+2017-09-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, sem_aux.adb, sem_res.adb: Minor reformatting.
+
+2017-09-06 Yannick Moy <moy@adacore.com>
+
+ * sem_ch12.adb (Analyze_Instance_And_Renamings): Refactor to set
+ global variable Ignore_SPARK_Mode_Pragmas_In_Instance only once.
+
+2017-09-06 Bob Duff <duff@adacore.com>
+
+ * sem_ch8.adb: Change Assert to be consistent with
+ other similar ones.
+
+2017-09-06 Bob Duff <duff@adacore.com>
+
+ * binde.adb (Find_Elab_Order): Do not run Elab_Old unless
+ requested. Previously, the -do switch meant "run Elab_New and
+ Elab_Old and use the order chosen by Elab_Old, possibly with
+ debugging printouts comparing the two orders." Now it means
+ "do not run Elab_New." This is of use if there are bugs that
+ cause Elab_New to crash.
+ (Elab_Position, Num_Chosen): Change type to Nat, to avoid various
+ type conversions.
+ * ali.ads (Elab_Position): Change type to Nat, to avoid various
+ type conversions.
+
+2017-09-06 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Fix
+ reference to SPARK RM.
+
+2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * layout.adb: Use SSU short hand consistently throughout the file.
+
+2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Record_Type)
+ <Sized_Component_Total_Round_RM_Size>: New local variable to
+ accumulate the rounded RM_Size of components. Update it for
+ every component whose RM_Size is statically known. Add missing
+ guard to check that bit packing is really required before issuing
+ the error about packing. Swap condition for clarity's sake.
+ * sem_prag.adb (Usage_Error): fix reference to
+ SPARK RM in comment
+
+2017-09-06 Fedor Rybin <frybin@adacore.com>
+
+ * makeutl.adb, makeutl.ads, mlib.adb, mlib.ads, mlib-fil.adb,
+ mlib-fil.ads, mlib-prj.adb, mlib-prj.ads, mlib-tgt.adb, mlib-tgt.ads,
+ mlib-tgt-specific.adb, mlib-tgt-specific.ads,
+ mlib-tgt-specific-aix.adb, mlib-tgt-specific-darwin.adb,
+ mlib-tgt-specific-hpux.adb, mlib-tgt-specific-linux.adb,
+ mlib-tgt-specific-mingw.adb, mlib-tgt-specific-solaris.adb,
+ mlib-tgt-specific-vxworks.adb, mlib-tgt-specific-xi.adb, mlib-utl.adb,
+ mlib-utl.ads, prj.adb, prj.ads, prj-attr.adb, prj-attr.ads,
+ prj-attr-pm.adb, prj-attr-pm.ads, prj-com.ads, prj-conf.adb,
+ prj-conf.ads, prj-dect.adb, prj-dect.ads, prj-env.adb, prj-env.ads,
+ prj-err.adb, prj-err.ads, prj-ext.adb, prj-ext.ads, prj-makr.adb,
+ prj-makr.ads, prj-nmsc.adb, prj-nmsc.ads, prj-pars.adb, prj-pars.ads,
+ prj-part.adb, prj-part.ads, prj-pp.adb, prj-pp.ads, prj-proc.adb,
+ prj-proc.ads, prj-strt.adb, prj-strt.ads, prj-tree.adb, prj-tree.ads,
+ prj-util.adb, prj-util.ads, sinput-p.adb, sinput-p.ads: Remove obsolete
+ project manager sources.
+
+2017-09-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Assigment): If the left-hand side is an
+ entity of a mutable type and the right-hand side is a conditional
+ expression, resolve the alternatives of the conditional using
+ the base type of the target entity, because the alternatives
+ may have distinct subtypes. This is particularly relevant if
+ the alternatives are aggregates.
+
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* checks.adb (Apply_Predicate_Check): If the expression is an
-- used for informational output, and also for constructing the main
-- unit if it is being built in Ada.
- Elab_Position : aliased Natural;
+ Elab_Position : Nat;
-- Initialized to zero. Set non-zero when a unit is chosen and
-- placed in the elaboration order. The value represents the
-- ordinal position in the elaboration order.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, 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- --
-- Used in computing transitive closure for Elaborate_All and also in
-- locating cycles and paths in the diagnose routines.
- Elab_Position : Natural;
+ Elab_Position : Nat;
-- Initialized to zero. Set non-zero when a unit is chosen and placed in
-- the elaboration order. The value represents the ordinal position in
-- the elaboration order.
-- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
-- set the Reason_Unit field of the created dependency link.
- Num_Chosen : Natural;
+ Num_Chosen : Nat;
-- Number of units chosen in the elaboration order so far
-----------------------
-- the reason for the link is R. Ea_Id is the contents to be placed in the
-- Elab_All_Link of the entry.
- procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id);
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id;
+ Msg : String);
-- Chosen is the next entry chosen in the elaboration order. This procedure
-- updates all data structures appropriately.
-- Choose --
------------
- procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id) is
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id;
+ Msg : String)
+ is
pragma Assert (Chosen /= No_Unit_Id);
S : Successor_Id;
U : Unit_Id;
if Debug_Flag_C then
Write_Str ("Choosing Unit ");
Write_Unit_Name (Units.Table (Chosen).Uname);
- Write_Eol;
+ Write_Str (Msg);
end if;
-- We shouldn't be choosing something with unelaborated predecessors,
Num_Chosen := Num_Chosen + 1;
pragma Assert
- (Errors_Detected > 0 or else Num_Chosen = Natural (Last (Elab_Order)));
+ (Errors_Detected > 0 or else Num_Chosen = Last (Elab_Order));
+ pragma Assert (Units.Last = UNR.Last);
+ pragma Assert (Num_Chosen + Num_Left = Int (UNR.Last));
+ if Debug_Flag_C then
+ Write_Str (" ");
+ Write_Int (Int (Num_Chosen));
+ Write_Str ("+");
+ Write_Int (Num_Left);
+ Write_Str ("=");
+ Write_Int (Int (UNR.Last));
+ Write_Eol;
+ end if;
UNR.Table (Chosen).Elab_Position := Num_Chosen;
then
null;
else
- Choose (Elab_Order, Corresponding_Body (Chosen));
+ Choose (Elab_Order, Corresponding_Body (Chosen),
+ " [Elaborate_Body]");
end if;
end if;
end Choose;
-- sufficiently long, generate error message and return True.
if U = Uto and then PL >= ML then
- Choose (Elab_Order, U);
+ Choose (Elab_Order, U, " [Find_Link: base]");
return True;
-- All done if already visited
while S /= No_Successor loop
if Find_Link (Succ.Table (S).After, PL + 1) then
Elab_Error_Msg (S);
- Choose (Elab_Order, U);
+ Choose (Elab_Order, U, " [Find_Link: recursive]");
return True;
end if;
Error_Msg ("?since all units compiled with static elaboration model");
end if;
- if Do_New then
+ if Do_New and not Debug_Flag_Old and not Debug_Flag_Older then
if Debug_Flag_V then
Write_Line ("Doing new...");
end if;
end if;
-- Elab_New does not support the pessimistic order, so if that was
- -- requested, use the old results. Use Elab_Old if -dp was selected.
- -- Elab_New does not yet give proper error messages for illegal
- -- Elaborate_Alls, so if there is one, run Elab_Old.
+ -- requested, use the old results. Use Elab_Old if -dp or -do was
+ -- selected. Elab_New does not yet give proper error messages for
+ -- illegal Elaborate_Alls, so if there is one, run Elab_Old.
if Do_Old
or Pessimistic_Elab_Order
or Debug_Flag_Old
+ or Debug_Flag_Older
or Illegal_Elab_All
then
if Debug_Flag_V then
declare
Old_Order : Unit_Id_Array renames
Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
- New_Order : Unit_Id_Array renames
- Elab_Order.Table (1 .. Last (Elab_Order));
- Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
- New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
-
begin
if Do_Old and Do_New then
- Write_Line (Get_Name_String (First_Main_Lib_File));
-
- pragma Assert (Old_Order'Length = New_Order'Length);
- pragma Debug (Validate (Old_Order, Doing_New => False));
- pragma Debug (Validate (New_Order, Doing_New => True));
+ declare
+ New_Order : Unit_Id_Array renames
+ Elab_Order.Table (1 .. Last (Elab_Order));
+ Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
+ New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
- -- Misc debug printouts that can be used for experimentation by
- -- changing the 'if's below.
+ begin
+ Write_Line (Get_Name_String (First_Main_Lib_File));
- if True then
- if New_Order = Old_Order then
- Write_Line ("Elab_New: same order.");
- else
- Write_Line ("Elab_New: diff order.");
- end if;
- end if;
+ pragma Assert (Old_Order'Length = New_Order'Length);
+ pragma Debug (Validate (Old_Order, Doing_New => False));
+ pragma Debug (Validate (New_Order, Doing_New => True));
- if New_Order /= Old_Order and then False then
- Write_Line ("Elaboration orders differ:");
- Write_Elab_Order
- (Old_Order, Title => "OLD ELABORATION ORDER");
- Write_Elab_Order
- (New_Order, Title => "NEW ELABORATION ORDER");
- end if;
+ -- Misc debug printouts that can be used for experimentation by
+ -- changing the 'if's below.
- if True then
- Write_Str ("Pairs: ");
- Write_Int (Old_Pairs);
+ if True then
+ if New_Order = Old_Order then
+ Write_Line ("Elab_New: same order.");
+ else
+ Write_Line ("Elab_New: diff order.");
+ end if;
+ end if;
- if Old_Pairs = New_Pairs then
- Write_Str (" = ");
- elsif Old_Pairs < New_Pairs then
- Write_Str (" < ");
- else
- Write_Str (" > ");
+ if New_Order /= Old_Order and then False then
+ Write_Line ("Elaboration orders differ:");
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
end if;
- Write_Int (New_Pairs);
- Write_Eol;
- end if;
+ if True then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- if Old_Pairs /= New_Pairs and then False then
- Write_Str ("Pairs: ");
- Write_Int (Old_Pairs);
+ if Old_Pairs = New_Pairs then
+ Write_Str (" = ");
+ elsif Old_Pairs < New_Pairs then
+ Write_Str (" < ");
+ else
+ Write_Str (" > ");
+ end if;
- if Old_Pairs < New_Pairs then
- Write_Str (" < ");
- else
- Write_Str (" > ");
+ Write_Int (New_Pairs);
+ Write_Eol;
end if;
- Write_Int (New_Pairs);
- Write_Eol;
+ if Old_Pairs /= New_Pairs and then False then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- if Old_Pairs /= New_Pairs and then Debug_Flag_V then
- Write_Elab_Order
- (Old_Order, Title => "OLD ELABORATION ORDER");
- Write_Elab_Order
- (New_Order, Title => "NEW ELABORATION ORDER");
- pragma Assert (New_Pairs >= Old_Pairs);
+ if Old_Pairs < New_Pairs then
+ Write_Str (" < ");
+ else
+ Write_Str (" > ");
+ end if;
+
+ Write_Int (New_Pairs);
+ Write_Eol;
+
+ if Old_Pairs /= New_Pairs and then Debug_Flag_V then
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
+ pragma Assert (New_Pairs >= Old_Pairs);
+ end if;
end if;
- end if;
+ end;
end if;
-- The Elab_New algorithm doesn't implement the -p switch, so if that
- -- was used, use the results from the old algorithm.
-
- if Pessimistic_Elab_Order or Debug_Flag_Old then
- New_Order := Old_Order;
+ -- was used, use the results from the old algorithm. Likewise if the
+ -- user has requested the old algorithm.
+
+ if Pessimistic_Elab_Order or Debug_Flag_Old or Debug_Flag_Older then
+ pragma Assert
+ (Last (Elab_Order) = 0
+ or else Last (Elab_Order) = Old_Order'Last);
+ Init (Elab_Order);
+ Append_All (Elab_Order, Old_Order);
end if;
-- Now set the Elab_Positions in the Units table. It is important to
-- do this late, in case we're running both Elab_New and Elab_Old.
declare
+ New_Order : Unit_Id_Array renames
+ Elab_Order.Table (1 .. Last (Elab_Order));
Units_Array : Units.Table_Type renames
Units.Table (Units.First .. Units.Last);
-
begin
for J in New_Order'Range loop
pragma Assert
- (UNR.Table (New_Order (J)).Elab_Position = Positive (J));
- Units_Array (New_Order (J)).Elab_Position := Positive (J);
+ (UNR.Table (New_Order (J)).Elab_Position = J);
+ Units_Array (New_Order (J)).Elab_Position := J;
end loop;
- end;
- if Errors_Detected = 0 then
+ if Errors_Detected = 0 then
- -- Display elaboration order if -l was specified
+ -- Display elaboration order if -l was specified
- if Elab_Order_Output then
- if Zero_Formatting then
- Write_Elab_Order (New_Order, Title => "");
- else
- Write_Elab_Order (New_Order, Title => "ELABORATION ORDER");
+ if Elab_Order_Output then
+ if Zero_Formatting then
+ Write_Elab_Order (New_Order, Title => "");
+ else
+ Write_Elab_Order
+ (New_Order, Title => "ELABORATION ORDER");
+ end if;
end if;
- end if;
- -- Display list of sources in the closure (except predefined
- -- sources) if -R was used. Include predefined sources if -Ra
- -- was used.
+ -- Display list of sources in the closure (except predefined
+ -- sources) if -R was used. Include predefined sources if -Ra
+ -- was used.
- if List_Closure then
- Write_Closure (New_Order);
+ if List_Closure then
+ Write_Closure (New_Order);
+ end if;
end if;
- end if;
+ end;
end;
end Find_Elab_Order;
-- a circularity. In the latter case, diagnose the circularity,
-- removing it from the graph and continue.
-- ????But Diagnose_Elaboration_Problem always raises an
- -- exception.
+ -- exception, so the loop never goes around more than once.
Get_No_Pred : while No_Pred = No_Unit_Id loop
exit Outer when Num_Left < 1;
-- Choose the best candidate found
- Choose (Elab_Order, Best_So_Far);
+ Choose (Elab_Order, Best_So_Far, " [Best_So_Far]");
-- If it's a spec with a body, and the body is not yet chosen,
-- choose the body if possible. The case where the body is
end if;
if Choose_The_Body then
- Choose (Elab_Order, Corresponding_Body (Best_So_Far));
+ Choose (Elab_Order, Corresponding_Body (Best_So_Far),
+ " [body]");
end if;
end;
end if;
and then UNR.Table (SCC (J)).Num_Pred = 0
then
Chose_One_Or_More := True;
- Choose (Elab_Order, SCC (J));
+ Choose (Elab_Order, SCC (J), " [same SCC]");
end if;
end loop;
pragma Assert (SCC (U) = U);
begin
for J in Nodes (U)'Range loop
- Write_Int (Int (UNR.Table (Nodes (U) (J)).Elab_Position));
+ Write_Int (UNR.Table (Nodes (U) (J)).Elab_Position);
Write_Str (". ");
Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
Write_Eol;
-- a circularity. In the latter case, diagnose the circularity,
-- removing it from the graph and continue.
-- ????But Diagnose_Elaboration_Problem always raises an
- -- exception.
+ -- exception, so the loop never goes around more than once.
Get_No_Pred : while No_Pred = No_Unit_Id loop
exit Outer when Num_Left < 1;
-- Choose the best candidate found
- Choose (Elab_Order, Best_So_Far);
+ Choose (Elab_Order, Best_So_Far, " [Elab_Old Best_So_Far]");
end loop Outer;
end Find_Elab_Order;
-- Accumulates total RM_Size values of all sized components. Used
-- for processing of Implicit_Packing.
+ Sized_Component_Total_Round_RM_Size : Uint := Uint_0;
+ -- Accumulates total RM_Size values of all sized components, rounded
+ -- individually to a multiple of the storage unit.
+
SSO_ADC : Node_Id;
-- Scalar_Storage_Order attribute definition clause for the record
-- an implicit subtype declaration.
if Known_Static_RM_Size (Etype (Comp)) then
- Sized_Component_Total_RM_Size :=
- Sized_Component_Total_RM_Size + RM_Size (Etype (Comp));
+ declare
+ Comp_Type : constant Entity_Id := Etype (Comp);
+ Comp_Size : constant Uint := RM_Size (Comp_Type);
+ SSU : constant Int := Ttypes.System_Storage_Unit;
+ begin
+ Sized_Component_Total_RM_Size :=
+ Sized_Component_Total_RM_Size + Comp_Size;
- if Present (Underlying_Type (Etype (Comp)))
- and then Is_Elementary_Type (Underlying_Type (Etype (Comp)))
- then
- Elem_Component_Total_Esize :=
- Elem_Component_Total_Esize + Esize (Etype (Comp));
- else
- All_Elem_Components := False;
+ Sized_Component_Total_Round_RM_Size :=
+ Sized_Component_Total_Round_RM_Size +
+ (Comp_Size + SSU - 1) / SSU * SSU;
- if RM_Size (Etype (Comp)) mod System_Storage_Unit /= 0 then
- All_Storage_Unit_Components := False;
+ if Present (Underlying_Type (Comp_Type))
+ and then Is_Elementary_Type (Underlying_Type (Comp_Type))
+ then
+ Elem_Component_Total_Esize :=
+ Elem_Component_Total_Esize + Esize (Comp_Type);
+ else
+ All_Elem_Components := False;
+
+ if Comp_Size mod SSU /= 0 then
+ All_Storage_Unit_Components := False;
+ end if;
end if;
- end if;
+ end;
else
All_Sized_Components := False;
end if;
and then RM_Size (Rec) < Elem_Component_Total_Esize)
or else
(not All_Elem_Components
- and then not All_Storage_Unit_Components))
+ and then not All_Storage_Unit_Components
+ and then RM_Size (Rec) < Sized_Component_Total_Round_RM_Size))
-- And the total RM size cannot be greater than the specified size
-- since otherwise packing will not get us where we have to be.
- and then RM_Size (Rec) >= Sized_Component_Total_RM_Size
+ and then Sized_Component_Total_RM_Size <= RM_Size (Rec)
-- Never do implicit packing in CodePeer or SPARK modes since
-- we don't do any packing in these modes, since this generates
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2017, 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- --
-- this means it will be storage-unit addressable).
if Is_Scalar_Type (E) then
- if Size <= System_Storage_Unit then
- Init_Esize (E, System_Storage_Unit);
+ if Size <= SSU then
+ Init_Esize (E, SSU);
elsif Size <= 16 then
Init_Esize (E, 16);
elsif Size <= 32 then
-- Finally, make sure that alignment is consistent with
-- the newly assigned size.
- while Alignment (E) * System_Storage_Unit < Esize (E)
+ while Alignment (E) * SSU < Esize (E)
and then Alignment (E) < Maximum_Alignment
loop
Set_Alignment (E, 2 * Alignment (E));
-- Reset alignment to match size if the known size is exactly 2, 4,
-- or 8 storage units.
- if Siz = 2 * System_Storage_Unit then
+ if Siz = 2 * SSU then
Align := 2;
- elsif Siz = 4 * System_Storage_Unit then
+ elsif Siz = 4 * SSU then
Align := 4;
- elsif Siz = 8 * System_Storage_Unit then
+ elsif Siz = 8 * SSU then
Align := 8;
-- If Optimize_Alignment is set to Space, then make sure the
-- bytes then we want an alignment of 1 for the type.
elsif Optimize_Alignment_Space (E) then
- if Siz mod (8 * System_Storage_Unit) = 0 then
+ if Siz mod (8 * SSU) = 0 then
Align := 8;
- elsif Siz mod (4 * System_Storage_Unit) = 0 then
+ elsif Siz mod (4 * SSU) = 0 then
Align := 4;
- elsif Siz mod (2 * System_Storage_Unit) = 0 then
+ elsif Siz mod (2 * SSU) = 0 then
Align := 2;
else
Align := 1;
-- alignment of 4.
elsif Optimize_Alignment_Time (E)
- and then Siz > System_Storage_Unit
- and then Siz <= 8 * System_Storage_Unit
+ and then Siz > SSU
+ and then Siz <= 8 * SSU
then
- if Siz <= 2 * System_Storage_Unit then
+ if Siz <= 2 * SSU then
Align := 2;
- elsif Siz <= 4 * System_Storage_Unit then
+ elsif Siz <= 4 * SSU then
Align := 4;
- else -- Siz <= 8 * System_Storage_Unit then
+ else -- Siz <= 8 * SSU then
Align := 8;
end if;
-- words in any case. Omit this if we are optimizing for time,
-- since conceivably we may be able to do better.
- if Align > System_Word_Size / System_Storage_Unit
+ if Align > System_Word_Size / SSU
and then not Optimize_Alignment_Time (E)
then
- Align := System_Word_Size / System_Storage_Unit;
+ Align := System_Word_Size / SSU;
end if;
-- Check components. If any component requires a higher alignment,
(Unknown_Esize (Comp)
or else (Known_Static_Esize (Comp)
and then
- Esize (Comp) =
- Calign * System_Storage_Unit))
+ Esize (Comp) = Calign * SSU))
then
Align := UI_To_Int (Calign);
end if;
Set_Alignment (E, UI_From_Int (Align));
if Known_Static_Esize (E)
- and then Esize (E) < Align * System_Storage_Unit
+ and then Esize (E) < Align * SSU
then
- Set_Esize (E, UI_From_Int (Align * System_Storage_Unit));
+ Set_Esize (E, UI_From_Int (Align * SSU));
end if;
end Set_Composite_Alignment;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M A K E U T L --
--- --
--- B o d y --
--- --
--- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with ALI; use ALI;
-with Atree; use Atree;
-with Debug;
-with Err_Vars; use Err_Vars;
-with Errutil;
-with Fname;
-with Osint; use Osint;
-with Output; use Output;
-with Opt; use Opt;
-with Prj.Com;
-with Prj.Err;
-with Prj.Ext;
-with Prj.Util; use Prj.Util;
-with Sinput.P;
-with Tempdir;
-
-with Ada.Command_Line; use Ada.Command_Line;
-with Ada.Unchecked_Deallocation;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.HTable;
-with GNAT.Regexp; use GNAT.Regexp;
-
-package body Makeutl is
-
- type Linker_Options_Data is record
- Project : Project_Id;
- Options : String_List_Id;
- end record;
-
- Linker_Option_Initial_Count : constant := 20;
-
- Linker_Options_Buffer : String_List_Access :=
- new String_List (1 .. Linker_Option_Initial_Count);
-
- Last_Linker_Option : Natural := 0;
-
- package Linker_Opts is new Table.Table (
- Table_Component_Type => Linker_Options_Data,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Make.Linker_Opts");
-
- procedure Add_Linker_Option (Option : String);
-
- ---------
- -- Add --
- ---------
-
- procedure Add
- (Option : String_Access;
- To : in out String_List_Access;
- Last : in out Natural)
- is
- begin
- if Last = To'Last then
- declare
- New_Options : constant String_List_Access :=
- new String_List (1 .. To'Last * 2);
-
- begin
- New_Options (To'Range) := To.all;
-
- -- Set all elements of the original options to null to avoid
- -- deallocation of copies.
-
- To.all := (others => null);
-
- Free (To);
- To := New_Options;
- end;
- end if;
-
- Last := Last + 1;
- To (Last) := Option;
- end Add;
-
- procedure Add
- (Option : String;
- To : in out String_List_Access;
- Last : in out Natural)
- is
- begin
- Add (Option => new String'(Option), To => To, Last => Last);
- end Add;
-
- -----------------------
- -- Add_Linker_Option --
- -----------------------
-
- procedure Add_Linker_Option (Option : String) is
- begin
- if Option'Length > 0 then
- if Last_Linker_Option = Linker_Options_Buffer'Last then
- declare
- New_Buffer : constant String_List_Access :=
- new String_List
- (1 .. Linker_Options_Buffer'Last +
- Linker_Option_Initial_Count);
- begin
- New_Buffer (Linker_Options_Buffer'Range) :=
- Linker_Options_Buffer.all;
- Linker_Options_Buffer.all := (others => null);
- Free (Linker_Options_Buffer);
- Linker_Options_Buffer := New_Buffer;
- end;
- end if;
-
- Last_Linker_Option := Last_Linker_Option + 1;
- Linker_Options_Buffer (Last_Linker_Option) := new String'(Option);
- end if;
- end Add_Linker_Option;
-
- -------------------
- -- Absolute_Path --
- -------------------
-
- function Absolute_Path
- (Path : Path_Name_Type;
- Project : Project_Id) return String
- is
- begin
- Get_Name_String (Path);
-
- declare
- Path_Name : constant String := Name_Buffer (1 .. Name_Len);
-
- begin
- if Is_Absolute_Path (Path_Name) then
- return Path_Name;
-
- else
- declare
- Parent_Directory : constant String :=
- Get_Name_String
- (Project.Directory.Display_Name);
-
- begin
- return Parent_Directory & Path_Name;
- end;
- end if;
- end;
- end Absolute_Path;
-
- ----------------------------
- -- Aggregate_Libraries_In --
- ----------------------------
-
- function Aggregate_Libraries_In (Tree : Project_Tree_Ref) return Boolean is
- List : Project_List;
-
- begin
- List := Tree.Projects;
- while List /= null loop
- if List.Project.Qualifier = Aggregate_Library then
- return True;
- end if;
-
- List := List.Next;
- end loop;
-
- return False;
- end Aggregate_Libraries_In;
-
- -------------------------
- -- Base_Name_Index_For --
- -------------------------
-
- function Base_Name_Index_For
- (Main : String;
- Main_Index : Int;
- Index_Separator : Character) return File_Name_Type
- is
- Result : File_Name_Type;
-
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Base_Name (Main));
-
- -- Remove the extension, if any, that is the last part of the base name
- -- starting with a dot and following some characters.
-
- for J in reverse 2 .. Name_Len loop
- if Name_Buffer (J) = '.' then
- Name_Len := J - 1;
- exit;
- end if;
- end loop;
-
- -- Add the index info, if index is different from 0
-
- if Main_Index > 0 then
- Add_Char_To_Name_Buffer (Index_Separator);
-
- declare
- Img : constant String := Main_Index'Img;
- begin
- Add_Str_To_Name_Buffer (Img (2 .. Img'Last));
- end;
- end if;
-
- Result := Name_Find;
- return Result;
- end Base_Name_Index_For;
-
- ------------------------------
- -- Check_Source_Info_In_ALI --
- ------------------------------
-
- function Check_Source_Info_In_ALI
- (The_ALI : ALI_Id;
- Tree : Project_Tree_Ref) return Name_Id
- is
- Result : Name_Id := No_Name;
- Unit_Name : Name_Id;
-
- begin
- -- Loop through units
-
- for U in ALIs.Table (The_ALI).First_Unit ..
- ALIs.Table (The_ALI).Last_Unit
- loop
- -- Check if the file name is one of the source of the unit
-
- Get_Name_String (Units.Table (U).Uname);
- Name_Len := Name_Len - 2;
- Unit_Name := Name_Find;
-
- if File_Not_A_Source_Of (Tree, Unit_Name, Units.Table (U).Sfile) then
- return No_Name;
- end if;
-
- if Result = No_Name then
- Result := Unit_Name;
- end if;
-
- -- Loop to do same check for each of the withed units
-
- for W in Units.Table (U).First_With .. Units.Table (U).Last_With loop
- declare
- WR : ALI.With_Record renames Withs.Table (W);
-
- begin
- if WR.Sfile /= No_File then
- Get_Name_String (WR.Uname);
- Name_Len := Name_Len - 2;
- Unit_Name := Name_Find;
-
- if File_Not_A_Source_Of (Tree, Unit_Name, WR.Sfile) then
- return No_Name;
- end if;
- end if;
- end;
- end loop;
- end loop;
-
- -- Loop to check subunits and replaced sources
-
- for D in ALIs.Table (The_ALI).First_Sdep ..
- ALIs.Table (The_ALI).Last_Sdep
- loop
- declare
- SD : Sdep_Record renames Sdep.Table (D);
-
- begin
- Unit_Name := SD.Subunit_Name;
-
- if Unit_Name = No_Name then
-
- -- Check if this source file has been replaced by a source with
- -- a different file name.
-
- if Tree /= null and then Tree.Replaced_Source_Number > 0 then
- declare
- Replacement : constant File_Name_Type :=
- Replaced_Source_HTable.Get
- (Tree.Replaced_Sources, SD.Sfile);
-
- begin
- if Replacement /= No_File then
- if Verbose_Mode then
- Write_Line
- ("source file"
- & Get_Name_String (SD.Sfile)
- & " has been replaced by "
- & Get_Name_String (Replacement));
- end if;
-
- return No_Name;
- end if;
- end;
- end if;
-
- -- Check that a dependent source for a unit that is from a
- -- project is indeed a source of this unit.
-
- Unit_Name := SD.Unit_Name;
-
- if Unit_Name /= No_Name
- and then not Fname.Is_Internal_File_Name (SD.Sfile)
- and then File_Not_A_Source_Of (Tree, Unit_Name, SD.Sfile)
- then
- return No_Name;
- end if;
-
- else
- -- For separates, the file is no longer associated with the
- -- unit ("proc-sep.adb" is not associated with unit "proc.sep")
- -- so we need to check whether the source file still exists in
- -- the source tree: it will if it matches the naming scheme
- -- (and then will be for the same unit).
-
- if Find_Source
- (In_Tree => Tree,
- Project => No_Project,
- Base_Name => SD.Sfile) = No_Source
- then
- -- If this is not a runtime file or if, when gnatmake switch
- -- -a is used, we are not able to find this subunit in the
- -- source directories, then recompilation is needed.
-
- if not Fname.Is_Internal_File_Name (SD.Sfile)
- or else
- (Check_Readonly_Files
- and then Full_Source_Name (SD.Sfile) = No_File)
- then
- if Verbose_Mode then
- Write_Line
- ("While parsing ALI file, file "
- & Get_Name_String (SD.Sfile)
- & " is indicated as containing subunit "
- & Get_Name_String (Unit_Name)
- & " but this does not match what was found while"
- & " parsing the project. Will recompile");
- end if;
-
- return No_Name;
- end if;
- end if;
- end if;
- end;
- end loop;
-
- return Result;
- end Check_Source_Info_In_ALI;
-
- --------------------------------
- -- Create_Binder_Mapping_File --
- --------------------------------
-
- function Create_Binder_Mapping_File
- (Project_Tree : Project_Tree_Ref) return Path_Name_Type
- is
- Mapping_Path : Path_Name_Type := No_Path;
-
- Mapping_FD : File_Descriptor := Invalid_FD;
- -- A File Descriptor for an eventual mapping file
-
- ALI_Unit : Unit_Name_Type := No_Unit_Name;
- -- The unit name of an ALI file
-
- ALI_Name : File_Name_Type := No_File;
- -- The file name of the ALI file
-
- ALI_Project : Project_Id := No_Project;
- -- The project of the ALI file
-
- Bytes : Integer;
- OK : Boolean := False;
- Unit : Unit_Index;
-
- Status : Boolean;
- -- For call to Close
-
- Iter : Source_Iterator := For_Each_Source
- (In_Tree => Project_Tree,
- Language => Name_Ada,
- Encapsulated_Libs => False,
- Locally_Removed => False);
-
- Source : Prj.Source_Id;
-
- begin
- Tempdir.Create_Temp_File (Mapping_FD, Mapping_Path);
- Record_Temp_File (Project_Tree.Shared, Mapping_Path);
-
- if Mapping_FD /= Invalid_FD then
- OK := True;
-
- loop
- Source := Element (Iter);
- exit when Source = No_Source;
-
- Unit := Source.Unit;
-
- if Source.Replaced_By /= No_Source
- or else Unit = No_Unit_Index
- or else Unit.Name = No_Name
- then
- ALI_Name := No_File;
-
- -- If this is a body, put it in the mapping
-
- elsif Source.Kind = Impl
- and then Unit.File_Names (Impl) /= No_Source
- and then Unit.File_Names (Impl).Project /= No_Project
- then
- Get_Name_String (Unit.Name);
- Add_Str_To_Name_Buffer ("%b");
- ALI_Unit := Name_Find;
- ALI_Name :=
- Lib_File_Name (Unit.File_Names (Impl).Display_File);
- ALI_Project := Unit.File_Names (Impl).Project;
-
- -- Otherwise, if this is a spec and there is no body, put it in
- -- the mapping.
-
- elsif Source.Kind = Spec
- and then Unit.File_Names (Impl) = No_Source
- and then Unit.File_Names (Spec) /= No_Source
- and then Unit.File_Names (Spec).Project /= No_Project
- then
- Get_Name_String (Unit.Name);
- Add_Str_To_Name_Buffer ("%s");
- ALI_Unit := Name_Find;
- ALI_Name :=
- Lib_File_Name (Unit.File_Names (Spec).Display_File);
- ALI_Project := Unit.File_Names (Spec).Project;
-
- else
- ALI_Name := No_File;
- end if;
-
- -- If we have something to put in the mapping then do it now. If
- -- the project is extended, look for the ALI file in the project,
- -- then in the extending projects in order, and use the last one
- -- found.
-
- if ALI_Name /= No_File then
-
- -- Look in the project and the projects that are extending it
- -- to find the real ALI file.
-
- declare
- ALI : constant String := Get_Name_String (ALI_Name);
- ALI_Path : Name_Id := No_Name;
-
- begin
- loop
- -- For library projects, use the library ALI directory,
- -- for other projects, use the object directory.
-
- if ALI_Project.Library then
- Get_Name_String
- (ALI_Project.Library_ALI_Dir.Display_Name);
- else
- Get_Name_String
- (ALI_Project.Object_Directory.Display_Name);
- end if;
-
- Add_Str_To_Name_Buffer (ALI);
-
- if Is_Regular_File (Name_Buffer (1 .. Name_Len)) then
- ALI_Path := Name_Find;
- end if;
-
- ALI_Project := ALI_Project.Extended_By;
- exit when ALI_Project = No_Project;
- end loop;
-
- if ALI_Path /= No_Name then
-
- -- First line is the unit name
-
- Get_Name_String (ALI_Unit);
- Add_Char_To_Name_Buffer (ASCII.LF);
- Bytes :=
- Write
- (Mapping_FD,
- Name_Buffer (1)'Address,
- Name_Len);
- OK := Bytes = Name_Len;
-
- exit when not OK;
-
- -- Second line is the ALI file name
-
- Get_Name_String (ALI_Name);
- Add_Char_To_Name_Buffer (ASCII.LF);
- Bytes :=
- Write
- (Mapping_FD,
- Name_Buffer (1)'Address,
- Name_Len);
- OK := (Bytes = Name_Len);
-
- exit when not OK;
-
- -- Third line is the ALI path name
-
- Get_Name_String (ALI_Path);
- Add_Char_To_Name_Buffer (ASCII.LF);
- Bytes :=
- Write
- (Mapping_FD,
- Name_Buffer (1)'Address,
- Name_Len);
- OK := (Bytes = Name_Len);
-
- -- If OK is False, it means we were unable to write a
- -- line. No point in continuing with the other units.
-
- exit when not OK;
- end if;
- end;
- end if;
-
- Next (Iter);
- end loop;
-
- Close (Mapping_FD, Status);
-
- OK := OK and Status;
- end if;
-
- -- If the creation of the mapping file was successful, we add the switch
- -- to the arguments of gnatbind.
-
- if OK then
- return Mapping_Path;
-
- else
- return No_Path;
- end if;
- end Create_Binder_Mapping_File;
-
- -----------------
- -- Create_Name --
- -----------------
-
- function Create_Name (Name : String) return File_Name_Type is
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name);
- return Name_Find;
- end Create_Name;
-
- function Create_Name (Name : String) return Name_Id is
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name);
- return Name_Find;
- end Create_Name;
-
- function Create_Name (Name : String) return Path_Name_Type is
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name);
- return Name_Find;
- end Create_Name;
-
- ---------------------------
- -- Ensure_Absolute_Path --
- ---------------------------
-
- procedure Ensure_Absolute_Path
- (Switch : in out String_Access;
- Parent : String;
- Do_Fail : Fail_Proc;
- For_Gnatbind : Boolean := False;
- Including_Non_Switch : Boolean := True;
- Including_RTS : Boolean := False)
- is
- begin
- if Switch /= null then
- declare
- Sw : String (1 .. Switch'Length);
- Start : Positive;
-
- begin
- Sw := Switch.all;
-
- if Sw (1) = '-' then
- if Sw'Length >= 3
- and then (Sw (2) = 'I'
- or else (not For_Gnatbind
- and then (Sw (2) = 'L'
- or else
- Sw (2) = 'A')))
- then
- Start := 3;
-
- if Sw = "-I-" then
- return;
- end if;
-
- elsif Sw'Length >= 4
- and then
- (Sw (2 .. 3) = "aL" or else
- Sw (2 .. 3) = "aO" or else
- Sw (2 .. 3) = "aI"
- or else (For_Gnatbind and then Sw (2 .. 3) = "A="))
- then
- Start := 4;
-
- elsif Including_RTS
- and then Sw'Length >= 7
- and then Sw (2 .. 6) = "-RTS="
- then
- Start := 7;
-
- else
- return;
- end if;
-
- -- Because relative path arguments to --RTS= may be relative to
- -- the search directory prefix, those relative path arguments
- -- are converted only when they include directory information.
-
- if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
- if Parent'Length = 0 then
- Do_Fail
- ("relative search path switches ("""
- & Sw
- & """) are not allowed");
-
- elsif Including_RTS then
- for J in Start .. Sw'Last loop
- if Sw (J) = Directory_Separator then
- Switch :=
- new String'
- (Sw (1 .. Start - 1)
- & Parent
- & Directory_Separator
- & Sw (Start .. Sw'Last));
- return;
- end if;
- end loop;
-
- else
- Switch :=
- new String'
- (Sw (1 .. Start - 1)
- & Parent
- & Directory_Separator
- & Sw (Start .. Sw'Last));
- end if;
- end if;
-
- elsif Including_Non_Switch then
- if not Is_Absolute_Path (Sw) then
- if Parent'Length = 0 then
- Do_Fail
- ("relative paths (""" & Sw & """) are not allowed");
- else
- Switch := new String'(Parent & Directory_Separator & Sw);
- end if;
- end if;
- end if;
- end;
- end if;
- end Ensure_Absolute_Path;
-
- ----------------------------
- -- Executable_Prefix_Path --
- ----------------------------
-
- function Executable_Prefix_Path return String is
- Exec_Name : constant String := Command_Name;
-
- function Get_Install_Dir (S : String) return String;
- -- S is the executable name preceded by the absolute or relative path,
- -- e.g. "c:\usr\bin\gcc.exe". Returns the absolute directory where "bin"
- -- lies (in the example "C:\usr"). If the executable is not in a "bin"
- -- directory, return "".
-
- ---------------------
- -- Get_Install_Dir --
- ---------------------
-
- function Get_Install_Dir (S : String) return String is
- Exec : String := S;
- Path_Last : Integer := 0;
-
- begin
- for J in reverse Exec'Range loop
- if Exec (J) = Directory_Separator then
- Path_Last := J - 1;
- exit;
- end if;
- end loop;
-
- if Path_Last >= Exec'First + 2 then
- To_Lower (Exec (Path_Last - 2 .. Path_Last));
- end if;
-
- if Path_Last < Exec'First + 2
- or else Exec (Path_Last - 2 .. Path_Last) /= "bin"
- or else (Path_Last - 3 >= Exec'First
- and then Exec (Path_Last - 3) /= Directory_Separator)
- then
- return "";
- end if;
-
- return Normalize_Pathname
- (Exec (Exec'First .. Path_Last - 4),
- Resolve_Links => Opt.Follow_Links_For_Dirs)
- & Directory_Separator;
- end Get_Install_Dir;
-
- -- Beginning of Executable_Prefix_Path
-
- begin
- -- First determine if a path prefix was placed in front of the
- -- executable name.
-
- for J in reverse Exec_Name'Range loop
- if Exec_Name (J) = Directory_Separator then
- return Get_Install_Dir (Exec_Name);
- end if;
- end loop;
-
- -- If we get here, the user has typed the executable name with no
- -- directory prefix.
-
- declare
- Path : String_Access := Locate_Exec_On_Path (Exec_Name);
- begin
- if Path = null then
- return "";
- else
- declare
- Dir : constant String := Get_Install_Dir (Path.all);
- begin
- Free (Path);
- return Dir;
- end;
- end if;
- end;
- end Executable_Prefix_Path;
-
- ------------------
- -- Fail_Program --
- ------------------
-
- procedure Fail_Program
- (Project_Tree : Project_Tree_Ref;
- S : String;
- Flush_Messages : Boolean := True)
- is
- begin
- if Flush_Messages and not No_Exit_Message then
- if Total_Errors_Detected /= 0 or else Warnings_Detected /= 0 then
- Errutil.Finalize;
- end if;
- end if;
-
- Finish_Program (Project_Tree, E_Fatal, S => S);
- end Fail_Program;
-
- --------------------
- -- Finish_Program --
- --------------------
-
- procedure Finish_Program
- (Project_Tree : Project_Tree_Ref;
- Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
- S : String := "")
- is
- begin
- if not Debug.Debug_Flag_N then
- Delete_Temp_Config_Files (Project_Tree);
-
- if Project_Tree /= null then
- Delete_All_Temp_Files (Project_Tree.Shared);
- end if;
- end if;
-
- if S'Length > 0 then
- if Exit_Code /= E_Success then
- if No_Exit_Message then
- Osint.Exit_Program (E_Fatal);
- else
- Osint.Fail (S);
- end if;
-
- elsif not No_Exit_Message then
- Write_Str (S);
- end if;
- end if;
-
- -- Output Namet statistics
-
- Namet.Finalize;
-
- Exit_Program (Exit_Code);
- end Finish_Program;
-
- --------------------------
- -- File_Not_A_Source_Of --
- --------------------------
-
- function File_Not_A_Source_Of
- (Project_Tree : Project_Tree_Ref;
- Uname : Name_Id;
- Sfile : File_Name_Type) return Boolean
- is
- Unit : constant Unit_Index :=
- Units_Htable.Get (Project_Tree.Units_HT, Uname);
-
- At_Least_One_File : Boolean := False;
-
- begin
- if Unit /= No_Unit_Index then
- for F in Unit.File_Names'Range loop
- if Unit.File_Names (F) /= null then
- At_Least_One_File := True;
- if Unit.File_Names (F).File = Sfile then
- return False;
- end if;
- end if;
- end loop;
-
- if not At_Least_One_File then
-
- -- The unit was probably created initially for a separate unit
- -- (which are initially created as IMPL when both suffixes are the
- -- same). Later on, Override_Kind changed the type of the file,
- -- and the unit is no longer valid in fact.
-
- return False;
- end if;
-
- Verbose_Msg (Uname, "sources do not include ", Name_Id (Sfile));
- return True;
- end if;
-
- return False;
- end File_Not_A_Source_Of;
-
- ---------------------
- -- Get_Directories --
- ---------------------
-
- procedure Get_Directories
- (Project_Tree : Project_Tree_Ref;
- For_Project : Project_Id;
- Activity : Activity_Type;
- Languages : Name_Ids)
- is
-
- procedure Recursive_Add
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Extended : in out Boolean);
- -- Add all the source directories of a project to the path only if
- -- this project has not been visited. Calls itself recursively for
- -- projects being extended, and imported projects.
-
- procedure Add_Dir (Value : Path_Name_Type);
- -- Add directory Value in table Directories, if it is defined and not
- -- already there.
-
- -------------
- -- Add_Dir --
- -------------
-
- procedure Add_Dir (Value : Path_Name_Type) is
- Add_It : Boolean := True;
-
- begin
- if Value /= No_Path
- and then Is_Directory (Get_Name_String (Value))
- then
- for Index in 1 .. Directories.Last loop
- if Directories.Table (Index) = Value then
- Add_It := False;
- exit;
- end if;
- end loop;
-
- if Add_It then
- Directories.Increment_Last;
- Directories.Table (Directories.Last) := Value;
- end if;
- end if;
- end Add_Dir;
-
- -------------------
- -- Recursive_Add --
- -------------------
-
- procedure Recursive_Add
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Extended : in out Boolean)
- is
- Current : String_List_Id;
- Dir : String_Element;
- OK : Boolean := False;
- Lang_Proc : Language_Ptr := Project.Languages;
-
- begin
- -- Add to path all directories of this project
-
- if Activity = Compilation then
- Lang_Loop :
- while Lang_Proc /= No_Language_Index loop
- for J in Languages'Range loop
- OK := Lang_Proc.Name = Languages (J);
- exit Lang_Loop when OK;
- end loop;
-
- Lang_Proc := Lang_Proc.Next;
- end loop Lang_Loop;
-
- if OK then
- Current := Project.Source_Dirs;
-
- while Current /= Nil_String loop
- Dir := Tree.Shared.String_Elements.Table (Current);
- Add_Dir (Path_Name_Type (Dir.Value));
- Current := Dir.Next;
- end loop;
- end if;
-
- elsif Project.Library then
- if Activity = SAL_Binding and then Extended then
- Add_Dir (Project.Object_Directory.Display_Name);
-
- else
- Add_Dir (Project.Library_ALI_Dir.Display_Name);
- end if;
-
- else
- Add_Dir (Project.Object_Directory.Display_Name);
- end if;
-
- if Project.Extends = No_Project then
- Extended := False;
- end if;
- end Recursive_Add;
-
- procedure For_All_Projects is
- new For_Every_Project_Imported (Boolean, Recursive_Add);
-
- Extended : Boolean := True;
-
- -- Start of processing for Get_Directories
-
- begin
- Directories.Init;
- For_All_Projects (For_Project, Project_Tree, Extended);
- end Get_Directories;
-
- ------------------
- -- Get_Switches --
- ------------------
-
- procedure Get_Switches
- (Source : Prj.Source_Id;
- Pkg_Name : Name_Id;
- Project_Tree : Project_Tree_Ref;
- Value : out Variable_Value;
- Is_Default : out Boolean)
- is
- begin
- Get_Switches
- (Source_File => Source.File,
- Source_Lang => Source.Language.Name,
- Source_Prj => Source.Project,
- Pkg_Name => Pkg_Name,
- Project_Tree => Project_Tree,
- Value => Value,
- Is_Default => Is_Default);
- end Get_Switches;
-
- ------------------
- -- Get_Switches --
- ------------------
-
- procedure Get_Switches
- (Source_File : File_Name_Type;
- Source_Lang : Name_Id;
- Source_Prj : Project_Id;
- Pkg_Name : Name_Id;
- Project_Tree : Project_Tree_Ref;
- Value : out Variable_Value;
- Is_Default : out Boolean;
- Test_Without_Suffix : Boolean := False;
- Check_ALI_Suffix : Boolean := False)
- is
- Project : constant Project_Id :=
- Ultimate_Extending_Project_Of (Source_Prj);
- Pkg : constant Package_Id :=
- Prj.Util.Value_Of
- (Name => Pkg_Name,
- In_Packages => Project.Decl.Packages,
- Shared => Project_Tree.Shared);
- Lang : Language_Ptr;
-
- begin
- Is_Default := False;
-
- if Source_File /= No_File then
- Value := Prj.Util.Value_Of
- (Name => Name_Id (Source_File),
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Pkg,
- Shared => Project_Tree.Shared,
- Allow_Wildcards => True);
- end if;
-
- if Value = Nil_Variable_Value and then Test_Without_Suffix then
- Lang :=
- Get_Language_From_Name (Project, Get_Name_String (Source_Lang));
-
- if Lang /= null then
- declare
- Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
- SF_Name : constant String := Get_Name_String (Source_File);
- Last : Positive := SF_Name'Length;
- Name : String (1 .. Last + 3);
- Spec_Suffix : String := Get_Name_String (Naming.Spec_Suffix);
- Body_Suffix : String := Get_Name_String (Naming.Body_Suffix);
- Truncated : Boolean := False;
-
- begin
- Canonical_Case_File_Name (Spec_Suffix);
- Canonical_Case_File_Name (Body_Suffix);
- Name (1 .. Last) := SF_Name;
-
- if Last > Body_Suffix'Length
- and then
- Name (Last - Body_Suffix'Length + 1 .. Last) = Body_Suffix
- then
- Truncated := True;
- Last := Last - Body_Suffix'Length;
- end if;
-
- if not Truncated
- and then Last > Spec_Suffix'Length
- and then
- Name (Last - Spec_Suffix'Length + 1 .. Last) = Spec_Suffix
- then
- Truncated := True;
- Last := Last - Spec_Suffix'Length;
- end if;
-
- if Truncated then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name (1 .. Last));
-
- Value := Prj.Util.Value_Of
- (Name => Name_Find,
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Pkg,
- Shared => Project_Tree.Shared,
- Allow_Wildcards => True);
- end if;
-
- if Value = Nil_Variable_Value and then Check_ALI_Suffix then
- Last := SF_Name'Length;
- while Name (Last) /= '.' loop
- Last := Last - 1;
- end loop;
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name (1 .. Last));
- Add_Str_To_Name_Buffer ("ali");
-
- Value := Prj.Util.Value_Of
- (Name => Name_Find,
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Pkg,
- Shared => Project_Tree.Shared,
- Allow_Wildcards => True);
- end if;
- end;
- end if;
- end if;
-
- if Value = Nil_Variable_Value then
- Is_Default := True;
- Value :=
- Prj.Util.Value_Of
- (Name => Source_Lang,
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Pkg,
- Shared => Project_Tree.Shared,
- Force_Lower_Case_Index => True);
- end if;
-
- if Value = Nil_Variable_Value then
- Value :=
- Prj.Util.Value_Of
- (Name => All_Other_Names,
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Pkg,
- Shared => Project_Tree.Shared,
- Force_Lower_Case_Index => True);
- end if;
-
- if Value = Nil_Variable_Value then
- Value :=
- Prj.Util.Value_Of
- (Name => Source_Lang,
- Attribute_Or_Array_Name => Name_Default_Switches,
- In_Package => Pkg,
- Shared => Project_Tree.Shared);
- end if;
- end Get_Switches;
-
- ------------
- -- Inform --
- ------------
-
- procedure Inform (N : File_Name_Type; Msg : String) is
- begin
- Inform (Name_Id (N), Msg);
- end Inform;
-
- procedure Inform (N : Name_Id := No_Name; Msg : String) is
- begin
- Osint.Write_Program_Name;
-
- Write_Str (": ");
-
- if N /= No_Name then
- Write_Str ("""");
-
- declare
- Name : constant String := Get_Name_String (N);
- begin
- if Debug.Debug_Flag_F and then Is_Absolute_Path (Name) then
- Write_Str (File_Name (Name));
- else
- Write_Str (Name);
- end if;
- end;
-
- Write_Str (""" ");
- end if;
-
- Write_Str (Msg);
- Write_Eol;
- end Inform;
-
- ------------------------------
- -- Initialize_Source_Record --
- ------------------------------
-
- procedure Initialize_Source_Record (Source : Prj.Source_Id) is
-
- procedure Set_Object_Project
- (Obj_Dir : String;
- Obj_Proj : Project_Id;
- Obj_Path : Path_Name_Type;
- Stamp : Time_Stamp_Type);
- -- Update information about object file, switches file,...
-
- ------------------------
- -- Set_Object_Project --
- ------------------------
-
- procedure Set_Object_Project
- (Obj_Dir : String;
- Obj_Proj : Project_Id;
- Obj_Path : Path_Name_Type;
- Stamp : Time_Stamp_Type) is
- begin
- Source.Object_Project := Obj_Proj;
- Source.Object_Path := Obj_Path;
- Source.Object_TS := Stamp;
-
- if Source.Language.Config.Dependency_Kind /= None then
- declare
- Dep_Path : constant String :=
- Normalize_Pathname
- (Name =>
- Get_Name_String (Source.Dep_Name),
- Resolve_Links => Opt.Follow_Links_For_Files,
- Directory => Obj_Dir);
- begin
- Source.Dep_Path := Create_Name (Dep_Path);
- Source.Dep_TS := Osint.Unknown_Attributes;
- end;
- end if;
-
- -- Get the path of the switches file, even if Opt.Check_Switches is
- -- not set, as switch -s may be in the Builder switches that have not
- -- been scanned yet.
-
- declare
- Switches_Path : constant String :=
- Normalize_Pathname
- (Name =>
- Get_Name_String (Source.Switches),
- Resolve_Links => Opt.Follow_Links_For_Files,
- Directory => Obj_Dir);
- begin
- Source.Switches_Path := Create_Name (Switches_Path);
-
- if Stamp /= Empty_Time_Stamp then
- Source.Switches_TS := File_Stamp (Source.Switches_Path);
- end if;
- end;
- end Set_Object_Project;
-
- Obj_Proj : Project_Id;
-
- begin
- -- Nothing to do if source record has already been fully initialized
-
- if Source.Initialized then
- return;
- end if;
-
- -- Systematically recompute the time stamp
-
- Source.Source_TS := File_Stamp (Source.Path.Display_Name);
-
- -- Parse the source file to check whether we have a subunit
-
- if Source.Language.Config.Kind = Unit_Based
- and then Source.Kind = Impl
- and then Is_Subunit (Source)
- then
- Source.Kind := Sep;
- end if;
-
- if Source.Language.Config.Object_Generated
- and then Is_Compilable (Source)
- then
- -- First, get the correct object file name and dependency file name
- -- if the source is in a multi-unit file.
-
- if Source.Index /= 0 then
- Source.Object :=
- Object_Name
- (Source_File_Name => Source.File,
- Source_Index => Source.Index,
- Index_Separator =>
- Source.Language.Config.Multi_Unit_Object_Separator,
- Object_File_Suffix =>
- Source.Language.Config.Object_File_Suffix);
-
- Source.Dep_Name :=
- Dependency_Name
- (Source.Object, Source.Language.Config.Dependency_Kind);
- end if;
-
- -- Find the object file for that source. It could be either in the
- -- current project or in an extended project (it might actually not
- -- exist yet in the ultimate extending project, but if not found
- -- elsewhere that's where we'll expect to find it).
-
- Obj_Proj := Source.Project;
-
- while Obj_Proj /= No_Project loop
- if Obj_Proj.Object_Directory /= No_Path_Information then
- declare
- Dir : constant String :=
- Get_Name_String (Obj_Proj.Object_Directory.Display_Name);
-
- Object_Path : constant String :=
- Normalize_Pathname
- (Name => Get_Name_String (Source.Object),
- Resolve_Links => Opt.Follow_Links_For_Files,
- Directory => Dir);
-
- Obj_Path : constant Path_Name_Type :=
- Create_Name (Object_Path);
-
- Stamp : Time_Stamp_Type := Empty_Time_Stamp;
-
- begin
- -- For specs, we do not check object files if there is a
- -- body. This saves a system call. On the other hand, we do
- -- need to know the object_path, in case the user has passed
- -- the .ads on the command line to compile the spec only.
-
- if Source.Kind /= Spec
- or else Source.Unit = No_Unit_Index
- or else Source.Unit.File_Names (Impl) = No_Source
- then
- Stamp := File_Stamp (Obj_Path);
- end if;
-
- if Stamp /= Empty_Time_Stamp
- or else (Obj_Proj.Extended_By = No_Project
- and then Source.Object_Project = No_Project)
- then
- Set_Object_Project (Dir, Obj_Proj, Obj_Path, Stamp);
- end if;
- end;
- end if;
-
- Obj_Proj := Obj_Proj.Extended_By;
- end loop;
-
- elsif Source.Language.Config.Dependency_Kind = Makefile then
- declare
- Object_Dir : constant String :=
- Get_Name_String (Source.Project.Object_Directory.Display_Name);
- Dep_Path : constant String :=
- Normalize_Pathname
- (Name => Get_Name_String (Source.Dep_Name),
- Resolve_Links => Opt.Follow_Links_For_Files,
- Directory => Object_Dir);
- begin
- Source.Dep_Path := Create_Name (Dep_Path);
- Source.Dep_TS := Osint.Unknown_Attributes;
- end;
- end if;
-
- Source.Initialized := True;
- end Initialize_Source_Record;
-
- ----------------------------
- -- Is_External_Assignment --
- ----------------------------
-
- function Is_External_Assignment
- (Env : Prj.Tree.Environment;
- Argv : String) return Boolean
- is
- Start : Positive := 3;
- Finish : Natural := Argv'Last;
-
- pragma Assert (Argv'First = 1);
- pragma Assert (Argv (1 .. 2) = "-X");
-
- begin
- if Argv'Last < 5 then
- return False;
-
- elsif Argv (3) = '"' then
- if Argv (Argv'Last) /= '"' or else Argv'Last < 7 then
- return False;
- else
- Start := 4;
- Finish := Argv'Last - 1;
- end if;
- end if;
-
- return Prj.Ext.Check
- (Self => Env.External,
- Declaration => Argv (Start .. Finish));
- end Is_External_Assignment;
-
- ----------------
- -- Is_Subunit --
- ----------------
-
- function Is_Subunit (Source : Prj.Source_Id) return Boolean is
- Src_Ind : Source_File_Index;
-
- begin
- if Source.Kind = Sep then
- return True;
-
- -- A Spec, a file based language source or a body with a spec cannot be
- -- a subunit.
-
- elsif Source.Kind = Spec
- or else Source.Unit = No_Unit_Index
- or else Other_Part (Source) /= No_Source
- then
- return False;
- end if;
-
- -- Here, we are assuming that the language is Ada, as it is the only
- -- unit based language that we know.
-
- Src_Ind :=
- Sinput.P.Load_Project_File
- (Get_Name_String (Source.Path.Display_Name));
-
- return Sinput.P.Source_File_Is_Subunit (Src_Ind);
- end Is_Subunit;
-
- -----------------------------
- -- Linker_Options_Switches --
- -----------------------------
-
- function Linker_Options_Switches
- (Project : Project_Id;
- Do_Fail : Fail_Proc;
- In_Tree : Project_Tree_Ref) return String_List
- is
- procedure Recursive_Add
- (Proj : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean);
- -- The recursive routine used to add linker options
-
- -------------------
- -- Recursive_Add --
- -------------------
-
- procedure Recursive_Add
- (Proj : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean)
- is
- Linker_Package : Package_Id;
- Options : Variable_Value;
-
- begin
- Linker_Package :=
- Prj.Util.Value_Of
- (Name => Name_Linker,
- In_Packages => Proj.Decl.Packages,
- Shared => In_Tree.Shared);
-
- Options :=
- Prj.Util.Value_Of
- (Name => Name_Ada,
- Index => 0,
- Attribute_Or_Array_Name => Name_Linker_Options,
- In_Package => Linker_Package,
- Shared => In_Tree.Shared);
-
- -- If attribute is present, add the project with the attribute to
- -- table Linker_Opts.
-
- if Options /= Nil_Variable_Value then
- Linker_Opts.Increment_Last;
- Linker_Opts.Table (Linker_Opts.Last) :=
- (Project => Proj, Options => Options.Values);
- end if;
- end Recursive_Add;
-
- procedure For_All_Projects is
- new For_Every_Project_Imported (Boolean, Recursive_Add);
-
- Dummy : Boolean := False;
-
- -- Start of processing for Linker_Options_Switches
-
- begin
- Linker_Opts.Init;
-
- For_All_Projects (Project, In_Tree, Dummy, Imported_First => True);
-
- Last_Linker_Option := 0;
-
- for Index in reverse 1 .. Linker_Opts.Last loop
- declare
- Options : String_List_Id;
- Proj : constant Project_Id :=
- Linker_Opts.Table (Index).Project;
- Option : Name_Id;
- Dir_Path : constant String :=
- Get_Name_String (Proj.Directory.Name);
-
- begin
- Options := Linker_Opts.Table (Index).Options;
- while Options /= Nil_String loop
- Option := In_Tree.Shared.String_Elements.Table (Options).Value;
- Get_Name_String (Option);
-
- -- Do not consider empty linker options
-
- if Name_Len /= 0 then
- Add_Linker_Option (Name_Buffer (1 .. Name_Len));
-
- -- Object files and -L switches specified with relative
- -- paths must be converted to absolute paths.
-
- Ensure_Absolute_Path
- (Switch =>
- Linker_Options_Buffer (Last_Linker_Option),
- Parent => Dir_Path,
- Do_Fail => Do_Fail,
- For_Gnatbind => False);
- end if;
-
- Options := In_Tree.Shared.String_Elements.Table (Options).Next;
- end loop;
- end;
- end loop;
-
- return Linker_Options_Buffer (1 .. Last_Linker_Option);
- end Linker_Options_Switches;
-
- -----------
- -- Mains --
- -----------
-
- package body Mains is
-
- package Names is new Table.Table
- (Table_Component_Type => Main_Info,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Makeutl.Mains.Names");
- -- The table that stores the mains
-
- Current : Natural := 0;
- -- The index of the last main retrieved from the table
-
- Count_Of_Mains_With_No_Tree : Natural := 0;
- -- Number of main units for which we do not know the project tree
-
- --------------
- -- Add_Main --
- --------------
-
- procedure Add_Main
- (Name : String;
- Index : Int := 0;
- Location : Source_Ptr := No_Location;
- Project : Project_Id := No_Project;
- Tree : Project_Tree_Ref := null)
- is
- begin
- if Current_Verbosity = High then
- Debug_Output ("Add_Main """ & Name & """ " & Index'Img
- & " with_tree? "
- & Boolean'Image (Tree /= null));
- end if;
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- Names.Increment_Last;
- Names.Table (Names.Last) :=
- (Name_Find, Index, Location, No_Source, Project, Tree);
-
- if Tree /= null then
- Builder_Data (Tree).Number_Of_Mains :=
- Builder_Data (Tree).Number_Of_Mains + 1;
-
- else
- Mains.Count_Of_Mains_With_No_Tree :=
- Mains.Count_Of_Mains_With_No_Tree + 1;
- end if;
- end Add_Main;
-
- --------------------
- -- Complete_Mains --
- --------------------
-
- procedure Complete_Mains
- (Flags : Processing_Flags;
- Root_Project : Project_Id;
- Project_Tree : Project_Tree_Ref)
- is
- procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref);
- -- Check the mains for this specific project
-
- procedure Complete_All is new For_Project_And_Aggregated
- (Do_Complete);
-
- procedure Add_Multi_Unit_Sources
- (Tree : Project_Tree_Ref;
- Source : Prj.Source_Id);
- -- Add all units from the same file as the multi-unit Source
-
- function Find_File_Add_Extension
- (Tree : Project_Tree_Ref;
- Base_Main : String) return Prj.Source_Id;
- -- Search for Main in the project, adding body or spec extensions
-
- ----------------------------
- -- Add_Multi_Unit_Sources --
- ----------------------------
-
- procedure Add_Multi_Unit_Sources
- (Tree : Project_Tree_Ref;
- Source : Prj.Source_Id)
- is
- Iter : Source_Iterator;
- Src : Prj.Source_Id;
-
- begin
- Debug_Output
- ("found multi-unit source file in project", Source.Project.Name);
-
- Iter := For_Each_Source
- (In_Tree => Tree, Project => Source.Project);
-
- while Element (Iter) /= No_Source loop
- Src := Element (Iter);
-
- if Src.File = Source.File
- and then Src.Index /= Source.Index
- then
- if Src.File = Source.File then
- Debug_Output
- ("add main in project, index=" & Src.Index'Img);
- end if;
-
- Names.Increment_Last;
- Names.Table (Names.Last) :=
- (File => Src.File,
- Index => Src.Index,
- Location => No_Location,
- Source => Src,
- Project => Src.Project,
- Tree => Tree);
-
- Builder_Data (Tree).Number_Of_Mains :=
- Builder_Data (Tree).Number_Of_Mains + 1;
- end if;
-
- Next (Iter);
- end loop;
- end Add_Multi_Unit_Sources;
-
- -----------------------------
- -- Find_File_Add_Extension --
- -----------------------------
-
- function Find_File_Add_Extension
- (Tree : Project_Tree_Ref;
- Base_Main : String) return Prj.Source_Id
- is
- Spec_Source : Prj.Source_Id := No_Source;
- Source : Prj.Source_Id;
- Iter : Source_Iterator;
- Suffix : File_Name_Type;
-
- begin
- Source := No_Source;
- Iter := For_Each_Source (Tree); -- In all projects
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- if Source.Kind = Impl then
- Get_Name_String (Source.File);
-
- if Name_Len > Base_Main'Length
- and then Name_Buffer (1 .. Base_Main'Length) = Base_Main
- then
- Suffix :=
- Source.Language.Config.Naming_Data.Body_Suffix;
-
- if Suffix /= No_File then
- declare
- Suffix_Str : String := Get_Name_String (Suffix);
- begin
- Canonical_Case_File_Name (Suffix_Str);
- exit when
- Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
- Suffix_Str;
- end;
- end if;
- end if;
-
- elsif Source.Kind = Spec
- and then Source.Language.Config.Kind = Unit_Based
- then
- -- An Ada spec needs to be taken into account unless there
- -- is also a body. So we delay the decision for them.
-
- Get_Name_String (Source.File);
-
- if Name_Len > Base_Main'Length
- and then Name_Buffer (1 .. Base_Main'Length) = Base_Main
- then
- Suffix := Source.Language.Config.Naming_Data.Spec_Suffix;
-
- if Suffix /= No_File then
- declare
- Suffix_Str : String := Get_Name_String (Suffix);
-
- begin
- Canonical_Case_File_Name (Suffix_Str);
-
- if Name_Buffer (Base_Main'Length + 1 .. Name_Len) =
- Suffix_Str
- then
- Spec_Source := Source;
- end if;
- end;
- end if;
- end if;
- end if;
-
- Next (Iter);
- end loop;
-
- if Source = No_Source then
- Source := Spec_Source;
- end if;
-
- return Source;
- end Find_File_Add_Extension;
-
- -----------------
- -- Do_Complete --
- -----------------
-
- procedure Do_Complete
- (Project : Project_Id; Tree : Project_Tree_Ref)
- is
- J : Integer;
-
- begin
- if Mains.Number_Of_Mains (Tree) > 0
- or else Mains.Count_Of_Mains_With_No_Tree > 0
- then
- -- Traverse in reverse order, since in the case of multi-unit
- -- files we will be adding extra files at the end, and there's
- -- no need to process them in turn.
-
- J := Names.Last;
- Main_Loop : loop
- declare
- File : Main_Info := Names.Table (J);
- Main_Id : File_Name_Type := File.File;
- Main : constant String :=
- Get_Name_String (Main_Id);
- Base : constant String := Base_Name (Main);
- Source : Prj.Source_Id := No_Source;
- Is_Absolute : Boolean := False;
-
- begin
- if Base /= Main then
- Is_Absolute := True;
-
- if Is_Absolute_Path (Main) then
- Main_Id := Create_Name (Base);
-
- -- Not an absolute path
-
- else
- -- Always resolve links here, so that users can be
- -- specify any name on the command line. If the
- -- project itself uses links, the user will be
- -- using -eL anyway, and thus files are also stored
- -- with resolved names.
-
- declare
- Absolute : constant String :=
- Normalize_Pathname
- (Name => Main,
- Directory => "",
- Resolve_Links => True,
- Case_Sensitive => False);
- begin
- File.File := Create_Name (Absolute);
- Main_Id := Create_Name (Base);
- end;
- end if;
- end if;
-
- -- If no project or tree was specified for the main, it
- -- came from the command line.
- -- Note that the assignments below will not modify inside
- -- the table itself.
-
- if File.Project = null then
- File.Project := Project;
- end if;
-
- if File.Tree = null then
- File.Tree := Tree;
- end if;
-
- if File.Source = null then
- if Current_Verbosity = High then
- Debug_Output
- ("search for main """ & Main
- & '"' & File.Index'Img & " in "
- & Get_Name_String (Debug_Name (File.Tree))
- & ", project", Project.Name);
- end if;
-
- -- First, look for the main as specified. We need to
- -- search for the base name though, and if needed
- -- check later that we found the correct file.
-
- declare
- Sources : constant Source_Ids :=
- Find_All_Sources
- (In_Tree => File.Tree,
- Project => File.Project,
- Base_Name => Main_Id,
- Index => File.Index,
- In_Imported_Only => True);
-
- begin
- if Is_Absolute then
- for J in Sources'Range loop
- if File_Name_Type (Sources (J).Path.Name) =
- File.File
- then
- Source := Sources (J);
- exit;
- end if;
- end loop;
-
- elsif Sources'Length > 1 then
-
- -- This is only allowed if the units are from
- -- the same multi-unit source file.
-
- Source := Sources (1);
-
- for J in 2 .. Sources'Last loop
- if Sources (J).Path /= Source.Path
- or else Sources (J).Index = Source.Index
- then
- Error_Msg_File_1 := Main_Id;
- Prj.Err.Error_Msg
- (Flags, "several main sources {",
- No_Location, File.Project);
- exit Main_Loop;
- end if;
- end loop;
-
- elsif Sources'Length = 1 then
- Source := Sources (Sources'First);
- end if;
- end;
-
- if Source = No_Source then
- Source := Find_File_Add_Extension
- (File.Tree, Get_Name_String (Main_Id));
- end if;
-
- if Is_Absolute
- and then Source /= No_Source
- and then
- File_Name_Type (Source.Path.Name) /= File.File
- then
- Debug_Output
- ("Found a non-matching file",
- Name_Id (Source.Path.Display_Name));
- Source := No_Source;
- end if;
-
- if Source /= No_Source then
- if not Is_Allowed_Language
- (Source.Language.Name)
- then
- -- Remove any main that is not in the list of
- -- restricted languages.
-
- Names.Table (J .. Names.Last - 1) :=
- Names.Table (J + 1 .. Names.Last);
- Names.Set_Last (Names.Last - 1);
-
- else
- -- If we have found a multi-unit source file but
- -- did not specify an index initially, we'll
- -- need to compile all the units from the same
- -- source file.
-
- if Source.Index /= 0 and then File.Index = 0 then
- Add_Multi_Unit_Sources (File.Tree, Source);
- end if;
-
- -- Now update the original Main, otherwise it
- -- will be reported as not found.
-
- Debug_Output
- ("found main in project", Source.Project.Name);
- Names.Table (J).File := Source.File;
- Names.Table (J).Project := Source.Project;
-
- if Names.Table (J).Tree = null then
- Names.Table (J).Tree := File.Tree;
-
- Builder_Data (File.Tree).Number_Of_Mains :=
- Builder_Data (File.Tree).Number_Of_Mains
- + 1;
- Mains.Count_Of_Mains_With_No_Tree :=
- Mains.Count_Of_Mains_With_No_Tree - 1;
- end if;
-
- Names.Table (J).Source := Source;
- Names.Table (J).Index := Source.Index;
- end if;
-
- elsif File.Location /= No_Location then
-
- -- If the main is declared in package Builder of
- -- the main project, report an error. If the main
- -- is on the command line, it may be a main from
- -- another project, so do nothing: if the main does
- -- not exist in another project, an error will be
- -- reported later.
-
- Error_Msg_File_1 := Main_Id;
- Error_Msg_Name_1 := File.Project.Name;
- Prj.Err.Error_Msg
- (Flags, "{ is not a source of project %%",
- File.Location, File.Project);
- end if;
- end if;
- end;
-
- J := J - 1;
- exit Main_Loop when J < Names.First;
- end loop Main_Loop;
- end if;
-
- if Total_Errors_Detected > 0 then
- Fail_Program (Tree, "problems with main sources");
- end if;
- end Do_Complete;
-
- -- Start of processing for Complete_Mains
-
- begin
- Complete_All (Root_Project, Project_Tree);
-
- if Mains.Count_Of_Mains_With_No_Tree > 0 then
- for J in Names.First .. Names.Last loop
- if Names.Table (J).Source = No_Source then
- Fail_Program
- (Project_Tree, '"' & Get_Name_String (Names.Table (J).File)
- & """ is not a source of any project");
- end if;
- end loop;
- end if;
- end Complete_Mains;
-
- ------------
- -- Delete --
- ------------
-
- procedure Delete is
- begin
- Names.Set_Last (0);
- Mains.Reset;
- end Delete;
-
- -----------------------
- -- Fill_From_Project --
- -----------------------
-
- procedure Fill_From_Project
- (Root_Project : Project_Id;
- Project_Tree : Project_Tree_Ref)
- is
- procedure Add_Mains_From_Project
- (Project : Project_Id;
- Tree : Project_Tree_Ref);
- -- Add the main units from this project into Mains.
- -- This takes into account the aggregated projects
-
- ----------------------------
- -- Add_Mains_From_Project --
- ----------------------------
-
- procedure Add_Mains_From_Project
- (Project : Project_Id;
- Tree : Project_Tree_Ref)
- is
- List : String_List_Id;
- Element : String_Element;
-
- begin
- if Number_Of_Mains (Tree) = 0
- and then Mains.Count_Of_Mains_With_No_Tree = 0
- then
- Debug_Output ("Add_Mains_From_Project", Project.Name);
- List := Project.Mains;
-
- if List /= Prj.Nil_String then
-
- -- The attribute Main is not an empty list. Get the mains in
- -- the list.
-
- while List /= Prj.Nil_String loop
- Element := Tree.Shared.String_Elements.Table (List);
- Debug_Output ("Add_Main", Element.Value);
-
- if Project.Library then
- Fail_Program
- (Tree,
- "cannot specify a main program "
- & "for a library project file");
- end if;
-
- Add_Main (Name => Get_Name_String (Element.Value),
- Index => Element.Index,
- Location => Element.Location,
- Project => Project,
- Tree => Tree);
- List := Element.Next;
- end loop;
- end if;
- end if;
-
- if Total_Errors_Detected > 0 then
- Fail_Program (Tree, "problems with main sources");
- end if;
- end Add_Mains_From_Project;
-
- procedure Fill_All is new For_Project_And_Aggregated
- (Add_Mains_From_Project);
-
- -- Start of processing for Fill_From_Project
-
- begin
- Fill_All (Root_Project, Project_Tree);
- end Fill_From_Project;
-
- ---------------
- -- Next_Main --
- ---------------
-
- function Next_Main return String is
- Info : constant Main_Info := Next_Main;
- begin
- if Info = No_Main_Info then
- return "";
- else
- return Get_Name_String (Info.File);
- end if;
- end Next_Main;
-
- function Next_Main return Main_Info is
- begin
- if Current >= Names.Last then
- return No_Main_Info;
- else
- Current := Current + 1;
-
- -- If not using projects, and in the gnatmake case, the main file
- -- may have not have the extension. Try ".adb" first then ".ads"
-
- if Names.Table (Current).Project = No_Project then
- declare
- Orig_Main : constant File_Name_Type :=
- Names.Table (Current).File;
- Current_Main : File_Name_Type;
-
- begin
- if Strip_Suffix (Orig_Main) = Orig_Main then
- Get_Name_String (Orig_Main);
- Add_Str_To_Name_Buffer (".adb");
- Current_Main := Name_Find;
-
- if Full_Source_Name (Current_Main) = No_File then
- Get_Name_String (Orig_Main);
- Add_Str_To_Name_Buffer (".ads");
- Current_Main := Name_Find;
-
- if Full_Source_Name (Current_Main) /= No_File then
- Names.Table (Current).File := Current_Main;
- end if;
-
- else
- Names.Table (Current).File := Current_Main;
- end if;
- end if;
- end;
- end if;
-
- return Names.Table (Current);
- end if;
- end Next_Main;
-
- ---------------------
- -- Number_Of_Mains --
- ---------------------
-
- function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural is
- begin
- if Tree = null then
- return Names.Last;
- else
- return Builder_Data (Tree).Number_Of_Mains;
- end if;
- end Number_Of_Mains;
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset is
- begin
- Current := 0;
- end Reset;
-
- --------------------------
- -- Set_Multi_Unit_Index --
- --------------------------
-
- procedure Set_Multi_Unit_Index
- (Project_Tree : Project_Tree_Ref := null;
- Index : Int := 0)
- is
- begin
- if Index /= 0 then
- if Names.Last = 0 then
- Fail_Program
- (Project_Tree,
- "cannot specify a multi-unit index but no main "
- & "on the command line");
-
- elsif Names.Last > 1 then
- Fail_Program
- (Project_Tree,
- "cannot specify several mains with a multi-unit index");
-
- else
- Names.Table (Names.Last).Index := Index;
- end if;
- end if;
- end Set_Multi_Unit_Index;
-
- end Mains;
-
- -----------------------
- -- Path_Or_File_Name --
- -----------------------
-
- function Path_Or_File_Name (Path : Path_Name_Type) return String is
- Path_Name : constant String := Get_Name_String (Path);
- begin
- if Debug.Debug_Flag_F then
- return File_Name (Path_Name);
- else
- return Path_Name;
- end if;
- end Path_Or_File_Name;
-
- -------------------
- -- Unit_Index_Of --
- -------------------
-
- function Unit_Index_Of (ALI_File : File_Name_Type) return Int is
- Start : Natural;
- Finish : Natural;
- Result : Int := 0;
-
- begin
- Get_Name_String (ALI_File);
-
- -- First, find the last dot
-
- Finish := Name_Len;
-
- while Finish >= 1 and then Name_Buffer (Finish) /= '.' loop
- Finish := Finish - 1;
- end loop;
-
- if Finish = 1 then
- return 0;
- end if;
-
- -- Now check that the dot is preceded by digits
-
- Start := Finish;
- Finish := Finish - 1;
- while Start >= 1 and then Name_Buffer (Start - 1) in '0' .. '9' loop
- Start := Start - 1;
- end loop;
-
- -- If there are no digits, or if the digits are not preceded by the
- -- character that precedes a unit index, this is not the ALI file of
- -- a unit in a multi-unit source.
-
- if Start > Finish
- or else Start = 1
- or else Name_Buffer (Start - 1) /= Multi_Unit_Index_Character
- then
- return 0;
- end if;
-
- -- Build the index from the digit(s)
-
- while Start <= Finish loop
- Result := Result * 10 +
- Character'Pos (Name_Buffer (Start)) - Character'Pos ('0');
- Start := Start + 1;
- end loop;
-
- return Result;
- end Unit_Index_Of;
-
- -----------------
- -- Verbose_Msg --
- -----------------
-
- procedure Verbose_Msg
- (N1 : Name_Id;
- S1 : String;
- N2 : Name_Id := No_Name;
- S2 : String := "";
- Prefix : String := " -> ";
- Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
- is
- begin
- if not Opt.Verbose_Mode
- or else Minimum_Verbosity > Opt.Verbosity_Level
- then
- return;
- end if;
-
- Write_Str (Prefix);
- Write_Str ("""");
- Write_Name (N1);
- Write_Str (""" ");
- Write_Str (S1);
-
- if N2 /= No_Name then
- Write_Str (" """);
- Write_Name (N2);
- Write_Str (""" ");
- end if;
-
- Write_Str (S2);
- Write_Eol;
- end Verbose_Msg;
-
- procedure Verbose_Msg
- (N1 : File_Name_Type;
- S1 : String;
- N2 : File_Name_Type := No_File;
- S2 : String := "";
- Prefix : String := " -> ";
- Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low)
- is
- begin
- Verbose_Msg
- (Name_Id (N1), S1, Name_Id (N2), S2, Prefix, Minimum_Verbosity);
- end Verbose_Msg;
-
- -----------
- -- Queue --
- -----------
-
- package body Queue is
-
- type Q_Record is record
- Info : Source_Info;
- Processed : Boolean;
- end record;
-
- package Q is new Table.Table
- (Table_Component_Type => Q_Record,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 1000,
- Table_Increment => 100,
- Table_Name => "Makeutl.Queue.Q");
- -- This is the actual Queue
-
- package Busy_Obj_Dirs is new GNAT.HTable.Simple_HTable
- (Header_Num => Prj.Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => Path_Name_Type,
- Hash => Hash,
- Equal => "=");
-
- type Mark_Key is record
- File : File_Name_Type;
- Index : Int;
- end record;
- -- Identify either a mono-unit source (when Index = 0) or a specific
- -- unit (index = 1's origin index of unit) in a multi-unit source.
-
- Max_Mask_Num : constant := 2048;
- subtype Mark_Num is Union_Id range 0 .. Max_Mask_Num - 1;
-
- function Hash (Key : Mark_Key) return Mark_Num;
-
- package Marks is new GNAT.HTable.Simple_HTable
- (Header_Num => Mark_Num,
- Element => Boolean,
- No_Element => False,
- Key => Mark_Key,
- Hash => Hash,
- Equal => "=");
- -- A hash table to keep tracks of the marked units.
- -- These are the units that have already been processed, when using the
- -- gnatmake format. When using the gprbuild format, we can directly
- -- store in the source_id whether the file has already been processed.
-
- procedure Mark (Source_File : File_Name_Type; Index : Int := 0);
- -- Mark a unit, identified by its source file and, when Index is not 0,
- -- the index of the unit in the source file. Marking is used to signal
- -- that the unit has already been inserted in the Q.
-
- function Is_Marked
- (Source_File : File_Name_Type;
- Index : Int := 0) return Boolean;
- -- Returns True if the unit was previously marked
-
- Q_Processed : Natural := 0;
- Q_Initialized : Boolean := False;
-
- Q_First : Natural := 1;
- -- Points to the first valid element in the queue
-
- One_Queue_Per_Obj_Dir : Boolean := False;
- -- See parameter to Initialize
-
- function Available_Obj_Dir (S : Source_Info) return Boolean;
- -- Whether the object directory for S is available for a build
-
- procedure Debug_Display (S : Source_Info);
- -- A debug display for S
-
- function Was_Processed (S : Source_Info) return Boolean;
- -- Whether S has already been processed. This marks the source as
- -- processed, if it hasn't already been processed.
-
- function Insert_No_Roots (Source : Source_Info) return Boolean;
- -- Insert Source, but do not look for its roots (see doc for Insert)
-
- -------------------
- -- Was_Processed --
- -------------------
-
- function Was_Processed (S : Source_Info) return Boolean is
- begin
- case S.Format is
- when Format_Gprbuild =>
- if S.Id.In_The_Queue then
- return True;
- end if;
-
- S.Id.In_The_Queue := True;
-
- when Format_Gnatmake =>
- if Is_Marked (S.File, S.Index) then
- return True;
- end if;
-
- Mark (S.File, Index => S.Index);
- end case;
-
- return False;
- end Was_Processed;
-
- -----------------------
- -- Available_Obj_Dir --
- -----------------------
-
- function Available_Obj_Dir (S : Source_Info) return Boolean is
- begin
- case S.Format is
- when Format_Gprbuild =>
- return
- not Busy_Obj_Dirs.Get
- (S.Id.Project.Object_Directory.Name);
-
- when Format_Gnatmake =>
- return
- S.Project = No_Project
- or else not Busy_Obj_Dirs.Get
- (S.Project.Object_Directory.Name);
- end case;
- end Available_Obj_Dir;
-
- -------------------
- -- Debug_Display --
- -------------------
-
- procedure Debug_Display (S : Source_Info) is
- begin
- case S.Format is
- when Format_Gprbuild =>
- Write_Name (S.Id.File);
-
- if S.Id.Index /= 0 then
- Write_Str (", ");
- Write_Int (S.Id.Index);
- end if;
-
- when Format_Gnatmake =>
- Write_Name (S.File);
-
- if S.Index /= 0 then
- Write_Str (", ");
- Write_Int (S.Index);
- end if;
- end case;
- end Debug_Display;
-
- ----------
- -- Hash --
- ----------
-
- function Hash (Key : Mark_Key) return Mark_Num is
- begin
- return Union_Id (Key.File) mod Max_Mask_Num;
- end Hash;
-
- ---------------
- -- Is_Marked --
- ---------------
-
- function Is_Marked
- (Source_File : File_Name_Type;
- Index : Int := 0) return Boolean
- is
- begin
- return Marks.Get (K => (File => Source_File, Index => Index));
- end Is_Marked;
-
- ----------
- -- Mark --
- ----------
-
- procedure Mark (Source_File : File_Name_Type; Index : Int := 0) is
- begin
- Marks.Set (K => (File => Source_File, Index => Index), E => True);
- end Mark;
-
- -------------
- -- Extract --
- -------------
-
- procedure Extract
- (Found : out Boolean;
- Source : out Source_Info)
- is
- begin
- Found := False;
-
- if One_Queue_Per_Obj_Dir then
- for J in Q_First .. Q.Last loop
- if not Q.Table (J).Processed
- and then Available_Obj_Dir (Q.Table (J).Info)
- then
- Found := True;
- Source := Q.Table (J).Info;
- Q.Table (J).Processed := True;
-
- if J = Q_First then
- while Q_First <= Q.Last
- and then Q.Table (Q_First).Processed
- loop
- Q_First := Q_First + 1;
- end loop;
- end if;
-
- exit;
- end if;
- end loop;
-
- elsif Q_First <= Q.Last then
- Source := Q.Table (Q_First).Info;
- Q.Table (Q_First).Processed := True;
- Q_First := Q_First + 1;
- Found := True;
- end if;
-
- if Found then
- Q_Processed := Q_Processed + 1;
- end if;
-
- if Found and then Debug.Debug_Flag_Q then
- Write_Str (" Q := Q - [ ");
- Debug_Display (Source);
- Write_Str (" ]");
- Write_Eol;
-
- Write_Str (" Q_First =");
- Write_Int (Int (Q_First));
- Write_Eol;
-
- Write_Str (" Q.Last =");
- Write_Int (Int (Q.Last));
- Write_Eol;
- end if;
- end Extract;
-
- ---------------
- -- Processed --
- ---------------
-
- function Processed return Natural is
- begin
- return Q_Processed;
- end Processed;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Queue_Per_Obj_Dir : Boolean;
- Force : Boolean := False)
- is
- begin
- if Force or else not Q_Initialized then
- Q_Initialized := True;
-
- for J in 1 .. Q.Last loop
- case Q.Table (J).Info.Format is
- when Format_Gprbuild =>
- Q.Table (J).Info.Id.In_The_Queue := False;
-
- when Format_Gnatmake =>
- null;
- end case;
- end loop;
-
- Q.Init;
- Q_Processed := 0;
- Q_First := 1;
- One_Queue_Per_Obj_Dir := Queue_Per_Obj_Dir;
- end if;
- end Initialize;
-
- ---------------------
- -- Insert_No_Roots --
- ---------------------
-
- function Insert_No_Roots (Source : Source_Info) return Boolean is
- begin
- pragma Assert
- (Source.Format = Format_Gnatmake or else Source.Id /= No_Source);
-
- -- Only insert in the Q if it is not already done, to avoid
- -- simultaneous compilations if -jnnn is used.
-
- if Was_Processed (Source) then
- return False;
- end if;
-
- -- For gprbuild, check if a source has already been inserted in the
- -- queue from the same project in a different project tree.
-
- if Source.Format = Format_Gprbuild then
- for J in 1 .. Q.Last loop
- if Source.Id.Path.Name = Q.Table (J).Info.Id.Path.Name
- and then Source.Id.Index = Q.Table (J).Info.Id.Index
- and then
- Ultimate_Extending_Project_Of (Source.Id.Project).Path.Name
- =
- Ultimate_Extending_Project_Of (Q.Table (J).Info.Id.Project).
- Path.Name
- then
- -- No need to insert this source in the queue, but still
- -- return True as we may need to insert its roots.
-
- return True;
- end if;
- end loop;
- end if;
-
- if Current_Verbosity = High then
- Write_Str ("Adding """);
- Debug_Display (Source);
- Write_Line (""" to the queue");
- end if;
-
- Q.Append (New_Val => (Info => Source, Processed => False));
-
- if Debug.Debug_Flag_Q then
- Write_Str (" Q := Q + [ ");
- Debug_Display (Source);
- Write_Str (" ] ");
- Write_Eol;
-
- Write_Str (" Q_First =");
- Write_Int (Int (Q_First));
- Write_Eol;
-
- Write_Str (" Q.Last =");
- Write_Int (Int (Q.Last));
- Write_Eol;
- end if;
-
- return True;
- end Insert_No_Roots;
-
- ------------
- -- Insert --
- ------------
-
- function Insert
- (Source : Source_Info;
- With_Roots : Boolean := False) return Boolean
- is
- Root_Arr : Array_Element_Id;
- Roots : Variable_Value;
- List : String_List_Id;
- Elem : String_Element;
- Unit_Name : Name_Id;
- Pat_Root : Boolean;
- Root_Pattern : Regexp;
- Root_Found : Boolean;
- Roots_Found : Boolean;
- Root_Source : Prj.Source_Id;
- Iter : Source_Iterator;
-
- Dummy : Boolean;
-
- begin
- if not Insert_No_Roots (Source) then
-
- -- Was already in the queue
-
- return False;
- end if;
-
- if With_Roots and then Source.Format = Format_Gprbuild then
- Debug_Output ("looking for roots of", Name_Id (Source.Id.File));
-
- Root_Arr :=
- Prj.Util.Value_Of
- (Name => Name_Roots,
- In_Arrays => Source.Id.Project.Decl.Arrays,
- Shared => Source.Tree.Shared);
-
- Roots :=
- Prj.Util.Value_Of
- (Index => Name_Id (Source.Id.File),
- Src_Index => 0,
- In_Array => Root_Arr,
- Shared => Source.Tree.Shared);
-
- -- If there is no roots for the specific main, try the language
-
- if Roots = Nil_Variable_Value then
- Roots :=
- Prj.Util.Value_Of
- (Index => Source.Id.Language.Name,
- Src_Index => 0,
- In_Array => Root_Arr,
- Shared => Source.Tree.Shared,
- Force_Lower_Case_Index => True);
- end if;
-
- -- Then try "*"
-
- if Roots = Nil_Variable_Value then
- Name_Len := 1;
- Name_Buffer (1) := '*';
-
- Roots :=
- Prj.Util.Value_Of
- (Index => Name_Find,
- Src_Index => 0,
- In_Array => Root_Arr,
- Shared => Source.Tree.Shared,
- Force_Lower_Case_Index => True);
- end if;
-
- if Roots = Nil_Variable_Value then
- Debug_Output (" -> no roots declared");
-
- else
- List := Roots.Values;
-
- Pattern_Loop :
- while List /= Nil_String loop
- Elem := Source.Tree.Shared.String_Elements.Table (List);
- Get_Name_String (Elem.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Unit_Name := Name_Find;
-
- -- Check if it is a unit name or a pattern
-
- Pat_Root := False;
-
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) not in 'a' .. 'z' and then
- Name_Buffer (J) not in '0' .. '9' and then
- Name_Buffer (J) /= '_' and then
- Name_Buffer (J) /= '.'
- then
- Pat_Root := True;
- exit;
- end if;
- end loop;
-
- if Pat_Root then
- begin
- Root_Pattern :=
- Compile
- (Pattern => Name_Buffer (1 .. Name_Len),
- Glob => True);
-
- exception
- when Error_In_Regexp =>
- Err_Vars.Error_Msg_Name_1 := Unit_Name;
- Errutil.Error_Msg
- ("invalid pattern %", Roots.Location);
- exit Pattern_Loop;
- end;
- end if;
-
- Roots_Found := False;
- Iter := For_Each_Source (Source.Tree);
-
- Source_Loop :
- loop
- Root_Source := Prj.Element (Iter);
- exit Source_Loop when Root_Source = No_Source;
-
- Root_Found := False;
- if Pat_Root then
- Root_Found := Root_Source.Unit /= No_Unit_Index
- and then Match
- (Get_Name_String (Root_Source.Unit.Name),
- Root_Pattern);
-
- else
- Root_Found :=
- Root_Source.Unit /= No_Unit_Index
- and then Root_Source.Unit.Name = Unit_Name;
- end if;
-
- if Root_Found then
- case Root_Source.Kind is
- when Impl =>
- null;
-
- when Spec =>
- Root_Found :=
- Other_Part (Root_Source) = No_Source;
-
- when Sep =>
- Root_Found := False;
- end case;
- end if;
-
- if Root_Found then
- Roots_Found := True;
- Debug_Output
- (" -> ", Name_Id (Root_Source.Display_File));
- Dummy := Queue.Insert_No_Roots
- (Source => (Format => Format_Gprbuild,
- Tree => Source.Tree,
- Id => Root_Source,
- Closure => False));
-
- Initialize_Source_Record (Root_Source);
-
- if Other_Part (Root_Source) /= No_Source then
- Initialize_Source_Record (Other_Part (Root_Source));
- end if;
-
- -- Save the root for the binder
-
- Source.Id.Roots := new Source_Roots'
- (Root => Root_Source,
- Next => Source.Id.Roots);
-
- exit Source_Loop when not Pat_Root;
- end if;
-
- Next (Iter);
- end loop Source_Loop;
-
- if not Roots_Found then
- if Pat_Root then
- if not Quiet_Output then
- Error_Msg_Name_1 := Unit_Name;
- Errutil.Error_Msg
- ("?no unit matches pattern %", Roots.Location);
- end if;
-
- else
- Errutil.Error_Msg
- ("Unit " & Get_Name_String (Unit_Name)
- & " does not exist", Roots.Location);
- end if;
- end if;
-
- List := Elem.Next;
- end loop Pattern_Loop;
- end if;
- end if;
-
- return True;
- end Insert;
-
- ------------
- -- Insert --
- ------------
-
- procedure Insert
- (Source : Source_Info;
- With_Roots : Boolean := False)
- is
- Discard : Boolean;
- begin
- Discard := Insert (Source, With_Roots);
- end Insert;
-
- --------------
- -- Is_Empty --
- --------------
-
- function Is_Empty return Boolean is
- begin
- return Q_Processed >= Q.Last;
- end Is_Empty;
-
- ------------------------
- -- Is_Virtually_Empty --
- ------------------------
-
- function Is_Virtually_Empty return Boolean is
- begin
- if One_Queue_Per_Obj_Dir then
- for J in Q_First .. Q.Last loop
- if not Q.Table (J).Processed
- and then Available_Obj_Dir (Q.Table (J).Info)
- then
- return False;
- end if;
- end loop;
-
- return True;
-
- else
- return Is_Empty;
- end if;
- end Is_Virtually_Empty;
-
- ----------------------
- -- Set_Obj_Dir_Busy --
- ----------------------
-
- procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type) is
- begin
- if One_Queue_Per_Obj_Dir then
- Busy_Obj_Dirs.Set (Obj_Dir, True);
- end if;
- end Set_Obj_Dir_Busy;
-
- ----------------------
- -- Set_Obj_Dir_Free --
- ----------------------
-
- procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type) is
- begin
- if One_Queue_Per_Obj_Dir then
- Busy_Obj_Dirs.Set (Obj_Dir, False);
- end if;
- end Set_Obj_Dir_Free;
-
- ----------
- -- Size --
- ----------
-
- function Size return Natural is
- begin
- return Q.Last;
- end Size;
-
- -------------
- -- Element --
- -------------
-
- function Element (Rank : Positive) return File_Name_Type is
- begin
- if Rank <= Q.Last then
- case Q.Table (Rank).Info.Format is
- when Format_Gprbuild =>
- return Q.Table (Rank).Info.Id.File;
-
- when Format_Gnatmake =>
- return Q.Table (Rank).Info.File;
- end case;
- else
- return No_File;
- end if;
- end Element;
-
- ------------------
- -- Remove_Marks --
- ------------------
-
- procedure Remove_Marks is
- begin
- Marks.Reset;
- end Remove_Marks;
-
- ----------------------------
- -- Insert_Project_Sources --
- ----------------------------
-
- procedure Insert_Project_Sources
- (Project : Project_Id;
- Project_Tree : Project_Tree_Ref;
- All_Projects : Boolean;
- Unique_Compile : Boolean)
- is
-
- procedure Do_Insert
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context);
- -- Local procedures must be commented ???
-
- ---------------
- -- Do_Insert --
- ---------------
-
- procedure Do_Insert
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context)
- is
- Unit_Based : constant Boolean :=
- Unique_Compile
- or else not Builder_Data (Tree).Closure_Needed;
- -- When Unit_Based is True, we enqueue all compilable sources
- -- including the unit based (Ada) one. When Unit_Based is False,
- -- put the Ada sources only when they are in a library project.
-
- Iter : Source_Iterator;
- Source : Prj.Source_Id;
- OK : Boolean;
- Closure : Boolean;
-
- begin
- -- Nothing to do when "-u" was specified and some files were
- -- specified on the command line
-
- if Unique_Compile and then Mains.Number_Of_Mains (Tree) > 0 then
- return;
- end if;
-
- Iter := For_Each_Source (Tree);
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- if Is_Allowed_Language (Source.Language.Name)
- and then Is_Compilable (Source)
- and then (All_Projects
- or else Is_Extending (Project, Source.Project))
- and then not Source.Locally_Removed
- and then Source.Replaced_By = No_Source
- and then (not Source.Project.Externally_Built
- or else (Is_Extending (Project, Source.Project)
- and then not Project.Externally_Built))
- and then Source.Kind /= Sep
- and then Source.Path /= No_Path_Information
- then
- if Source.Kind = Impl
- or else (Source.Unit /= No_Unit_Index
- and then Source.Kind = Spec
- and then (Other_Part (Source) = No_Source
- or else
- Other_Part (Source).Locally_Removed))
- then
- if (Unit_Based
- or else Source.Unit = No_Unit_Index
- or else Source.Project.Library
- or else Context.In_Aggregate_Lib
- or else Project.Qualifier = Aggregate_Library)
- and then not Is_Subunit (Source)
- then
- OK := True;
- Closure := False;
-
- if Source.Unit /= No_Unit_Index
- and then
- (Source.Project.Library
- or else Project.Qualifier = Aggregate_Library
- or else Context.In_Aggregate_Lib)
- and then Source.Project.Standalone_Library /= No
- then
- -- Check if the unit is in the interface
-
- OK := False;
-
- declare
- List : String_List_Id;
- Element : String_Element;
-
- begin
- List := Source.Project.Lib_Interface_ALIs;
- while List /= Nil_String loop
- Element :=
- Project_Tree.Shared.String_Elements.Table
- (List);
-
- if Element.Value = Name_Id (Source.Dep_Name)
- then
- OK := True;
- Closure := True;
- exit;
- end if;
-
- List := Element.Next;
- end loop;
- end;
- end if;
-
- if OK then
- Queue.Insert
- (Source => (Format => Format_Gprbuild,
- Tree => Tree,
- Id => Source,
- Closure => Closure));
- end if;
- end if;
- end if;
- end if;
-
- Next (Iter);
- end loop;
- end Do_Insert;
-
- procedure Insert_All is
- new For_Project_And_Aggregated_Context (Do_Insert);
-
- begin
- Insert_All (Project, Project_Tree);
- end Insert_Project_Sources;
-
- -------------------------------
- -- Insert_Withed_Sources_For --
- -------------------------------
-
- procedure Insert_Withed_Sources_For
- (The_ALI : ALI.ALI_Id;
- Project_Tree : Project_Tree_Ref;
- Excluding_Shared_SALs : Boolean := False)
- is
- Sfile : File_Name_Type;
- Afile : File_Name_Type;
- Src_Id : Prj.Source_Id;
-
- begin
- -- Insert in the queue the unmarked source files (i.e. those which
- -- have never been inserted in the queue and hence never considered).
-
- for J in ALI.ALIs.Table (The_ALI).First_Unit ..
- ALI.ALIs.Table (The_ALI).Last_Unit
- loop
- for K in ALI.Units.Table (J).First_With ..
- ALI.Units.Table (J).Last_With
- loop
- Sfile := ALI.Withs.Table (K).Sfile;
-
- -- Skip generics
-
- if Sfile /= No_File then
- Afile := ALI.Withs.Table (K).Afile;
-
- Src_Id := Source_Files_Htable.Get
- (Project_Tree.Source_Files_HT, Sfile);
- while Src_Id /= No_Source loop
- Initialize_Source_Record (Src_Id);
-
- if Is_Compilable (Src_Id)
- and then Src_Id.Dep_Name = Afile
- then
- case Src_Id.Kind is
- when Spec =>
- declare
- Bdy : constant Prj.Source_Id :=
- Other_Part (Src_Id);
- begin
- if Bdy /= No_Source
- and then not Bdy.Locally_Removed
- then
- Src_Id := Other_Part (Src_Id);
- end if;
- end;
-
- when Impl =>
- if Is_Subunit (Src_Id) then
- Src_Id := No_Source;
- end if;
-
- when Sep =>
- Src_Id := No_Source;
- end case;
-
- exit;
- end if;
-
- Src_Id := Src_Id.Next_With_File_Name;
- end loop;
-
- -- If Excluding_Shared_SALs is True, do not insert in the
- -- queue the sources of a shared Stand-Alone Library.
-
- if Src_Id /= No_Source
- and then (not Excluding_Shared_SALs
- or else Src_Id.Project.Standalone_Library = No
- or else Src_Id.Project.Library_Kind = Static)
- then
- Queue.Insert
- (Source => (Format => Format_Gprbuild,
- Tree => Project_Tree,
- Id => Src_Id,
- Closure => True));
- end if;
- end if;
- end loop;
- end loop;
- end Insert_Withed_Sources_For;
-
- end Queue;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Data : in out Builder_Project_Tree_Data) is
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Binding_Data_Record, Binding_Data);
-
- TmpB, Binding : Binding_Data := Data.Binding;
-
- begin
- while Binding /= null loop
- TmpB := Binding.Next;
- Unchecked_Free (Binding);
- Binding := TmpB;
- end loop;
- end Free;
-
- ------------------
- -- Builder_Data --
- ------------------
-
- function Builder_Data
- (Tree : Project_Tree_Ref) return Builder_Data_Access
- is
- begin
- if Tree.Appdata = null then
- Tree.Appdata := new Builder_Project_Tree_Data;
- end if;
-
- return Builder_Data_Access (Tree.Appdata);
- end Builder_Data;
-
- --------------------------------
- -- Compute_Compilation_Phases --
- --------------------------------
-
- procedure Compute_Compilation_Phases
- (Tree : Project_Tree_Ref;
- Root_Project : Project_Id;
- Option_Unique_Compile : Boolean := False; -- Was "-u" specified ?
- Option_Compile_Only : Boolean := False; -- Was "-c" specified ?
- Option_Bind_Only : Boolean := False;
- Option_Link_Only : Boolean := False)
- is
- procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref);
-
- ----------------
- -- Do_Compute --
- ----------------
-
- procedure Do_Compute (Project : Project_Id; Tree : Project_Tree_Ref) is
- Data : constant Builder_Data_Access := Builder_Data (Tree);
- All_Phases : constant Boolean :=
- not Option_Compile_Only
- and then not Option_Bind_Only
- and then not Option_Link_Only;
- -- Whether the command line asked for all three phases. Depending on
- -- the project settings, we might still disable some of the phases.
-
- Has_Mains : constant Boolean := Data.Number_Of_Mains > 0;
- -- Whether there are some main units defined for this project tree
- -- (either from one of the projects, or from the command line)
-
- begin
- if Option_Unique_Compile then
-
- -- If -u or -U is specified on the command line, disregard any -c,
- -- -b or -l switch: only perform compilation.
-
- Data.Closure_Needed := False;
- Data.Need_Compilation := True;
- Data.Need_Binding := False;
- Data.Need_Linking := False;
-
- else
- Data.Closure_Needed :=
- Has_Mains
- or else (Root_Project.Library
- and then Root_Project.Standalone_Library /= No);
- Data.Need_Compilation := All_Phases or Option_Compile_Only;
- Data.Need_Binding := All_Phases or Option_Bind_Only;
- Data.Need_Linking := (All_Phases or Option_Link_Only)
- and Has_Mains;
- end if;
-
- if Current_Verbosity = High then
- Debug_Output ("compilation phases: "
- & " compile=" & Data.Need_Compilation'Img
- & " bind=" & Data.Need_Binding'Img
- & " link=" & Data.Need_Linking'Img
- & " closure=" & Data.Closure_Needed'Img
- & " mains=" & Data.Number_Of_Mains'Img,
- Project.Name);
- end if;
- end Do_Compute;
-
- procedure Compute_All is new For_Project_And_Aggregated (Do_Compute);
-
- begin
- Compute_All (Root_Project, Tree);
- end Compute_Compilation_Phases;
-
- ------------------------------
- -- Compute_Builder_Switches --
- ------------------------------
-
- procedure Compute_Builder_Switches
- (Project_Tree : Project_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Main_Project : Project_Id;
- Only_For_Lang : Name_Id := No_Name)
- is
- Builder_Package : constant Package_Id :=
- Value_Of (Name_Builder, Main_Project.Decl.Packages,
- Project_Tree.Shared);
-
- Global_Compilation_Array : Array_Element_Id;
- Global_Compilation_Elem : Array_Element;
- Global_Compilation_Switches : Variable_Value;
-
- Default_Switches_Array : Array_Id;
-
- Builder_Switches_Lang : Name_Id := No_Name;
-
- List : String_List_Id;
- Element : String_Element;
-
- Index : Name_Id;
- Source : Prj.Source_Id;
-
- Lang : Name_Id := No_Name; -- language index for Switches
- Switches_For_Lang : Variable_Value := Nil_Variable_Value;
- -- Value of Builder'Default_Switches(lang)
-
- Name : Name_Id := No_Name; -- main file index for Switches
- Switches_For_Main : Variable_Value := Nil_Variable_Value;
- -- Switches for a specific main. When there are several mains, Name is
- -- set to No_Name, and Switches_For_Main might be left with an actual
- -- value (so that we can display a warning that it was ignored).
-
- Other_Switches : Variable_Value := Nil_Variable_Value;
- -- Value of Builder'Switches(others)
-
- Defaults : Variable_Value := Nil_Variable_Value;
-
- Switches : Variable_Value := Nil_Variable_Value;
- -- The computed builder switches
-
- Success : Boolean := False;
- begin
- if Builder_Package /= No_Package then
- Mains.Reset;
-
- -- If there is no main, and there is only one compilable language,
- -- use this language as the switches index.
-
- if Mains.Number_Of_Mains (Project_Tree) = 0 then
- if Only_For_Lang = No_Name then
- declare
- Language : Language_Ptr := Main_Project.Languages;
-
- begin
- while Language /= No_Language_Index loop
- if Language.Config.Compiler_Driver /= No_File
- and then Language.Config.Compiler_Driver /= Empty_File
- then
- if Lang /= No_Name then
- Lang := No_Name;
- exit;
- else
- Lang := Language.Name;
- end if;
- end if;
- Language := Language.Next;
- end loop;
- end;
- else
- Lang := Only_For_Lang;
- end if;
-
- else
- for Index in 1 .. Mains.Number_Of_Mains (Project_Tree) loop
- Source := Mains.Next_Main.Source;
-
- if Source /= No_Source then
- if Switches_For_Main = Nil_Variable_Value then
- Switches_For_Main := Value_Of
- (Name => Name_Id (Source.File),
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Builder_Package,
- Shared => Project_Tree.Shared,
- Force_Lower_Case_Index => False,
- Allow_Wildcards => True);
-
- -- If not found, try without extension.
- -- That's because gnatmake accepts truncated file names
- -- in Builder'Switches
-
- if Switches_For_Main = Nil_Variable_Value
- and then Source.Unit /= null
- then
- Switches_For_Main := Value_Of
- (Name => Source.Unit.Name,
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Builder_Package,
- Shared => Project_Tree.Shared,
- Force_Lower_Case_Index => False,
- Allow_Wildcards => True);
- end if;
- end if;
-
- if Index = 1 then
- Lang := Source.Language.Name;
- Name := Name_Id (Source.File);
- else
- Name := No_Name; -- Can't use main specific switches
-
- if Lang /= Source.Language.Name then
- Lang := No_Name;
- end if;
- end if;
- end if;
- end loop;
- end if;
-
- Global_Compilation_Array := Value_Of
- (Name => Name_Global_Compilation_Switches,
- In_Arrays => Project_Tree.Shared.Packages.Table
- (Builder_Package).Decl.Arrays,
- Shared => Project_Tree.Shared);
-
- Default_Switches_Array :=
- Project_Tree.Shared.Packages.Table (Builder_Package).Decl.Arrays;
-
- while Default_Switches_Array /= No_Array
- and then
- Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Name /=
- Name_Default_Switches
- loop
- Default_Switches_Array :=
- Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Next;
- end loop;
-
- if Global_Compilation_Array /= No_Array_Element
- and then Default_Switches_Array /= No_Array
- then
- Prj.Err.Error_Msg
- (Env.Flags,
- "Default_Switches forbidden in presence of "
- & "Global_Compilation_Switches. Use Switches instead.",
- Project_Tree.Shared.Arrays.Table
- (Default_Switches_Array).Location);
- Fail_Program
- (Project_Tree, "*** illegal combination of Builder attributes");
- end if;
-
- if Lang /= No_Name then
- Switches_For_Lang := Prj.Util.Value_Of
- (Name => Lang,
- Index => 0,
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Builder_Package,
- Shared => Project_Tree.Shared,
- Force_Lower_Case_Index => True);
-
- Defaults := Prj.Util.Value_Of
- (Name => Lang,
- Index => 0,
- Attribute_Or_Array_Name => Name_Default_Switches,
- In_Package => Builder_Package,
- Shared => Project_Tree.Shared,
- Force_Lower_Case_Index => True);
- end if;
-
- Other_Switches := Prj.Util.Value_Of
- (Name => All_Other_Names,
- Index => 0,
- Attribute_Or_Array_Name => Name_Switches,
- In_Package => Builder_Package,
- Shared => Project_Tree.Shared);
-
- if not Quiet_Output
- and then Mains.Number_Of_Mains (Project_Tree) > 1
- and then Switches_For_Main /= Nil_Variable_Value
- then
- -- More than one main, but we had main-specific switches that
- -- are ignored.
-
- if Switches_For_Lang /= Nil_Variable_Value then
- Write_Line
- ("Warning: using Builder'Switches("""
- & Get_Name_String (Lang)
- & """), as there are several mains");
-
- elsif Other_Switches /= Nil_Variable_Value then
- Write_Line
- ("Warning: using Builder'Switches(others), "
- & "as there are several mains");
-
- elsif Defaults /= Nil_Variable_Value then
- Write_Line
- ("Warning: using Builder'Default_Switches("""
- & Get_Name_String (Lang)
- & """), as there are several mains");
- else
- Write_Line
- ("Warning: using no switches from package "
- & "Builder, as there are several mains");
- end if;
- end if;
-
- Builder_Switches_Lang := Lang;
-
- if Name /= No_Name then
- -- Get the switches for the single main
- Switches := Switches_For_Main;
- end if;
-
- if Switches = Nil_Variable_Value or else Switches.Default then
- -- Get the switches for the common language of the mains
- Switches := Switches_For_Lang;
- end if;
-
- if Switches = Nil_Variable_Value or else Switches.Default then
- Switches := Other_Switches;
- end if;
-
- -- For backward compatibility with gnatmake, if no Switches
- -- are declared, check for Default_Switches (<language>).
-
- if Switches = Nil_Variable_Value or else Switches.Default then
- Switches := Defaults;
- end if;
-
- -- If switches have been found, scan them
-
- if Switches /= Nil_Variable_Value and then not Switches.Default then
- List := Switches.Values;
-
- while List /= Nil_String loop
- Element := Project_Tree.Shared.String_Elements.Table (List);
- Get_Name_String (Element.Value);
-
- if Name_Len /= 0 then
- declare
- -- Add_Switch might itself be using the name_buffer, so
- -- we make a temporary here.
- Switch : constant String := Name_Buffer (1 .. Name_Len);
- begin
- Success := Add_Switch
- (Switch => Switch,
- For_Lang => Builder_Switches_Lang,
- For_Builder => True,
- Has_Global_Compilation_Switches =>
- Global_Compilation_Array /= No_Array_Element);
- end;
-
- if not Success then
- for J in reverse 1 .. Name_Len loop
- Name_Buffer (J + J) := Name_Buffer (J);
- Name_Buffer (J + J - 1) := ''';
- end loop;
-
- Name_Len := Name_Len + Name_Len;
-
- Prj.Err.Error_Msg
- (Env.Flags,
- '"' & Name_Buffer (1 .. Name_Len)
- & """ is not a builder switch. Consider moving "
- & "it to Global_Compilation_Switches.",
- Element.Location);
- Fail_Program
- (Project_Tree,
- "*** illegal switch """
- & Get_Name_String (Element.Value) & '"');
- end if;
- end if;
-
- List := Element.Next;
- end loop;
- end if;
-
- -- Reset the Builder Switches language
-
- Builder_Switches_Lang := No_Name;
-
- -- Take into account attributes Global_Compilation_Switches
-
- while Global_Compilation_Array /= No_Array_Element loop
- Global_Compilation_Elem :=
- Project_Tree.Shared.Array_Elements.Table
- (Global_Compilation_Array);
-
- Get_Name_String (Global_Compilation_Elem.Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Index := Name_Find;
-
- if Only_For_Lang = No_Name or else Index = Only_For_Lang then
- Global_Compilation_Switches := Global_Compilation_Elem.Value;
-
- if Global_Compilation_Switches /= Nil_Variable_Value
- and then not Global_Compilation_Switches.Default
- then
- -- We have found an attribute
- -- Global_Compilation_Switches for a language: put the
- -- switches in the appropriate table.
-
- List := Global_Compilation_Switches.Values;
- while List /= Nil_String loop
- Element :=
- Project_Tree.Shared.String_Elements.Table (List);
-
- if Element.Value /= No_Name then
- Success := Add_Switch
- (Switch => Get_Name_String (Element.Value),
- For_Lang => Index,
- For_Builder => False,
- Has_Global_Compilation_Switches =>
- Global_Compilation_Array /= No_Array_Element);
- end if;
-
- List := Element.Next;
- end loop;
- end if;
- end if;
-
- Global_Compilation_Array := Global_Compilation_Elem.Next;
- end loop;
- end if;
- end Compute_Builder_Switches;
-
- ---------------------
- -- Write_Path_File --
- ---------------------
-
- procedure Write_Path_File (FD : File_Descriptor) is
- Last : Natural;
- Status : Boolean;
-
- begin
- Name_Len := 0;
-
- for Index in Directories.First .. Directories.Last loop
- Add_Str_To_Name_Buffer (Get_Name_String (Directories.Table (Index)));
- Add_Char_To_Name_Buffer (ASCII.LF);
- end loop;
-
- Last := Write (FD, Name_Buffer (1)'Address, Name_Len);
-
- if Last = Name_Len then
- Close (FD, Status);
- else
- Status := False;
- end if;
-
- if not Status then
- Prj.Com.Fail ("could not write temporary file");
- end if;
- end Write_Path_File;
-
-end Makeutl;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M A K E U T L --
--- --
--- S p e c --
--- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains various subprograms used by the builders, in
--- particular those subprograms related to project management and build
--- queue management.
-
-with ALI;
-with Namet; use Namet;
-with Opt;
-with Osint;
-with Prj; use Prj;
-with Prj.Tree;
-with Snames; use Snames;
-with Table;
-with Types; use Types;
-
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-
-package Makeutl is
-
- type Fail_Proc is access procedure (S : String);
- -- Pointer to procedure which outputs a failure message
-
- Root_Environment : Prj.Tree.Environment;
- -- The environment coming from environment variables and command line
- -- switches. When we do not have an aggregate project, this is used for
- -- parsing the project tree. When we have an aggregate project, this is
- -- used to parse the aggregate project; the latter then generates another
- -- environment (with additional external values and project path) to parse
- -- the aggregated projects.
-
- Default_Config_Name : constant String := "default.cgpr";
- -- Name of the configuration file used by gprbuild and generated by
- -- gprconfig by default.
-
- On_Windows : constant Boolean := Directory_Separator = '\';
- -- True when on Windows
-
- Source_Info_Option : constant String := "--source-info=";
- -- Switch to indicate the source info file
-
- Subdirs_Option : constant String := "--subdirs=";
- -- Switch used to indicate that the real directories (object, exec,
- -- library, ...) are subdirectories of those in the project file.
-
- Relocate_Build_Tree_Option : constant String := "--relocate-build-tree";
- -- Switch to build out-of-tree. In this context the object, exec and
- -- library directories are relocated to the current working directory
- -- or the directory specified as parameter to this option.
-
- Root_Dir_Option : constant String := "--root-dir";
- -- The root directory under which all artifacts (objects, library, ali)
- -- directory are to be found for the current compilation. This directory
- -- will be used to relocate artifacts based on this directory. If this
- -- option is not specificed the default value is the directory of the
- -- main project.
-
- Unchecked_Shared_Lib_Imports : constant String :=
- "--unchecked-shared-lib-imports";
- -- Command line switch to allow shared library projects to import projects
- -- that are not shared library projects.
-
- Single_Compile_Per_Obj_Dir_Switch : constant String :=
- "--single-compile-per-obj-dir";
- -- Switch to forbid simultaneous compilations for the same object directory
- -- when project files are used.
-
- Create_Map_File_Switch : constant String := "--create-map-file";
- -- Switch to create a map file when an executable is linked
-
- No_Exit_Message_Option : constant String := "--no-exit-message";
- -- Switch to suppress exit error message when there are compilation
- -- failures. This is useful when a tool, such as gnatprove, silently calls
- -- the builder and does not want to pollute its output with error messages
- -- coming from the builder. This is an internal switch.
-
- Keep_Temp_Files_Option : constant String := "--keep-temp-files";
- -- Switch to suppress deletion of temp files created by the builder.
- -- Note that debug switch -gnatdn also has this effect.
-
- Load_Standard_Base : Boolean := True;
- -- False when gprbuild is called with --db-
-
- package Db_Switch_Args is new Table.Table
- (Table_Component_Type => Name_Id,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 200,
- Table_Increment => 100,
- Table_Name => "Makegpr.Db_Switch_Args");
- -- Table of all the arguments of --db switches of gprbuild
-
- package Directories is new Table.Table
- (Table_Component_Type => Path_Name_Type,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 200,
- Table_Increment => 100,
- Table_Name => "Makegpr.Directories");
- -- Table of all the source or object directories, filled up by
- -- Get_Directories.
-
- procedure Add
- (Option : String_Access;
- To : in out String_List_Access;
- Last : in out Natural);
- procedure Add
- (Option : String;
- To : in out String_List_Access;
- Last : in out Natural);
- -- Add a string to a list of strings
-
- function Absolute_Path
- (Path : Path_Name_Type;
- Project : Project_Id) return String;
- -- Returns an absolute path for a configuration pragmas file
-
- function Create_Binder_Mapping_File
- (Project_Tree : Project_Tree_Ref) return Path_Name_Type;
- -- Create a binder mapping file and returns its path name
-
- function Create_Name (Name : String) return File_Name_Type;
- function Create_Name (Name : String) return Name_Id;
- function Create_Name (Name : String) return Path_Name_Type;
- -- Get an id for a name
-
- function Base_Name_Index_For
- (Main : String;
- Main_Index : Int;
- Index_Separator : Character) return File_Name_Type;
- -- Returns the base name of Main, without the extension, followed by the
- -- Index_Separator followed by the Main_Index if it is non-zero.
-
- function Executable_Prefix_Path return String;
- -- Return the absolute path parent directory of the directory where the
- -- current executable resides, if its directory is named "bin", otherwise
- -- return an empty string. When a directory is returned, it is guaranteed
- -- to end with a directory separator.
-
- procedure Inform (N : Name_Id := No_Name; Msg : String);
- procedure Inform (N : File_Name_Type; Msg : String);
- -- Prints out the program name followed by a colon, N and S
-
- function File_Not_A_Source_Of
- (Project_Tree : Project_Tree_Ref;
- Uname : Name_Id;
- Sfile : File_Name_Type) return Boolean;
- -- Check that file name Sfile is one of the source of unit Uname. Returns
- -- True if the unit is in one of the project file, but the file name is not
- -- one of its source. Returns False otherwise.
-
- function Check_Source_Info_In_ALI
- (The_ALI : ALI.ALI_Id;
- Tree : Project_Tree_Ref) return Name_Id;
- -- Check whether all file references in ALI are still valid (i.e. the
- -- source files are still associated with the same units). Return the name
- -- of the unit if everything is still valid. Return No_Name otherwise.
-
- procedure Ensure_Absolute_Path
- (Switch : in out String_Access;
- Parent : String;
- Do_Fail : Fail_Proc;
- For_Gnatbind : Boolean := False;
- Including_Non_Switch : Boolean := True;
- Including_RTS : Boolean := False);
- -- Do nothing if Switch is an absolute path switch. If relative, fail if
- -- Parent is the empty string, otherwise prepend the path with Parent. This
- -- subprogram is only used when using project files. If For_Gnatbind is
- -- True, consider gnatbind specific syntax for -L (not a path, left
- -- unchanged) and -A (path is optional, preceded with "=" if present).
- -- If Including_RTS is True, process also switches --RTS=. Do_Fail is
- -- called in case of error. Using Osint.Fail might be appropriate.
-
- function Is_Subunit (Source : Source_Id) return Boolean;
- -- Return True if source is a subunit
-
- procedure Initialize_Source_Record (Source : Source_Id);
- -- Get information either about the source file, or the object and
- -- dependency file, as well as their timestamps.
-
- function Is_External_Assignment
- (Env : Prj.Tree.Environment;
- Argv : String) return Boolean;
- -- Verify that an external assignment switch is syntactically correct
- --
- -- Correct forms are:
- --
- -- -Xname=value
- -- -X"name=other value"
- --
- -- Assumptions: 'First = 1, Argv (1 .. 2) = "-X"
- --
- -- When this function returns True, the external assignment has been
- -- entered by a call to Prj.Ext.Add, so that in a project file, External
- -- ("name") will return "value".
-
- type Name_Ids is array (Positive range <>) of Name_Id;
- No_Names : constant Name_Ids := (1 .. 0 => No_Name);
- -- Name_Ids is used for list of language names in procedure Get_Directories
- -- below.
-
- Ada_Only : constant Name_Ids := (1 => Name_Ada);
- -- Used to invoke Get_Directories in gnatmake
-
- type Activity_Type is (Compilation, Executable_Binding, SAL_Binding);
-
- procedure Get_Directories
- (Project_Tree : Project_Tree_Ref;
- For_Project : Project_Id;
- Activity : Activity_Type;
- Languages : Name_Ids);
- -- Put in table Directories the source (when Sources is True) or
- -- object/library (when Sources is False) directories of project
- -- For_Project and of all the project it imports directly or indirectly.
- -- The source directories of imported projects are only included if one
- -- of the declared languages is in the list Languages.
-
- function Aggregate_Libraries_In (Tree : Project_Tree_Ref) return Boolean;
- -- Return True iff there is one or more aggregate library projects in
- -- the project tree Tree.
-
- procedure Write_Path_File (FD : File_Descriptor);
- -- Write in the specified open path file the directories in table
- -- Directories, then closed the path file.
-
- procedure Get_Switches
- (Source : Source_Id;
- Pkg_Name : Name_Id;
- Project_Tree : Project_Tree_Ref;
- Value : out Variable_Value;
- Is_Default : out Boolean);
- procedure Get_Switches
- (Source_File : File_Name_Type;
- Source_Lang : Name_Id;
- Source_Prj : Project_Id;
- Pkg_Name : Name_Id;
- Project_Tree : Project_Tree_Ref;
- Value : out Variable_Value;
- Is_Default : out Boolean;
- Test_Without_Suffix : Boolean := False;
- Check_ALI_Suffix : Boolean := False);
- -- Compute the switches (Compilation switches for instance) for the given
- -- 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. If Test_Without_Suffix is True, and there is no "for
- -- Switches(Source_File) use", then this procedure also tests without the
- -- extension of the filename. If Test_Without_Suffix is True and
- -- Check_ALI_Suffix is True, then we also replace the file extension with
- -- ".ali" when testing.
-
- function Linker_Options_Switches
- (Project : Project_Id;
- Do_Fail : Fail_Proc;
- In_Tree : Project_Tree_Ref) return String_List;
- -- Collect the options specified in the Linker'Linker_Options attributes
- -- of project Project, in project tree In_Tree, and in the projects that
- -- it imports directly or indirectly, and returns the result.
-
- function Path_Or_File_Name (Path : Path_Name_Type) return String;
- -- Returns a file name if -df is used, otherwise return a path name
-
- function Unit_Index_Of (ALI_File : File_Name_Type) return Int;
- -- Find the index of a unit in a source file. Return zero if the file is
- -- not a multi-unit source file.
-
- procedure Verbose_Msg
- (N1 : Name_Id;
- S1 : String;
- N2 : Name_Id := No_Name;
- S2 : String := "";
- Prefix : String := " -> ";
- Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
- procedure Verbose_Msg
- (N1 : File_Name_Type;
- S1 : String;
- N2 : File_Name_Type := No_File;
- S2 : String := "";
- Prefix : String := " -> ";
- Minimum_Verbosity : Opt.Verbosity_Level_Type := Opt.Low);
- -- If the verbose flag (Verbose_Mode) is set and the verbosity level is at
- -- least equal to Minimum_Verbosity, then print Prefix to standard output
- -- followed by N1 and S1. If N2 /= No_Name then N2 is printed after S1. S2
- -- is printed last. Both N1 and N2 are printed in quotation marks. The two
- -- forms differ only in taking Name_Id or File_Name_Type arguments.
-
- -------------------------
- -- Program termination --
- -------------------------
-
- procedure Fail_Program
- (Project_Tree : Project_Tree_Ref;
- S : String;
- Flush_Messages : Boolean := True);
- -- Terminate program with a message and a fatal status code
-
- procedure Finish_Program
- (Project_Tree : Project_Tree_Ref;
- Exit_Code : Osint.Exit_Code_Type := Osint.E_Success;
- S : String := "");
- -- Terminate program, with or without a message, setting the status code
- -- according to Fatal. This properly removes all temporary files.
-
- --------------
- -- Switches --
- --------------
-
- generic
- with function Add_Switch
- (Switch : String;
- For_Lang : Name_Id;
- For_Builder : Boolean;
- Has_Global_Compilation_Switches : Boolean) return Boolean;
- -- For_Builder is true if we have a builder switch. This function
- -- should return True in case of success (the switch is valid),
- -- False otherwise. The error message will be displayed by
- -- Compute_Builder_Switches itself.
- --
- -- Has_Global_Compilation_Switches is True if the attribute
- -- Global_Compilation_Switches is defined in the project.
-
- procedure Compute_Builder_Switches
- (Project_Tree : Project_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Main_Project : Project_Id;
- Only_For_Lang : Name_Id := No_Name);
- -- Compute the builder switches and global compilation switches. Every time
- -- a switch is found in the project, it is passed to Add_Switch. You can
- -- provide a value for Only_For_Lang so that we only look for this language
- -- when parsing the global compilation switches.
-
- -----------------------
- -- Project_Tree data --
- -----------------------
-
- -- The following types are specific to builders, and associated with each
- -- of the loaded project trees.
-
- type Binding_Data_Record;
- type Binding_Data is access Binding_Data_Record;
- type Binding_Data_Record is record
- Language : Language_Ptr;
- Language_Name : Name_Id;
- Binder_Driver_Name : File_Name_Type;
- Binder_Driver_Path : String_Access;
- Binder_Prefix : Name_Id;
- Next : Binding_Data;
- end record;
- -- Data for a language that have a binder driver
-
- type Builder_Project_Tree_Data is new Project_Tree_Appdata with record
- Binding : Binding_Data;
-
- There_Are_Binder_Drivers : Boolean := False;
- -- True when there is a binder driver. Set by Get_Configuration when
- -- an attribute Language_Processing'Binder_Driver is declared.
- -- Reset to False if there are no sources of the languages with binder
- -- drivers.
-
- Number_Of_Mains : Natural := 0;
- -- Number of main units in this project tree
-
- Closure_Needed : Boolean := False;
- -- If True, we need to add the closure of the file we just compiled to
- -- the queue. If False, it is assumed that all files are already on the
- -- queue so we do not waste time computing the closure.
-
- Need_Compilation : Boolean := True;
- Need_Binding : Boolean := True;
- Need_Linking : Boolean := True;
- -- Which of the compilation phases are needed for this project tree
- end record;
- type Builder_Data_Access is access all Builder_Project_Tree_Data;
-
- procedure Free (Data : in out Builder_Project_Tree_Data);
- -- Free all memory allocated for Data
-
- function Builder_Data (Tree : Project_Tree_Ref) return Builder_Data_Access;
- -- Return (allocate if needed) tree-specific data
-
- procedure Compute_Compilation_Phases
- (Tree : Project_Tree_Ref;
- Root_Project : Project_Id;
- Option_Unique_Compile : Boolean := False; -- Was "-u" specified ?
- Option_Compile_Only : Boolean := False; -- Was "-c" specified ?
- Option_Bind_Only : Boolean := False;
- Option_Link_Only : Boolean := False);
- -- Compute which compilation phases will be needed for Tree. This also does
- -- the computation for aggregated trees. This also check whether we'll need
- -- to check the closure of the files we have just compiled to add them to
- -- the queue.
-
- -----------
- -- Mains --
- -----------
-
- -- Package Mains is used to store the mains specified on the command line
- -- and to retrieve them when a project file is used, to verify that the
- -- files exist and that they belong to a project file.
-
- -- Mains are stored in a table. An index is used to retrieve the mains
- -- from the table.
-
- type Main_Info is record
- File : File_Name_Type; -- Always canonical casing
- Index : Int := 0;
- Location : Source_Ptr := No_Location;
-
- Source : Prj.Source_Id := No_Source;
- Project : Project_Id;
- Tree : Project_Tree_Ref;
- end record;
-
- No_Main_Info : constant Main_Info :=
- (No_File, 0, No_Location, No_Source, No_Project, null);
-
- package Mains is
- procedure Add_Main
- (Name : String;
- Index : Int := 0;
- Location : Source_Ptr := No_Location;
- Project : Project_Id := No_Project;
- Tree : Project_Tree_Ref := null);
- -- Add one main to the table. This is in general used to add the main
- -- files specified on the command line. Index is used for multi-unit
- -- source files, and indicates which unit in the source is concerned.
- -- Location is the location within the project file (if a project file
- -- is used). Project and Tree indicate to which project the main should
- -- belong. In particular, for aggregate projects, this isn't necessarily
- -- the main project tree. These can be set to No_Project and null when
- -- not using projects.
-
- procedure Delete;
- -- Empty the table
-
- procedure Reset;
- -- Reset the cursor to the beginning of the table
-
- procedure Set_Multi_Unit_Index
- (Project_Tree : Project_Tree_Ref := null;
- Index : Int := 0);
- -- If a single main file was defined, this subprogram indicates which
- -- unit inside it is the main (case of a multi-unit source files).
- -- Errors are raised if zero or more than one main file was defined,
- -- and Index is non-zaero. This subprogram is used for the handling
- -- of the command line switch.
-
- function Next_Main return String;
- function Next_Main return Main_Info;
- -- Moves the cursor forward and returns the new current entry. Returns
- -- No_Main_Info there are no more mains in the table.
-
- function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural;
- -- Returns the number of mains in this project tree (if Tree is null, it
- -- returns the total number of project trees).
-
- procedure Fill_From_Project
- (Root_Project : Project_Id;
- Project_Tree : Project_Tree_Ref);
- -- If no main was already added (presumably from the command line), add
- -- the main units from root_project (or in the case of an aggregate
- -- project from all the aggregated projects).
-
- procedure Complete_Mains
- (Flags : Processing_Flags;
- Root_Project : Project_Id;
- Project_Tree : Project_Tree_Ref);
- -- If some main units were already added from the command line, check
- -- that they all belong to the root project, and that they are full
- -- paths rather than (partial) base names (e.g. no body suffix was
- -- specified).
-
- end Mains;
-
- -----------
- -- Queue --
- -----------
-
- type Source_Info_Format is (Format_Gprbuild, Format_Gnatmake);
-
- package Queue is
-
- -- The queue of sources to be checked for compilation. There can be a
- -- single such queue per application.
-
- type Source_Info (Format : Source_Info_Format := Format_Gprbuild) is
- record
- case Format is
- when Format_Gprbuild =>
- Tree : Project_Tree_Ref := No_Project_Tree;
- Id : Source_Id := No_Source;
- Closure : Boolean := False;
-
- when Format_Gnatmake =>
- File : File_Name_Type := No_File;
- Unit : Unit_Name_Type := No_Unit_Name;
- Index : Int := 0;
- Project : Project_Id := No_Project;
- Sid : Source_Id := No_Source;
- end case;
- end record;
- -- Information about files stored in the queue. The exact information
- -- depends on the builder, and in particular whether it only supports
- -- project-based files (in which case we have a full Source_Id record).
-
- No_Source_Info : constant Source_Info :=
- (Format_Gprbuild, null, null, False);
-
- procedure Initialize
- (Queue_Per_Obj_Dir : Boolean;
- Force : Boolean := False);
- -- Initialize the queue
- --
- -- Queue_Per_Obj_Dir matches the --single-compile-per-obj-dir switch:
- -- when True, there cannot be simultaneous compilations with the object
- -- files in the same object directory when project files are used.
- --
- -- Nothing is done if Force is False and the queue was already
- -- initialized.
-
- procedure Remove_Marks;
- -- Remove all marks set for the files. This means that the files will be
- -- handed to the compiler if they are added to the queue, and is mostly
- -- useful when recompiling several executables in non-project mode, as
- -- the switches may be different and -s may be in use.
-
- function Is_Empty return Boolean;
- -- Returns True if the queue is empty
-
- function Is_Virtually_Empty return Boolean;
- -- Returns True if queue is empty or if all object directories are busy
-
- procedure Insert (Source : Source_Info; With_Roots : Boolean := False);
- function Insert
- (Source : Source_Info; With_Roots : Boolean := False) return Boolean;
- -- Insert source in the queue. The second version returns False if the
- -- Source was already marked in the queue. If With_Roots is True and the
- -- source is in Format_Gprbuild mode (ie with a project), this procedure
- -- also includes the "Roots" for this main, ie all the other files that
- -- must be included in the library or binary (in particular to combine
- -- Ada and C files connected through pragma Export/Import). When the
- -- roots are computed, they are also stored in the corresponding
- -- Source_Id for later reuse by the binder.
-
- procedure Insert_Project_Sources
- (Project : Project_Id;
- Project_Tree : Project_Tree_Ref;
- All_Projects : Boolean;
- Unique_Compile : Boolean);
- -- Insert all the compilable sources of the project in the queue. If
- -- All_Project is true, then all sources from imported projects are also
- -- inserted. Unique_Compile should be true if "-u" was specified on the
- -- command line: if True and some files were given on the command line),
- -- only those files will be compiled (so Insert_Project_Sources will do
- -- nothing). If True and no file was specified on the command line, all
- -- files of the project(s) will be compiled. This procedure also
- -- processed aggregated projects.
-
- procedure Insert_Withed_Sources_For
- (The_ALI : ALI.ALI_Id;
- Project_Tree : Project_Tree_Ref;
- Excluding_Shared_SALs : Boolean := False);
- -- Insert in the queue those sources withed by The_ALI, if there are not
- -- already in the queue and Only_Interfaces is False or they are part of
- -- the interfaces of their project.
-
- procedure Extract
- (Found : out Boolean;
- Source : out Source_Info);
- -- Get the first source that can be compiled from the queue. If no
- -- source may be compiled, sets Found to False. In this case, the value
- -- for Source is undefined.
-
- function Size return Natural;
- -- Return the total size of the queue, including the sources already
- -- extracted.
-
- function Processed return Natural;
- -- Return the number of source in the queue that have aready been
- -- processed.
-
- procedure Set_Obj_Dir_Busy (Obj_Dir : Path_Name_Type);
- procedure Set_Obj_Dir_Free (Obj_Dir : Path_Name_Type);
- -- Mark Obj_Dir as busy or free (see the parameter to Initialize)
-
- function Element (Rank : Positive) return File_Name_Type;
- -- Get the file name for element of index Rank in the queue
-
- end Queue;
-
-end Makeutl;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . F I L --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2007, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a set of routines to deal with file extensions
-
-with Ada.Strings.Fixed;
-with MLib.Tgt;
-
-package body MLib.Fil is
-
- use Ada;
-
- package Target renames MLib.Tgt;
-
- ---------------
- -- Append_To --
- ---------------
-
- function Append_To
- (Filename : String;
- Ext : String) return String
- is
- begin
- if Ext'Length = 0 then
- return Filename;
-
- elsif Filename (Filename'Last) = '.' then
- if Ext (Ext'First) = '.' then
- return Filename & Ext (Ext'First + 1 .. Ext'Last);
-
- else
- return Filename & Ext;
- end if;
-
- else
- if Ext (Ext'First) = '.' then
- return Filename & Ext;
-
- else
- return Filename & '.' & Ext;
- end if;
- end if;
- end Append_To;
-
- ------------
- -- Ext_To --
- ------------
-
- function Ext_To
- (Filename : String;
- New_Ext : String := "") return String
- is
- use Strings.Fixed;
-
- J : constant Natural :=
- Index (Source => Filename,
- Pattern => ".",
- Going => Strings.Backward);
-
- begin
- if J = 0 then
- if New_Ext = "" then
- return Filename;
- else
- return Filename & "." & New_Ext;
- end if;
-
- else
- if New_Ext = "" then
- return Head (Filename, J - 1);
- else
- return Head (Filename, J - 1) & '.' & New_Ext;
- end if;
- end if;
- end Ext_To;
-
- -------------
- -- Get_Ext --
- -------------
-
- function Get_Ext (Filename : String) return String is
- use Strings.Fixed;
-
- J : constant Natural :=
- Index (Source => Filename,
- Pattern => ".",
- Going => Strings.Backward);
-
- begin
- if J = 0 then
- return "";
- else
- return Filename (J .. Filename'Last);
- end if;
- end Get_Ext;
-
- ----------------
- -- Is_Archive --
- ----------------
-
- function Is_Archive (Filename : String) return Boolean is
- Ext : constant String := Get_Ext (Filename);
- begin
- return Target.Is_Archive_Ext (Ext);
- end Is_Archive;
-
- ----------
- -- Is_C --
- ----------
-
- function Is_C (Filename : String) return Boolean is
- Ext : constant String := Get_Ext (Filename);
- begin
- return Target.Is_C_Ext (Ext);
- end Is_C;
-
- ------------
- -- Is_Obj --
- ------------
-
- function Is_Obj (Filename : String) return Boolean is
- Ext : constant String := Get_Ext (Filename);
- begin
- return Target.Is_Object_Ext (Ext);
- end Is_Obj;
-
-end MLib.Fil;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . F I L --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2007, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a set of routines to deal with file extensions
-
-package MLib.Fil is
-
- function Ext_To
- (Filename : String;
- New_Ext : String := "") return String;
- -- Return Filename with the extension changed to New_Ext
-
- function Append_To
- (Filename : String;
- Ext : String) return String;
- -- Return Filename with the extension Ext
-
- function Get_Ext (Filename : String) return String;
- -- Return extension of filename
-
- function Is_Archive (Filename : String) return Boolean;
- -- Test if filename is an archive
-
- function Is_C (Filename : String) return Boolean;
- -- Test if Filename is a C file
-
- function Is_Obj (Filename : String) return Boolean;
- -- Test if Filename is an object file
-
-end MLib.Fil;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . P R J --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with ALI; use ALI;
-with Gnatvsn; use Gnatvsn;
-with Makeutl; use Makeutl;
-with MLib.Fil; use MLib.Fil;
-with MLib.Tgt; use MLib.Tgt;
-with MLib.Utl; use MLib.Utl;
-with Opt;
-with Output; use Output;
-with Prj.Com; use Prj.Com;
-with Prj.Env; use Prj.Env;
-with Prj.Util; use Prj.Util;
-with Sinput.P;
-with Snames; use Snames;
-with Switch; use Switch;
-with Table;
-with Tempdir;
-with Types; use Types;
-
-with Ada.Characters.Handling;
-
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.HTable;
-with Interfaces.C_Streams; use Interfaces.C_Streams;
-with System; use System;
-with System.Case_Util; use System.Case_Util;
-
-package body MLib.Prj is
-
- Prj_Add_Obj_Files : Types.Int;
- pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files");
- Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0;
- -- Indicates if object files in pragmas Linker_Options (found in the
- -- binder generated file) should be taken when linking a stand-alone
- -- library. False for Windows, True for other platforms.
-
- ALI_Suffix : constant String := ".ali";
-
- B_Start : constant String := "b~";
- -- Prefix of bind file
-
- S_Osinte_Ads : File_Name_Type := No_File;
- -- Name_Id for "s-osinte.ads"
-
- S_Dec_Ads : File_Name_Type := No_File;
- -- Name_Id for "dec.ads"
-
- Arguments : String_List_Access := No_Argument;
- -- Used to accumulate arguments for the invocation of gnatbind and of the
- -- compiler. Also used to collect the interface ALI when copying the ALI
- -- files to the library directory.
-
- Argument_Number : Natural := 0;
- -- Index of the last argument in Arguments
-
- Initial_Argument_Max : constant := 10;
- -- Where does the magic constant 10 come from???
-
- No_Main_String : aliased String := "-n";
- No_Main : constant String_Access := No_Main_String'Access;
-
- Output_Switch_String : aliased String := "-o";
- Output_Switch : constant String_Access :=
- Output_Switch_String'Access;
-
- Compile_Switch_String : aliased String := "-c";
- Compile_Switch : constant String_Access :=
- Compile_Switch_String'Access;
-
- No_Warning_String : aliased String := "-gnatws";
- No_Warning : constant String_Access := No_Warning_String'Access;
-
- Auto_Initialize : constant String := "-a";
-
- -- List of objects to put inside the library
-
- Object_Files : Argument_List_Access;
-
- package Objects is new Table.Table
- (Table_Name => "Mlib.Prj.Objects",
- Table_Component_Type => String_Access,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 50,
- Table_Increment => 100);
-
- package Objects_Htable is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
-
- -- List of ALI files
-
- Ali_Files : Argument_List_Access;
-
- package ALIs is new Table.Table
- (Table_Name => "Mlib.Prj.Alis",
- Table_Component_Type => String_Access,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 50,
- Table_Increment => 100);
-
- -- List of options set in the command line
-
- Options : Argument_List_Access;
-
- package Opts is new Table.Table
- (Table_Name => "Mlib.Prj.Opts",
- Table_Component_Type => String_Access,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 5,
- Table_Increment => 100);
-
- -- All the ALI file in the library
-
- package Library_ALIs is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
-
- -- The ALI files in the interface sets
-
- package Interface_ALIs is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
-
- -- The ALI files that have been processed to check if the corresponding
- -- library unit is in the interface set.
-
- package Processed_ALIs is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
-
- -- The projects imported directly or indirectly
-
- package Processed_Projects is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
-
- -- The library projects imported directly or indirectly
-
- package Library_Projs is new Table.Table (
- Table_Component_Type => Project_Id,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 10,
- Table_Name => "Make.Library_Projs");
-
- type Build_Mode_State is (None, Static, Dynamic, Relocatable);
-
- procedure Add_Argument (S : String);
- -- Add one argument to Arguments array, if array is full, double its size
-
- function ALI_File_Name (Source : String) return String;
- -- Return the ALI file name corresponding to a source
-
- procedure Check (Filename : String);
- -- Check if filename is a regular file. Fail if it is not
-
- procedure Check_Context;
- -- Check each object files in table Object_Files
- -- Fail if any of them is not a regular file
-
- procedure Copy_Interface_Sources
- (For_Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Interfaces : Argument_List;
- To_Dir : Path_Name_Type);
- -- Copy the interface sources of a SAL to directory To_Dir
-
- procedure Display (Executable : String);
- -- Display invocation of gnatbind and of the compiler with the arguments
- -- in Arguments, except when Quiet_Output is True.
-
- function Index (S, Pattern : String) return Natural;
- -- Return the last occurrence of Pattern in S, or 0 if none
-
- procedure Process_Binder_File (Name : String);
- -- For Stand-Alone libraries, get the Linker Options in the binder
- -- generated file.
-
- procedure Reset_Tables;
- -- Make sure that all the above tables are empty
- -- (Objects, Ali_Files, Options).
-
- function SALs_Use_Constructors return Boolean;
- -- Indicate if Stand-Alone Libraries are automatically initialized using
- -- the constructor mechanism.
-
- ------------------
- -- Add_Argument --
- ------------------
-
- procedure Add_Argument (S : String) is
- begin
- if Argument_Number = Arguments'Last then
- declare
- New_Args : constant String_List_Access :=
- new String_List (1 .. 2 * Arguments'Last);
-
- begin
- -- Copy the String_Accesses and set them to null in Arguments
- -- so that they will not be deallocated by the call to
- -- Free (Arguments).
-
- New_Args (Arguments'Range) := Arguments.all;
- Arguments.all := (others => null);
- Free (Arguments);
- Arguments := New_Args;
- end;
- end if;
-
- Argument_Number := Argument_Number + 1;
- Arguments (Argument_Number) := new String'(S);
- end Add_Argument;
-
- -------------------
- -- ALI_File_Name --
- -------------------
-
- function ALI_File_Name (Source : String) return String is
- begin
- -- If the source name has an extension, then replace it with
- -- the ALI suffix.
-
- for Index in reverse Source'First + 1 .. Source'Last loop
- if Source (Index) = '.' then
- return Source (Source'First .. Index - 1) & ALI_Suffix;
- end if;
- end loop;
-
- -- If there is no dot, or if it is the first character, just add the
- -- ALI suffix.
-
- return Source & ALI_Suffix;
- end ALI_File_Name;
-
- -------------------
- -- Build_Library --
- -------------------
-
- procedure Build_Library
- (For_Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Gnatbind : String;
- Gnatbind_Path : String_Access;
- Gcc : String;
- Gcc_Path : String_Access;
- Bind : Boolean := True;
- Link : Boolean := True)
- is
- Maximum_Size : Integer;
- pragma Import (C, Maximum_Size, "__gnat_link_max");
- -- Maximum number of bytes to put in an invocation of gnatbind
-
- Size : Integer;
- -- The number of bytes for the invocation of gnatbind
-
- Warning_For_Library : Boolean := False;
- -- Set True for first warning for a unit missing from the interface set
-
- Current_Proj : Project_Id;
-
- Libgnarl_Needed : Yes_No_Unknown := For_Project.Libgnarl_Needed;
- -- Set True if library needs to be linked with libgnarl
-
- Object_Directory_Path : constant String :=
- Get_Name_String
- (For_Project.Object_Directory.Display_Name);
-
- Standalone : constant Boolean := For_Project.Standalone_Library /= No;
-
- Project_Name : constant String := Get_Name_String (For_Project.Name);
-
- Current_Dir : constant String := Get_Current_Dir;
-
- Lib_Filename : String_Access;
- Lib_Dirpath : String_Access;
- Lib_Version : String_Access := new String'("");
-
- The_Build_Mode : Build_Mode_State := None;
-
- Success : Boolean := False;
-
- Library_Options : Variable_Value := Nil_Variable_Value;
-
- Driver_Name : Name_Id := No_Name;
-
- In_Main_Object_Directory : Boolean := True;
-
- Foreign_Sources : Boolean;
-
- Rpath : String_Access := null;
- -- Allocated only if Path Option is supported
-
- Rpath_Last : Natural := 0;
- -- Index of last valid character of Rpath
-
- Initial_Rpath_Length : constant := 200;
- -- Initial size of Rpath, when first allocated
-
- Path_Option : String_Access := Linker_Library_Path_Option;
- -- If null, Path Option is not supported. Not a constant so that it can
- -- be deallocated.
-
- First_ALI : File_Name_Type := No_File;
- -- Store the ALI file name of a source of the library (the first found)
-
- procedure Add_ALI_For (Source : File_Name_Type);
- -- Add name of the ALI file corresponding to Source to the Arguments
-
- procedure Add_Rpath (Path : String);
- -- Add a path name to Rpath
-
- function Check_Project (P : Project_Id) return Boolean;
- -- Returns True if P is For_Project or a project extended by For_Project
-
- procedure Check_Libs (ALI_File : String; Main_Project : Boolean);
- -- Set Libgnarl_Needed if the ALI_File indicates that there is a need
- -- to link with -lgnarl (this is the case when there is a dependency
- -- on s-osinte.ads).
-
- procedure Process (The_ALI : File_Name_Type);
- -- Check if the closure of a library unit which is or should be in the
- -- interface set is also in the interface set. Issue a warning for each
- -- missing library unit.
-
- procedure Process_Imported_Libraries;
- -- Add the -L and -l switches for the imported Library Project Files,
- -- and, if Path Option is supported, the library directory path names
- -- to Rpath.
-
- -----------------
- -- Add_ALI_For --
- -----------------
-
- procedure Add_ALI_For (Source : File_Name_Type) is
- ALI : constant String := ALI_File_Name (Get_Name_String (Source));
- ALI_Id : File_Name_Type;
-
- begin
- if Bind then
- Add_Argument (ALI);
- end if;
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer (S => ALI);
- ALI_Id := Name_Find;
-
- -- Add the ALI file name to the library ALIs
-
- if Bind then
- Library_ALIs.Set (ALI_Id, True);
- end if;
-
- -- Set First_ALI, if not already done
-
- if First_ALI = No_File then
- First_ALI := ALI_Id;
- end if;
- end Add_ALI_For;
-
- ---------------
- -- Add_Rpath --
- ---------------
-
- procedure Add_Rpath (Path : String) is
-
- procedure Double;
- -- Double Rpath size
-
- ------------
- -- Double --
- ------------
-
- procedure Double is
- New_Rpath : constant String_Access :=
- new String (1 .. 2 * Rpath'Length);
- begin
- New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last);
- Free (Rpath);
- Rpath := New_Rpath;
- end Double;
-
- -- Start of processing for Add_Rpath
-
- begin
- -- If first path, allocate initial Rpath
-
- if Rpath = null then
- Rpath := new String (1 .. Initial_Rpath_Length);
- Rpath_Last := 0;
-
- else
- -- Otherwise, add a path separator between two path names
-
- if Rpath_Last = Rpath'Last then
- Double;
- end if;
-
- Rpath_Last := Rpath_Last + 1;
- Rpath (Rpath_Last) := Path_Separator;
- end if;
-
- -- Increase Rpath size until it is large enough
-
- while Rpath_Last + Path'Length > Rpath'Last loop
- Double;
- end loop;
-
- -- Add the path name
-
- Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path;
- Rpath_Last := Rpath_Last + Path'Length;
- end Add_Rpath;
-
- -------------------
- -- Check_Project --
- -------------------
-
- function Check_Project (P : Project_Id) return Boolean is
- begin
- if P = For_Project then
- return True;
-
- elsif P /= No_Project then
- declare
- Proj : Project_Id;
-
- begin
- Proj := For_Project;
- while Proj.Extends /= No_Project loop
- if P = Proj.Extends then
- return True;
- end if;
-
- Proj := Proj.Extends;
- end loop;
- end;
- end if;
-
- return False;
- end Check_Project;
-
- ----------------
- -- Check_Libs --
- ----------------
-
- procedure Check_Libs (ALI_File : String; Main_Project : Boolean) is
- Lib_File : File_Name_Type;
- Text : Text_Buffer_Ptr;
- Id : ALI.ALI_Id;
-
- begin
- if Libgnarl_Needed /= Yes then
-
- -- Scan the ALI file
-
- Name_Len := ALI_File'Length;
- Name_Buffer (1 .. Name_Len) := ALI_File;
- Lib_File := Name_Find;
- Text := Read_Library_Info (Lib_File, True);
-
- Id := ALI.Scan_ALI
- (F => Lib_File,
- T => Text,
- Ignore_ED => False,
- Err => True,
- Read_Lines => "D");
- Free (Text);
-
- -- Look for s-osinte.ads in the dependencies
-
- for Index in ALI.ALIs.Table (Id).First_Sdep ..
- ALI.ALIs.Table (Id).Last_Sdep
- loop
- if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then
- Libgnarl_Needed := Yes;
-
- if Main_Project then
- For_Project.Libgnarl_Needed := Yes;
- else
- exit;
- end if;
- end if;
- end loop;
- end if;
- end Check_Libs;
-
- -------------
- -- Process --
- -------------
-
- procedure Process (The_ALI : File_Name_Type) is
- Text : Text_Buffer_Ptr;
- Idread : ALI_Id;
- First_Unit : ALI.Unit_Id;
- Last_Unit : ALI.Unit_Id;
- Unit_Data : Unit_Record;
- Afile : File_Name_Type;
-
- begin
- -- Nothing to do if the ALI file has already been processed.
- -- This happens if an interface imports another interface.
-
- if not Processed_ALIs.Get (The_ALI) then
- Processed_ALIs.Set (The_ALI, True);
- Text := Read_Library_Info (The_ALI);
-
- if Text /= null then
- Idread :=
- Scan_ALI
- (F => The_ALI,
- T => Text,
- Ignore_ED => False,
- Err => True);
- Free (Text);
-
- if Idread /= No_ALI_Id then
- First_Unit := ALI.ALIs.Table (Idread).First_Unit;
- Last_Unit := ALI.ALIs.Table (Idread).Last_Unit;
-
- -- Process both unit (spec and body) if the body is needed
- -- by the spec (inline or generic). Otherwise, just process
- -- the spec.
-
- if First_Unit /= Last_Unit and then
- not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL
- then
- First_Unit := Last_Unit;
- end if;
-
- for Unit in First_Unit .. Last_Unit loop
- Unit_Data := ALI.Units.Table (Unit);
-
- -- Check if each withed unit which is in the library is
- -- also in the interface set, if it has not yet been
- -- processed.
-
- for W in Unit_Data.First_With .. Unit_Data.Last_With loop
- Afile := Withs.Table (W).Afile;
-
- if Afile /= No_File and then Library_ALIs.Get (Afile)
- and then not Processed_ALIs.Get (Afile)
- then
- if not Interface_ALIs.Get (Afile) then
- if not Warning_For_Library then
- Write_Str ("Warning: In library project """);
- Get_Name_String (Current_Proj.Name);
- To_Mixed (Name_Buffer (1 .. Name_Len));
- Write_Str (Name_Buffer (1 .. Name_Len));
- Write_Line ("""");
- Warning_For_Library := True;
- end if;
-
- Write_Str (" Unit """);
- Get_Name_String (Withs.Table (W).Uname);
- To_Mixed (Name_Buffer (1 .. Name_Len - 2));
- Write_Str (Name_Buffer (1 .. Name_Len - 2));
- Write_Line (""" is not in the interface set");
- Write_Str (" but it is needed by ");
-
- case Unit_Data.Utype is
- when Is_Spec =>
- Write_Str ("the spec of ");
-
- when Is_Body =>
- Write_Str ("the body of ");
-
- when others =>
- null;
- end case;
-
- Write_Str ("""");
- Get_Name_String (Unit_Data.Uname);
- To_Mixed (Name_Buffer (1 .. Name_Len - 2));
- Write_Str (Name_Buffer (1 .. Name_Len - 2));
- Write_Line ("""");
- end if;
-
- -- Now, process this unit
-
- Process (Afile);
- end if;
- end loop;
- end loop;
- end if;
- end if;
- end if;
- end Process;
-
- --------------------------------
- -- Process_Imported_Libraries --
- --------------------------------
-
- procedure Process_Imported_Libraries is
- Current : Project_Id;
-
- procedure Process_Project (Project : Project_Id);
- -- Process Project and its imported projects recursively.
- -- Add any library projects to table Library_Projs.
-
- ---------------------
- -- Process_Project --
- ---------------------
-
- procedure Process_Project (Project : Project_Id) is
- Imported : Project_List;
-
- begin
- -- Nothing to do if process has already been processed
-
- if not Processed_Projects.Get (Project.Name) then
- Processed_Projects.Set (Project.Name, True);
-
- -- Call Process_Project recursively for any imported project.
- -- We first process the imported projects to guarantee that
- -- we have a proper reverse order for the libraries.
-
- Imported := Project.Imported_Projects;
- while Imported /= null loop
- if Imported.Project /= No_Project then
- Process_Project (Imported.Project);
- end if;
-
- Imported := Imported.Next;
- end loop;
-
- -- If it is a library project, add it to Library_Projs
-
- if Project /= For_Project and then Project.Library then
- Library_Projs.Increment_Last;
- Library_Projs.Table (Library_Projs.Last) := Project;
-
- -- Check if because of this library we need to use libgnarl
-
- if Libgnarl_Needed = Unknown then
- if Project.Libgnarl_Needed = Unknown
- and then Project.Object_Directory /= No_Path_Information
- then
- -- Check if libgnarl is needed for this library
-
- declare
- Object_Dir_Path : constant String :=
- Get_Name_String
- (Project.Object_Directory.
- Display_Name);
- Object_Dir : Dir_Type;
- Filename : String (1 .. 255);
- Last : Natural;
-
- begin
- Open (Object_Dir, Object_Dir_Path);
-
- -- For all entries in the object directory
-
- loop
- Read (Object_Dir, Filename, Last);
- exit when Last = 0;
-
- -- Check if it is an object file
-
- if Is_Obj (Filename (1 .. Last)) then
- declare
- Object_Path : constant String :=
- Normalize_Pathname
- (Object_Dir_Path &
- Directory_Separator &
- Filename (1 .. Last));
- ALI_File : constant String :=
- Ext_To
- (Object_Path, "ali");
-
- begin
- if Is_Regular_File (ALI_File) then
-
- -- Find out if for this ALI file,
- -- libgnarl is necessary.
-
- Check_Libs
- (ALI_File, Main_Project => False);
-
- if Libgnarl_Needed = Yes then
- Project.Libgnarl_Needed := Yes;
- For_Project.Libgnarl_Needed := Yes;
- exit;
- end if;
- end if;
- end;
- end if;
- end loop;
-
- Close (Object_Dir);
- end;
- end if;
-
- if Project.Libgnarl_Needed = Yes then
- Libgnarl_Needed := Yes;
- For_Project.Libgnarl_Needed := Yes;
- end if;
- end if;
- end if;
- end if;
- end Process_Project;
-
- -- Start of processing for Process_Imported_Libraries
-
- begin
- -- Build list of library projects imported directly or indirectly,
- -- in the reverse order.
-
- Process_Project (For_Project);
-
- -- Add the -L and -l switches and, if the Rpath option is supported,
- -- add the directory to the Rpath. As the library projects are in the
- -- wrong order, process from the last to the first.
-
- for Index in reverse 1 .. Library_Projs.Last loop
- Current := Library_Projs.Table (Index);
-
- Get_Name_String (Current.Library_Dir.Display_Name);
- Opts.Increment_Last;
- Opts.Table (Opts.Last) :=
- new String'("-L" & Name_Buffer (1 .. Name_Len));
-
- if Path_Option /= null then
- Add_Rpath (Name_Buffer (1 .. Name_Len));
- end if;
-
- Opts.Increment_Last;
- Opts.Table (Opts.Last) :=
- new String'("-l" & Get_Name_String (Current.Library_Name));
- end loop;
- end Process_Imported_Libraries;
-
- Path_FD : File_Descriptor := Invalid_FD;
- -- Used for setting the source and object paths
-
- -- Start of processing for Build_Library
-
- begin
- Reset_Tables;
-
- -- Fail if project is not a library project
-
- if not For_Project.Library then
- Com.Fail ("project """ & Project_Name & """ has no library");
- end if;
-
- -- Do not attempt to build the library if it is externally built
-
- if For_Project.Externally_Built then
- return;
- end if;
-
- -- If this is the first time Build_Library is called, get the Name_Id
- -- of "s-osinte.ads".
-
- if S_Osinte_Ads = No_File then
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("s-osinte.ads");
- S_Osinte_Ads := Name_Find;
- end if;
-
- if S_Dec_Ads = No_File then
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("dec.ads");
- S_Dec_Ads := Name_Find;
- end if;
-
- -- We work in the object directory
-
- Change_Dir (Object_Directory_Path);
-
- if Standalone then
-
- -- Call gnatbind only if Bind is True
-
- if Bind then
- if Gnatbind_Path = null then
- Com.Fail ("unable to locate " & Gnatbind);
- end if;
-
- if Gcc_Path = null then
- Com.Fail ("unable to locate " & Gcc);
- end if;
-
- -- Allocate Arguments, if it is the first time we see a standalone
- -- library.
-
- if Arguments = No_Argument then
- Arguments := new String_List (1 .. Initial_Argument_Max);
- end if;
-
- -- Add "-n -o b~<lib>.adb -L<lib>_"
-
- Argument_Number := 2;
- Arguments (1) := No_Main;
- Arguments (2) := Output_Switch;
-
- Add_Argument
- (B_Start & Get_Name_String (For_Project.Library_Name) & ".adb");
-
- -- Make sure that the init procedure is never "adainit"
-
- Get_Name_String (For_Project.Library_Name);
-
- if Name_Buffer (1 .. Name_Len) = "ada" then
- Add_Argument ("-Lada_");
- else
- Add_Argument
- ("-L" & Get_Name_String (For_Project.Library_Name));
- end if;
-
- if For_Project.Lib_Auto_Init and then SALs_Use_Constructors then
- Add_Argument (Auto_Initialize);
- end if;
-
- -- Check if Binder'Default_Switches ("Ada") is defined. If it is,
- -- add these switches to call gnatbind.
-
- declare
- Binder_Package : constant Package_Id :=
- Value_Of
- (Name => Name_Binder,
- In_Packages => For_Project.Decl.Packages,
- Shared => In_Tree.Shared);
-
- begin
- if Binder_Package /= No_Package then
- declare
- Defaults : constant Array_Element_Id :=
- Value_Of
- (Name => Name_Default_Switches,
- In_Arrays =>
- In_Tree.Shared.Packages.Table
- (Binder_Package).Decl.Arrays,
- Shared => In_Tree.Shared);
-
- Switches : Variable_Value := Nil_Variable_Value;
- Switch : String_List_Id := Nil_String;
-
- begin
- if Defaults /= No_Array_Element then
- Switches :=
- Value_Of
- (Index => Name_Ada,
- Src_Index => 0,
- In_Array => Defaults,
- Shared => In_Tree.Shared);
-
- if not Switches.Default then
- Switch := Switches.Values;
-
- while Switch /= Nil_String loop
- Add_Argument
- (Get_Name_String
- (In_Tree.Shared.String_Elements.Table
- (Switch).Value));
- Switch := In_Tree.Shared.String_Elements.
- Table (Switch).Next;
- end loop;
- end if;
- end if;
- end;
- end if;
- end;
- end if;
-
- -- Get all the ALI files of the project file. We do that even if
- -- Bind is False, so that First_ALI is set.
-
- declare
- Unit : Unit_Index;
-
- begin
- Library_ALIs.Reset;
- Interface_ALIs.Reset;
- Processed_ALIs.Reset;
-
- Unit := Units_Htable.Get_First (In_Tree.Units_HT);
- while Unit /= No_Unit_Index loop
- if Unit.File_Names (Impl) /= null
- and then not Unit.File_Names (Impl).Locally_Removed
- then
- if Check_Project (Unit.File_Names (Impl).Project) then
- if Unit.File_Names (Spec) = null then
-
- -- Add the ALI file only if it is not a subunit
-
- declare
- Src_Ind : constant Source_File_Index :=
- Sinput.P.Load_Project_File
- (Get_Name_String
- (Unit.File_Names (Impl).Path.Name));
- begin
- if not
- Sinput.P.Source_File_Is_Subunit (Src_Ind)
- then
- Add_ALI_For (Unit.File_Names (Impl).File);
- exit when not Bind;
- end if;
- end;
-
- else
- Add_ALI_For (Unit.File_Names (Impl).File);
- exit when not Bind;
- end if;
- end if;
-
- elsif Unit.File_Names (Spec) /= null
- and then not Unit.File_Names (Spec).Locally_Removed
- and then Check_Project (Unit.File_Names (Spec).Project)
- then
- Add_ALI_For (Unit.File_Names (Spec).File);
- exit when not Bind;
- end if;
-
- Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
- end loop;
- end;
-
- -- Continue setup and call gnatbind if Bind is True
-
- if Bind then
-
- -- Get an eventual --RTS from the ALI file
-
- if First_ALI /= No_File then
- declare
- T : Text_Buffer_Ptr;
- A : ALI_Id;
-
- begin
- -- Load the ALI file
-
- T := Read_Library_Info (First_ALI, True);
-
- -- Read it
-
- A := Scan_ALI
- (First_ALI, T, Ignore_ED => False, Err => False);
-
- if A /= No_ALI_Id then
- for Index in
- ALI.Units.Table
- (ALI.ALIs.Table (A).First_Unit).First_Arg ..
- ALI.Units.Table
- (ALI.ALIs.Table (A).First_Unit).Last_Arg
- loop
- -- If --RTS found, add switch to call gnatbind
-
- declare
- Arg : String_Ptr renames Args.Table (Index);
- begin
- if Arg'Length >= 6 and then
- Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
- then
- Add_Argument (Arg.all);
- exit;
- end if;
- end;
- end loop;
- end if;
- end;
- end if;
-
- -- Set the paths
-
- -- First the source path
-
- if For_Project.Include_Path_File = No_Path then
- Get_Directories
- (Project_Tree => In_Tree,
- For_Project => For_Project,
- Activity => Compilation,
- Languages => Ada_Only);
-
- Create_New_Path_File
- (In_Tree.Shared, Path_FD, For_Project.Include_Path_File);
-
- Write_Path_File (Path_FD);
- Path_FD := Invalid_FD;
- end if;
-
- if Current_Source_Path_File_Of (In_Tree.Shared) /=
- For_Project.Include_Path_File
- then
- Set_Current_Source_Path_File_Of
- (In_Tree.Shared, For_Project.Include_Path_File);
- Set_Path_File_Var
- (Project_Include_Path_File,
- Get_Name_String (For_Project.Include_Path_File));
- end if;
-
- -- Then, the object path
-
- Get_Directories
- (Project_Tree => In_Tree,
- For_Project => For_Project,
- Activity => SAL_Binding,
- Languages => Ada_Only);
-
- declare
- Path_File_Name : Path_Name_Type;
-
- begin
- Create_New_Path_File (In_Tree.Shared, Path_FD, Path_File_Name);
-
- Write_Path_File (Path_FD);
- Path_FD := Invalid_FD;
-
- Set_Path_File_Var
- (Project_Objects_Path_File, Get_Name_String (Path_File_Name));
- Set_Current_Source_Path_File_Of
- (In_Tree.Shared, Path_File_Name);
- end;
-
- -- Display the gnatbind command, if not in quiet output
-
- Display (Gnatbind);
-
- Size := 0;
- for J in 1 .. Argument_Number loop
- Size := Size + Arguments (J)'Length + 1;
- end loop;
-
- -- Invoke gnatbind with the arguments if the size is not too large
-
- if Size <= Maximum_Size then
- Spawn
- (Gnatbind_Path.all,
- Arguments (1 .. Argument_Number),
- Success);
-
- -- Otherwise create a temporary response file
-
- else
- declare
- FD : File_Descriptor;
- Path : Path_Name_Type;
- Args : Argument_List (1 .. 1);
- EOL : constant String (1 .. 1) := (1 => ASCII.LF);
- Status : Integer;
- Succ : Boolean;
- Quotes_Needed : Boolean;
- Last_Char : Natural;
- Ch : Character;
-
- begin
- Tempdir.Create_Temp_File (FD, Path);
- Args (1) := new String'("@" & Get_Name_String (Path));
-
- for J in 1 .. Argument_Number loop
-
- -- Check if the argument should be quoted
-
- Quotes_Needed := False;
- Last_Char := Arguments (J)'Length;
-
- for K in Arguments (J)'Range loop
- Ch := Arguments (J) (K);
-
- if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then
- Quotes_Needed := True;
- exit;
- end if;
- end loop;
-
- if Quotes_Needed then
-
- -- Quote the argument, doubling '"'
-
- declare
- Arg : String (1 .. Arguments (J)'Length * 2 + 2);
-
- begin
- Arg (1) := '"';
- Last_Char := 1;
-
- for K in Arguments (J)'Range loop
- Ch := Arguments (J) (K);
- Last_Char := Last_Char + 1;
- Arg (Last_Char) := Ch;
-
- if Ch = '"' then
- Last_Char := Last_Char + 1;
- Arg (Last_Char) := '"';
- end if;
- end loop;
-
- Last_Char := Last_Char + 1;
- Arg (Last_Char) := '"';
-
- Status := Write (FD, Arg'Address, Last_Char);
- end;
-
- else
- Status := Write
- (FD,
- Arguments (J) (Arguments (J)'First)'Address,
- Last_Char);
- end if;
-
- if Status /= Last_Char then
- Fail ("disk full");
- end if;
-
- Status := Write (FD, EOL (1)'Address, 1);
-
- if Status /= 1 then
- Fail ("disk full");
- end if;
- end loop;
-
- Close (FD);
-
- -- And invoke gnatbind with this response file
-
- Spawn (Gnatbind_Path.all, Args, Success);
-
- Delete_File (Get_Name_String (Path), Succ);
-
- -- We ignore a failure in this Delete_File operation.
- -- Is that OK??? If so, worth a comment as to why we
- -- are OK with the operation failing
- end;
- end if;
-
- if not Success then
- Com.Fail ("could not bind standalone library "
- & Get_Name_String (For_Project.Library_Name));
- end if;
- end if;
-
- -- Compile the binder generated file only if Link is true
-
- if Link then
-
- -- Set the paths
-
- Set_Ada_Paths
- (Project => For_Project,
- In_Tree => In_Tree,
- Including_Libraries => True);
-
- -- Invoke <gcc> -c b__<lib>.adb
-
- -- Allocate Arguments, if first time we see a standalone library
-
- if Arguments = No_Argument then
- Arguments := new String_List (1 .. Initial_Argument_Max);
- end if;
-
- Argument_Number := 2;
- Arguments (1) := Compile_Switch;
- Arguments (2) := No_Warning;
-
- Add_Argument
- (B_Start & Get_Name_String (For_Project.Library_Name) & ".adb");
-
- -- If necessary, add the PIC option
-
- if PIC_Option /= "" then
- Add_Argument (PIC_Option);
- end if;
-
- -- Get the back-end switches and --RTS from the ALI file
-
- if First_ALI /= No_File then
- declare
- T : Text_Buffer_Ptr;
- A : ALI_Id;
-
- begin
- -- Load the ALI file
-
- T := Read_Library_Info (First_ALI, True);
-
- -- Read it
-
- A :=
- Scan_ALI (First_ALI, T, Ignore_ED => False, Err => False);
-
- if A /= No_ALI_Id then
- for Index in
- ALI.Units.Table
- (ALI.ALIs.Table (A).First_Unit).First_Arg ..
- ALI.Units.Table
- (ALI.ALIs.Table (A).First_Unit).Last_Arg
- loop
- -- Do not compile with the front end switches except
- -- for --RTS.
-
- declare
- Arg : String_Ptr renames Args.Table (Index);
- begin
- if not Is_Front_End_Switch (Arg.all)
- or else
- Arg (Arg'First + 2 .. Arg'First + 5) = "RTS="
- then
- Add_Argument (Arg.all);
- end if;
- end;
- end loop;
- end if;
- end;
- end if;
-
- -- Now all the arguments are set, compile binder generated file
-
- Display (Gcc);
- Spawn
- (Gcc_Path.all, Arguments (1 .. Argument_Number), Success);
-
- if not Success then
- Com.Fail
- ("could not compile binder generated file for library "
- & Get_Name_String (For_Project.Library_Name));
- end if;
-
- -- Process binder generated file for pragmas Linker_Options
-
- Process_Binder_File (Arguments (3).all & ASCII.NUL);
- end if;
- end if;
-
- -- Build the library only if Link is True
-
- if Link then
-
- -- If attributes Library_GCC or Linker'Driver were specified, get the
- -- driver name.
-
- if For_Project.Config.Shared_Lib_Driver /= No_File then
- Driver_Name := Name_Id (For_Project.Config.Shared_Lib_Driver);
- end if;
-
- -- If attribute Library_Options was specified, add these options
-
- Library_Options := Value_Of
- (Name_Library_Options, For_Project.Decl.Attributes,
- In_Tree.Shared);
-
- if not Library_Options.Default then
- declare
- Current : String_List_Id;
- Element : String_Element;
-
- begin
- Current := Library_Options.Values;
- while Current /= Nil_String loop
- Element := In_Tree.Shared.String_Elements.Table (Current);
- Get_Name_String (Element.Value);
-
- if Name_Len /= 0 then
- Opts.Increment_Last;
- Opts.Table (Opts.Last) :=
- new String'(Name_Buffer (1 .. Name_Len));
- end if;
-
- Current := Element.Next;
- end loop;
- end;
- end if;
-
- Lib_Dirpath :=
- new String'(Get_Name_String (For_Project.Library_Dir.Display_Name));
- Lib_Filename :=
- new String'(Get_Name_String (For_Project.Library_Name));
-
- case For_Project.Library_Kind is
- when Static =>
- The_Build_Mode := Static;
-
- when Dynamic =>
- The_Build_Mode := Dynamic;
-
- when Relocatable =>
- The_Build_Mode := Relocatable;
-
- if PIC_Option /= "" then
- Opts.Increment_Last;
- Opts.Table (Opts.Last) := new String'(PIC_Option);
- end if;
- end case;
-
- -- Get the library version, if any
-
- if For_Project.Lib_Internal_Name /= No_Name then
- Lib_Version :=
- new String'(Get_Name_String (For_Project.Lib_Internal_Name));
- end if;
-
- -- Add the objects found in the object directory and the object
- -- directories of the extended files, if any, except for generated
- -- object files (b~.. or B__..) from extended projects.
- -- When there are one or more extended files, only add an object file
- -- if no object file with the same name have already been added.
-
- In_Main_Object_Directory := True;
-
- -- For gnatmake, when the project specifies more than just Ada as a
- -- language (even if course we could not find any source file for
- -- the other languages), we will take all object files found in the
- -- object directories. Since we know the project supports at least
- -- Ada, we just have to test whether it has at least two languages,
- -- and not care about the sources.
-
- Foreign_Sources := For_Project.Languages.Next /= null;
- Current_Proj := For_Project;
- loop
- if Current_Proj.Object_Directory /= No_Path_Information then
-
- -- The following code gets far too indented ... suggest some
- -- procedural abstraction here. How about making this declare
- -- block a named procedure???
-
- declare
- Object_Dir_Path : constant String :=
- Get_Name_String
- (Current_Proj.Object_Directory
- .Display_Name);
-
- Object_Dir : Dir_Type;
- Filename : String (1 .. 255);
- Last : Natural;
- Id : Name_Id;
-
- begin
- Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path);
-
- -- For all entries in the object directory
-
- loop
- Read (Object_Dir, Filename, Last);
-
- exit when Last = 0;
-
- -- Check if it is an object file
-
- if Is_Obj (Filename (1 .. Last)) then
- declare
- Object_Path : constant String :=
- Normalize_Pathname
- (Object_Dir_Path
- & Directory_Separator
- & Filename (1 .. Last));
- Object_File : constant String :=
- Filename (1 .. Last);
-
- C_Filename : String := Object_File;
-
- begin
- Canonical_Case_File_Name (C_Filename);
-
- -- If in the object directory of an extended
- -- project, do not consider generated object files.
-
- if In_Main_Object_Directory
- or else Last < 5
- or else
- C_Filename (1 .. B_Start'Length) /= B_Start
- then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (C_Filename);
- Id := Name_Find;
-
- if not Objects_Htable.Get (Id) then
- declare
- ALI_File : constant String :=
- Ext_To (C_Filename, "ali");
-
- ALI_Path : constant String :=
- Ext_To (Object_Path, "ali");
-
- Add_It : Boolean;
- Fname : File_Name_Type;
- Proj : Project_Id;
- Index : Unit_Index;
-
- begin
- -- The following assignment could use
- -- a comment ???
-
- Add_It :=
- Foreign_Sources
- or else
- (Last >= 5
- and then
- C_Filename (1 .. B_Start'Length)
- = B_Start);
-
- if Is_Regular_File (ALI_Path) then
-
- -- If there is an ALI file, check if
- -- the object file should be added to
- -- the library. If there are foreign
- -- sources we put all object files in
- -- the library.
-
- if not Add_It then
- Index :=
- Units_Htable.Get_First
- (In_Tree.Units_HT);
- while Index /= null loop
- if Index.File_Names (Impl) /=
- null
- then
- Proj :=
- Index.File_Names (Impl)
- .Project;
- Fname :=
- Index.File_Names (Impl).File;
-
- elsif Index.File_Names (Spec) /=
- null
- then
- Proj :=
- Index.File_Names (Spec)
- .Project;
- Fname :=
- Index.File_Names (Spec).File;
-
- else
- Proj := No_Project;
- end if;
-
- Add_It := Proj /= No_Project;
-
- -- If the source is in the
- -- project or a project it
- -- extends, we may put it in
- -- the library.
-
- if Add_It then
- Add_It := Check_Project (Proj);
- end if;
-
- -- But we don't, if the ALI file
- -- does not correspond to the
- -- unit.
-
- if Add_It then
- declare
- F : constant String :=
- Ext_To
- (Get_Name_String
- (Fname), "ali");
- begin
- Add_It := F = ALI_File;
- end;
- end if;
-
- exit when Add_It;
-
- Index :=
- Units_Htable.Get_Next
- (In_Tree.Units_HT);
- end loop;
- end if;
-
- if Add_It then
- Objects_Htable.Set (Id, True);
- Objects.Append
- (new String'(Object_Path));
-
- -- Record the ALI file
-
- ALIs.Append (new String'(ALI_Path));
-
- -- Find out if for this ALI file,
- -- libgnarl is necessary.
-
- Check_Libs (ALI_Path, True);
- end if;
-
- elsif Foreign_Sources then
- Objects.Append
- (new String'(Object_Path));
- end if;
- end;
- end if;
- end if;
- end;
- end if;
- end loop;
-
- Close (Dir => Object_Dir);
-
- exception
- when Directory_Error =>
- Com.Fail ("cannot find object directory """
- & Get_Name_String
- (Current_Proj.Object_Directory.Display_Name)
- & """");
- end;
- end if;
-
- exit when Current_Proj.Extends = No_Project;
-
- In_Main_Object_Directory := False;
- Current_Proj := Current_Proj.Extends;
- end loop;
-
- -- Add the -L and -l switches for the imported Library Project Files,
- -- and, if Path Option is supported, the library directory path names
- -- to Rpath.
-
- Process_Imported_Libraries;
-
- -- Link with libgnat and possibly libgnarl
-
- Opts.Increment_Last;
- Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory);
-
- -- If Path Option supported, add libgnat directory path name to Rpath
-
- if Path_Option /= null then
- declare
- Libdir : constant String := Lib_Directory;
- GCC_Index : Natural := 0;
-
- begin
- Add_Rpath (Libdir);
-
- -- For shared libraries, add to the Path Option the directory
- -- of the shared version of libgcc.
-
- if The_Build_Mode /= Static then
- GCC_Index := Index (Libdir, "/lib/");
-
- if GCC_Index = 0 then
- GCC_Index :=
- Index
- (Libdir,
- Directory_Separator & "lib" & Directory_Separator);
- end if;
-
- if GCC_Index /= 0 then
- Add_Rpath (Libdir (Libdir'First .. GCC_Index + 3));
- end if;
- end if;
- end;
- end if;
-
- if Libgnarl_Needed = Yes then
- Opts.Increment_Last;
-
- if The_Build_Mode = Static then
- Opts.Table (Opts.Last) := new String'("-lgnarl");
- else
- Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl"));
- end if;
- end if;
-
- Opts.Increment_Last;
-
- if The_Build_Mode = Static then
- Opts.Table (Opts.Last) := new String'("-lgnat");
- else
- Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat"));
- end if;
-
- -- If Path Option is supported, add the necessary switch with the
- -- content of Rpath. As Rpath contains at least libgnat directory
- -- path name, it is guaranteed that it is not null.
-
- if Opt.Run_Path_Option and then Path_Option /= null then
- Opts.Increment_Last;
- Opts.Table (Opts.Last) :=
- new String'(Path_Option.all & Rpath (1 .. Rpath_Last));
- Free (Path_Option);
- Free (Rpath);
- end if;
-
- Object_Files :=
- new Argument_List'
- (Argument_List (Objects.Table (1 .. Objects.Last)));
-
- Ali_Files :=
- new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last)));
-
- Options :=
- new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last)));
-
- -- We fail if there are no object to put in the library
- -- (Ada or foreign objects).
-
- if Object_Files'Length = 0 then
- Com.Fail ("no object files for library """ &
- Lib_Filename.all & '"');
- end if;
-
- if not Opt.Quiet_Output then
- Write_Eol;
- Write_Str ("building ");
- Write_Str (Ada.Characters.Handling.To_Lower
- (Build_Mode_State'Image (The_Build_Mode)));
- Write_Str (" library for project ");
- Write_Line (Project_Name);
-
- -- Only output list of object files and ALI files in verbose mode
-
- if Opt.Verbose_Mode then
- Write_Eol;
-
- Write_Line ("object files:");
-
- for Index in Object_Files'Range loop
- Write_Str (" ");
- Write_Line (Object_Files (Index).all);
- end loop;
-
- Write_Eol;
-
- if Ali_Files'Length = 0 then
- Write_Line ("NO ALI files");
-
- else
- Write_Line ("ALI files:");
-
- for Index in Ali_Files'Range loop
- Write_Str (" ");
- Write_Line (Ali_Files (Index).all);
- end loop;
- end if;
-
- Write_Eol;
- end if;
- end if;
-
- -- We check that all object files are regular files
-
- Check_Context;
-
- -- Delete the existing library file, if it exists. Fail if the
- -- library file is not writable, or if it is not possible to delete
- -- the file.
-
- declare
- DLL_Name : aliased String :=
- Lib_Dirpath.all & Directory_Separator & DLL_Prefix &
- Lib_Filename.all & "." & DLL_Ext;
-
- Archive_Name : aliased String :=
- Lib_Dirpath.all & Directory_Separator & "lib" &
- Lib_Filename.all & "." & Archive_Ext;
-
- type Str_Ptr is access all String;
- -- This type is necessary to meet the accessibility rules of Ada.
- -- It is not possible to use String_Access here.
-
- Full_Lib_Name : Str_Ptr;
- -- Designates the full library path name. Either DLL_Name or
- -- Archive_Name, depending on the library kind.
-
- Success : Boolean;
- pragma Warnings (Off, Success);
- -- Used to call Delete_File
-
- begin
- if The_Build_Mode = Static then
- Full_Lib_Name := Archive_Name'Access;
- else
- Full_Lib_Name := DLL_Name'Access;
- end if;
-
- if Is_Regular_File (Full_Lib_Name.all) then
- if Is_Writable_File (Full_Lib_Name.all) then
- Delete_File (Full_Lib_Name.all, Success);
- end if;
-
- if Is_Regular_File (Full_Lib_Name.all) then
- Com.Fail ("could not delete """ & Full_Lib_Name.all & """");
- end if;
- end if;
- end;
-
- Argument_Number := 0;
-
- -- If we have a standalone library, gather all the interface ALI.
- -- They are flagged as Interface when we copy them to the library
- -- directory (by Copy_ALI_Files, below).
-
- if Standalone then
- Current_Proj := For_Project;
-
- declare
- Iface : String_List_Id := For_Project.Lib_Interface_ALIs;
- ALI : File_Name_Type;
-
- begin
- while Iface /= Nil_String loop
- ALI :=
- File_Name_Type
- (In_Tree.Shared.String_Elements.Table (Iface).Value);
- Interface_ALIs.Set (ALI, True);
- Get_Name_String
- (In_Tree.Shared.String_Elements.Table (Iface).Value);
- Add_Argument (Name_Buffer (1 .. Name_Len));
- Iface := In_Tree.Shared.String_Elements.Table (Iface).Next;
- end loop;
-
- Iface := For_Project.Lib_Interface_ALIs;
-
- if not Opt.Quiet_Output then
-
- -- Check that the interface set is complete: any unit in the
- -- library that is needed by an interface should also be an
- -- interface. If it is not the case, output a warning.
-
- while Iface /= Nil_String loop
- ALI :=
- File_Name_Type
- (In_Tree.Shared.String_Elements.Table (Iface).Value);
- Process (ALI);
- Iface :=
- In_Tree.Shared.String_Elements.Table (Iface).Next;
- end loop;
- end if;
- end;
- end if;
-
- declare
- Current_Dir : constant String := Get_Current_Dir;
- Dir : Dir_Type;
-
- Name : String (1 .. 200);
- Last : Natural;
-
- Disregard : Boolean;
- pragma Warnings (Off, Disregard);
-
- DLL_Name : aliased constant String :=
- Lib_Filename.all & "." & DLL_Ext;
-
- Archive_Name : aliased constant String :=
- Lib_Filename.all & "." & Archive_Ext;
-
- Delete : Boolean := False;
-
- begin
- -- Clean the library directory: remove any file with the name of
- -- the library file and any ALI file of a source of the project.
-
- begin
- Get_Name_String (For_Project.Library_Dir.Display_Name);
- Change_Dir (Name_Buffer (1 .. Name_Len));
-
- exception
- when others =>
- Com.Fail
- ("unable to access library directory """
- & Name_Buffer (1 .. Name_Len)
- & """");
- end;
-
- Open (Dir, ".");
-
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
-
- declare
- Filename : constant String := Name (1 .. Last);
-
- begin
- if Is_Regular_File (Filename) then
- Canonical_Case_File_Name (Name (1 .. Last));
- Delete := False;
-
- if (The_Build_Mode = Static
- and then Name (1 .. Last) = Archive_Name)
- or else
- ((The_Build_Mode = Dynamic
- or else
- The_Build_Mode = Relocatable)
- and then Name (1 .. Last) = DLL_Name)
- then
- Delete := True;
-
- elsif Last > 4
- and then Name (Last - 3 .. Last) = ".ali"
- then
- declare
- Unit : Unit_Index;
-
- begin
- -- Compare with ALI file names of the project
-
- Unit := Units_Htable.Get_First (In_Tree.Units_HT);
- while Unit /= No_Unit_Index loop
- if Unit.File_Names (Impl) /= null
- and then Unit.File_Names (Impl).Project /=
- No_Project
- then
- if Ultimate_Extending_Project_Of
- (Unit.File_Names (Impl).Project) =
- For_Project
- then
- Get_Name_String
- (Unit.File_Names (Impl).File);
- Name_Len :=
- Name_Len -
- File_Extension
- (Name (1 .. Name_Len))'Length;
-
- if Name_Buffer (1 .. Name_Len) =
- Name (1 .. Last - 4)
- then
- Delete := True;
- exit;
- end if;
- end if;
-
- elsif Unit.File_Names (Spec) /= null
- and then Ultimate_Extending_Project_Of
- (Unit.File_Names (Spec).Project) =
- For_Project
- then
- Get_Name_String (Unit.File_Names (Spec).File);
- Name_Len :=
- Name_Len -
- File_Extension (Name (1 .. Last))'Length;
-
- if Name_Buffer (1 .. Name_Len) =
- Name (1 .. Last - 4)
- then
- Delete := True;
- exit;
- end if;
- end if;
-
- Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
- end loop;
- end;
- end if;
-
- if Delete then
- Set_Writable (Filename);
- Delete_File (Filename, Disregard);
- end if;
- end if;
- end;
- end loop;
-
- Close (Dir);
-
- Change_Dir (Current_Dir);
- end;
-
- -- Call procedure to build the library, depending on the build mode
-
- case The_Build_Mode is
- when Dynamic
- | Relocatable
- =>
- Build_Dynamic_Library
- (Ofiles => Object_Files.all,
- Options => Options.all,
- Interfaces => Arguments (1 .. Argument_Number),
- Lib_Filename => Lib_Filename.all,
- Lib_Dir => Lib_Dirpath.all,
- Symbol_Data => Current_Proj.Symbol_Data,
- Driver_Name => Driver_Name,
- Lib_Version => Lib_Version.all,
- Auto_Init => Current_Proj.Lib_Auto_Init);
-
- when Static =>
- MLib.Build_Library
- (Object_Files.all,
- Lib_Filename.all,
- Lib_Dirpath.all);
-
- when None =>
- null;
- end case;
-
- -- We need to copy the ALI files from the object directory to the
- -- library ALI directory, so that the linker find them there, and
- -- does not need to look in the object directory where it would also
- -- find the object files; and we don't want that: we want the linker
- -- to use the library.
-
- -- Copy the ALI files and make the copies read-only. For interfaces,
- -- mark the copies as interfaces.
-
- Copy_ALI_Files
- (Files => Ali_Files.all,
- To => For_Project.Library_ALI_Dir.Display_Name,
- Interfaces => Arguments (1 .. Argument_Number));
-
- -- Copy interface sources if Library_Src_Dir specified
-
- if Standalone
- and then For_Project.Library_Src_Dir /= No_Path_Information
- then
- -- Clean the interface copy directory: remove any source that
- -- could be a source of the project.
-
- begin
- Get_Name_String (For_Project.Library_Src_Dir.Display_Name);
- Change_Dir (Name_Buffer (1 .. Name_Len));
-
- exception
- when others =>
- Com.Fail
- ("unable to access library source copy directory """
- & Name_Buffer (1 .. Name_Len)
- & """");
- end;
-
- declare
- Dir : Dir_Type;
- Delete : Boolean := False;
- Unit : Unit_Index;
-
- Name : String (1 .. 200);
- Last : Natural;
-
- Disregard : Boolean;
- pragma Warnings (Off, Disregard);
-
- begin
- Open (Dir, ".");
-
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
-
- if Is_Regular_File (Name (1 .. Last)) then
- Canonical_Case_File_Name (Name (1 .. Last));
- Delete := False;
-
- -- Compare with source file names of the project
-
- Unit := Units_Htable.Get_First (In_Tree.Units_HT);
- while Unit /= No_Unit_Index loop
- if Unit.File_Names (Impl) /= null
- and then Ultimate_Extending_Project_Of
- (Unit.File_Names (Impl).Project) = For_Project
- and then
- Get_Name_String
- (Unit.File_Names (Impl).File) =
- Name (1 .. Last)
- then
- Delete := True;
- exit;
- end if;
-
- if Unit.File_Names (Spec) /= null
- and then Ultimate_Extending_Project_Of
- (Unit.File_Names (Spec).Project) =
- For_Project
- and then
- Get_Name_String
- (Unit.File_Names (Spec).File) =
- Name (1 .. Last)
- then
- Delete := True;
- exit;
- end if;
-
- Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
- end loop;
- end if;
-
- if Delete then
- Set_Writable (Name (1 .. Last));
- Delete_File (Name (1 .. Last), Disregard);
- end if;
- end loop;
-
- Close (Dir);
- end;
-
- Copy_Interface_Sources
- (For_Project => For_Project,
- In_Tree => In_Tree,
- Interfaces => Arguments (1 .. Argument_Number),
- To_Dir => For_Project.Library_Src_Dir.Display_Name);
- end if;
- end if;
-
- -- Reset the current working directory to its previous value
-
- Change_Dir (Current_Dir);
- end Build_Library;
-
- -----------
- -- Check --
- -----------
-
- procedure Check (Filename : String) is
- begin
- if not Is_Regular_File (Filename) then
- Com.Fail (Filename & " not found.");
- end if;
- end Check;
-
- -------------------
- -- Check_Context --
- -------------------
-
- procedure Check_Context is
- begin
- -- Check that each object file exists
-
- for F in Object_Files'Range loop
- Check (Object_Files (F).all);
- end loop;
- end Check_Context;
-
- -------------------
- -- Check_Library --
- -------------------
-
- procedure Check_Library
- (For_Project : Project_Id; In_Tree : Project_Tree_Ref)
- is
- Lib_TS : Time_Stamp_Type;
- Current : constant Dir_Name_Str := Get_Current_Dir;
-
- begin
- -- No need to build the library if there is no object directory,
- -- hence no object files to build the library.
-
- if For_Project.Library then
- declare
- Lib_Name : constant File_Name_Type :=
- Library_File_Name_For (For_Project, In_Tree);
- begin
- Change_Dir
- (Get_Name_String (For_Project.Library_Dir.Display_Name));
- Lib_TS := File_Stamp (Lib_Name);
- For_Project.Library_TS := Lib_TS;
- end;
-
- if not For_Project.Externally_Built
- and then not For_Project.Need_To_Build_Lib
- and then For_Project.Object_Directory /= No_Path_Information
- then
- declare
- Obj_TS : Time_Stamp_Type;
- Object_Dir : Dir_Type;
-
- begin
- -- If the library file does not exist, then the time stamp will
- -- be Empty_Time_Stamp, earlier than any other time stamp.
-
- Change_Dir
- (Get_Name_String (For_Project.Object_Directory.Display_Name));
- Open (Dir => Object_Dir, Dir_Name => ".");
-
- -- For all entries in the object directory
-
- loop
- Read (Object_Dir, Name_Buffer, Name_Len);
- exit when Name_Len = 0;
-
- -- Check if it is an object file, but ignore any binder
- -- generated file.
-
- if Is_Obj (Name_Buffer (1 .. Name_Len))
- and then Name_Buffer (1 .. B_Start'Length) /= B_Start
- then
- -- Get the object file time stamp
-
- Obj_TS := File_Stamp (File_Name_Type'(Name_Find));
-
- -- If library file time stamp is earlier, set
- -- Need_To_Build_Lib and return. String comparison is
- -- used, otherwise time stamps may be too close and the
- -- comparison would return True, which would trigger
- -- an unnecessary rebuild of the library.
-
- if String (Lib_TS) < String (Obj_TS) then
-
- -- Library must be rebuilt
-
- For_Project.Need_To_Build_Lib := True;
- exit;
- end if;
- end if;
- end loop;
-
- Close (Object_Dir);
- end;
- end if;
-
- Change_Dir (Current);
- end if;
- end Check_Library;
-
- ----------------------------
- -- Copy_Interface_Sources --
- ----------------------------
-
- procedure Copy_Interface_Sources
- (For_Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Interfaces : Argument_List;
- To_Dir : Path_Name_Type)
- is
- Current : constant Dir_Name_Str := Get_Current_Dir;
- -- The current directory, where to return to at the end
-
- Target : constant Dir_Name_Str := Get_Name_String (To_Dir);
- -- The directory where to copy sources
-
- Text : Text_Buffer_Ptr;
- The_ALI : ALI.ALI_Id;
- Lib_File : File_Name_Type;
-
- First_Unit : ALI.Unit_Id;
- Second_Unit : ALI.Unit_Id;
-
- Copy_Subunits : Boolean := False;
- -- When True, indicates that subunits, if any, need to be copied too
-
- procedure Copy (File_Name : File_Name_Type);
- -- Copy one source of the project to the target directory
-
- ----------
- -- Copy --
- ----------
-
- procedure Copy (File_Name : File_Name_Type) is
- Success : Boolean;
- pragma Warnings (Off, Success);
-
- Source : Standard.Prj.Source_Id;
- begin
- Source := Find_Source
- (In_Tree, For_Project,
- In_Extended_Only => True,
- Base_Name => File_Name);
-
- if Source /= No_Source
- and then not Source.Locally_Removed
- and then Source.Replaced_By = No_Source
- then
- Copy_File
- (Get_Name_String (Source.Path.Name),
- Target,
- Success,
- Mode => Overwrite,
- Preserve => Preserve);
- end if;
- end Copy;
-
- -- Start of processing for Copy_Interface_Sources
-
- begin
- -- Change the working directory to the object directory
-
- Change_Dir (Get_Name_String (For_Project.Object_Directory.Display_Name));
-
- for Index in Interfaces'Range loop
-
- -- First, load the ALI file
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Interfaces (Index).all);
- Lib_File := Name_Find;
- Text := Read_Library_Info (Lib_File);
- The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True);
- Free (Text);
-
- Second_Unit := No_Unit_Id;
- First_Unit := ALI.ALIs.Table (The_ALI).First_Unit;
- Copy_Subunits := True;
-
- -- If there is both a spec and a body, check if they are both needed
-
- if ALI.Units.Table (First_Unit).Utype = Is_Body then
- Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit;
-
- -- If the body is not needed, then reset First_Unit
-
- if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then
- First_Unit := No_Unit_Id;
- Copy_Subunits := False;
- end if;
-
- elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then
- Copy_Subunits := False;
- end if;
-
- -- Copy the file(s) that need to be copied
-
- if First_Unit /= No_Unit_Id then
- Copy (File_Name => ALI.Units.Table (First_Unit).Sfile);
- end if;
-
- if Second_Unit /= No_Unit_Id then
- Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile);
- end if;
-
- -- Copy all the separates, if any
-
- if Copy_Subunits then
- for Dep in ALI.ALIs.Table (The_ALI).First_Sdep ..
- ALI.ALIs.Table (The_ALI).Last_Sdep
- loop
- if Sdep.Table (Dep).Subunit_Name /= No_Name then
- Copy (File_Name => Sdep.Table (Dep).Sfile);
- end if;
- end loop;
- end if;
- end loop;
-
- -- Restore the initial working directory
-
- Change_Dir (Current);
- end Copy_Interface_Sources;
-
- -------------
- -- Display --
- -------------
-
- procedure Display (Executable : String) is
- begin
- if not Opt.Quiet_Output then
- Write_Str (Executable);
-
- for Index in 1 .. Argument_Number loop
- Write_Char (' ');
- Write_Str (Arguments (Index).all);
-
- if not Opt.Verbose_Mode and then Index > 4 then
- Write_Str (" ...");
- exit;
- end if;
- end loop;
-
- Write_Eol;
- end if;
- end Display;
-
- -----------
- -- Index --
- -----------
-
- function Index (S, Pattern : String) return Natural is
- Len : constant Natural := Pattern'Length;
-
- begin
- for J in reverse S'First .. S'Last - Len + 1 loop
- if Pattern = S (J .. J + Len - 1) then
- return J;
- end if;
- end loop;
-
- return 0;
- end Index;
-
- -------------------------
- -- Process_Binder_File --
- -------------------------
-
- procedure Process_Binder_File (Name : String) is
- Fd : FILEs;
- -- Binder file's descriptor
-
- Read_Mode : constant String := "r" & ASCII.NUL;
- -- For fopen
-
- Status : Interfaces.C_Streams.int;
- pragma Unreferenced (Status);
- -- For fclose
-
- Begin_Info : constant String := "-- BEGIN Object file/option list";
- End_Info : constant String := "-- END Object file/option list ";
-
- Next_Line : String (1 .. 1000);
- -- Current line value
- -- Where does this odd constant 1000 come from, looks suspicious ???
-
- Nlast : Integer;
- -- End of line slice (the slice does not contain the line terminator)
-
- procedure Get_Next_Line;
- -- Read the next line from the binder file without the line terminator
-
- -------------------
- -- Get_Next_Line --
- -------------------
-
- procedure Get_Next_Line is
- Fchars : chars;
-
- begin
- Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd);
-
- if Fchars = System.Null_Address then
- Fail ("Error reading binder output");
- end if;
-
- Nlast := 1;
- while Nlast <= Next_Line'Last
- and then Next_Line (Nlast) /= ASCII.LF
- and then Next_Line (Nlast) /= ASCII.CR
- loop
- Nlast := Nlast + 1;
- end loop;
-
- Nlast := Nlast - 1;
- end Get_Next_Line;
-
- -- Start of processing for Process_Binder_File
-
- begin
- Fd := fopen (Name'Address, Read_Mode'Address);
-
- if Fd = NULL_Stream then
- Fail ("Failed to open binder output");
- end if;
-
- -- Skip up to the Begin Info line
-
- loop
- Get_Next_Line;
- exit when Next_Line (1 .. Nlast) = Begin_Info;
- end loop;
-
- -- Find the first switch
-
- loop
- Get_Next_Line;
-
- exit when Next_Line (1 .. Nlast) = End_Info;
-
- -- As the binder generated file is in Ada, remove the first eight
- -- characters " -- ".
-
- Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
- Nlast := Nlast - 8;
-
- -- Stop when the first switch is found
-
- exit when Next_Line (1) = '-';
- end loop;
-
- if Next_Line (1 .. Nlast) /= End_Info then
- loop
- -- Ignore -static and -shared, since -shared will be used
- -- in any case.
-
- -- Ignore -lgnat and -lgnarl as they will be added later,
- -- because they are also needed for non Stand-Alone shared
- -- libraries.
-
- -- Also ignore the shared libraries which are:
-
- -- -lgnat-<version> (7 + version'length chars)
- -- -lgnarl-<version> (8 + version'length chars)
-
- if Next_Line (1 .. Nlast) /= "-static" and then
- Next_Line (1 .. Nlast) /= "-shared" and then
- Next_Line (1 .. Nlast) /= "-lgnarl" and then
- Next_Line (1 .. Nlast) /= "-lgnat"
- and then
- Next_Line
- (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /=
- Shared_Lib ("gnarl")
- and then
- Next_Line
- (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /=
- Shared_Lib ("gnat")
- then
- if Next_Line (1) /= '-' then
-
- -- This is not an option, should we add it?
-
- if Add_Object_Files then
- Opts.Increment_Last;
- Opts.Table (Opts.Last) :=
- new String'(Next_Line (1 .. Nlast));
- end if;
-
- else
- -- Add all other options
-
- Opts.Increment_Last;
- Opts.Table (Opts.Last) :=
- new String'(Next_Line (1 .. Nlast));
- end if;
- end if;
-
- -- Next option, if any
-
- Get_Next_Line;
- exit when Next_Line (1 .. Nlast) = End_Info;
-
- -- Remove first eight characters " -- "
-
- Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast);
- Nlast := Nlast - 8;
- end loop;
- end if;
-
- Status := fclose (Fd);
-
- -- Is it really right to ignore any close error ???
-
- end Process_Binder_File;
-
- ------------------
- -- Reset_Tables --
- ------------------
-
- procedure Reset_Tables is
- begin
- Objects.Init;
- Objects_Htable.Reset;
- ALIs.Init;
- Opts.Init;
- Processed_Projects.Reset;
- Library_Projs.Init;
- end Reset_Tables;
-
- ---------------------------
- -- SALs_Use_Constructors --
- ---------------------------
-
- function SALs_Use_Constructors return Boolean is
- function C_SALs_Init_Using_Constructors return Integer;
- pragma Import (C, C_SALs_Init_Using_Constructors,
- "__gnat_sals_init_using_constructors");
- begin
- return C_SALs_Init_Using_Constructors /= 0;
- end SALs_Use_Constructors;
-
-end MLib.Prj;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . P R J --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2007, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package builds a library for a library project file
-
-with Prj; use Prj;
-
-package MLib.Prj is
-
- procedure Build_Library
- (For_Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Gnatbind : String;
- Gnatbind_Path : String_Access;
- Gcc : String;
- Gcc_Path : String_Access;
- Bind : Boolean := True;
- Link : Boolean := True);
- -- Build the library of library project For_Project.
- -- Fails if For_Project is not a library project file.
- -- Gnatbind, Gnatbind_Path, Gcc, Gcc_Path are used for standalone
- -- libraries, to call the binder and to compile the binder generated
- -- files. If Bind is False the binding of a stand-alone library is skipped.
- -- If Link is False, the library is not linked/built.
-
- procedure Check_Library
- (For_Project : Project_Id;
- In_Tree : Project_Tree_Ref);
- -- Check if the library of a library project needs to be rebuilt,
- -- because its time-stamp is earlier than the time stamp of one of its
- -- object files.
-
-end MLib.Prj;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (AIX Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2008, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the AIX version of the body
-
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-
-with MLib.Fil;
-with MLib.Utl;
-with Opt;
-with Output; use Output;
-with Prj.Com;
-with Prj.Util; use Prj.Util;
-
-package body MLib.Tgt.Specific is
-
- -- Local subprograms
- -- These *ALL* require comments ???
-
- function Archive_Indexer return String;
- -- What is this???
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function DLL_Ext return String;
-
- function Library_Major_Minor_Id_Supported return Boolean;
-
- function Support_For_Libraries return Library_Support;
-
- -- Local variables
-
- No_Arguments : aliased Argument_List := (1 .. 0 => null);
- Empty_Argument_List : constant Argument_List_Access := No_Arguments'Access;
-
- Bexpall : aliased String := "-Wl,-bexpall";
- Bexpall_Option : constant String_Access := Bexpall'Access;
- -- The switch to export all symbols
-
- Lpthreads : aliased String := "-lpthreads";
- Native_Thread_Options : aliased Argument_List := (1 => Lpthreads'Access);
- -- The switch to use when linking a library against libgnarl when using
- -- Native threads.
-
- Lgthreads : aliased String := "-lgthreads";
- Lmalloc : aliased String := "-lmalloc";
- FSU_Thread_Options : aliased Argument_List :=
- (1 => Lgthreads'Access, 2 => Lmalloc'Access);
- -- The switches to use when linking a library against libgnarl when using
- -- FSU threads.
-
- Thread_Options : Argument_List_Access := Empty_Argument_List;
- -- Designate the thread switches to used when linking a library against
- -- libgnarl. Depends on the thread library (Native or FSU). Resolved for
- -- the first library linked against libgnarl.
-
- ---------------------
- -- Archive_Indexer --
- ---------------------
-
- function Archive_Indexer return String is
- begin
- return "";
- end Archive_Indexer;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Lib_Version);
- pragma Unreferenced (Auto_Init);
-
- Lib_File : constant String :=
- Lib_Dir & Directory_Separator & "lib" &
- MLib.Fil.Append_To (Lib_Filename, DLL_Ext);
- -- The file name of the library
-
- Thread_Opts : Argument_List_Access := Empty_Argument_List;
- -- Set to Thread_Options if -lgnarl is found in the Options
-
- begin
- if Opt.Verbose_Mode then
- Write_Str ("building relocatable shared library ");
- Write_Line (Lib_File);
- end if;
-
- -- Look for -lgnarl in Options. If found, set the thread options
-
- for J in Options'Range loop
- if Options (J).all = "-lgnarl" then
-
- -- If Thread_Options is null, read s-osinte.ads to discover the
- -- thread library and set Thread_Options accordingly.
-
- if Thread_Options = null then
- declare
- File : Text_File;
- Line : String (1 .. 100);
- Last : Natural;
-
- begin
- Open
- (File, Include_Dir_Default_Prefix & "/s-osinte.ads");
-
- while not End_Of_File (File) loop
- Get_Line (File, Line, Last);
-
- if Index (Line (1 .. Last), "-lpthreads") /= 0 then
- Thread_Options := Native_Thread_Options'Access;
- exit;
-
- elsif Index (Line (1 .. Last), "-lgthreads") /= 0 then
- Thread_Options := FSU_Thread_Options'Access;
- exit;
- end if;
- end loop;
-
- Close (File);
-
- if Thread_Options = null then
- Prj.Com.Fail ("cannot find the thread library in use");
- end if;
-
- exception
- when others =>
- Prj.Com.Fail ("cannot open s-osinte.ads");
- end;
- end if;
-
- Thread_Opts := Thread_Options;
- exit;
- end if;
- end loop;
-
- -- Finally, call GCC (or the driver specified) to build the library
-
- MLib.Utl.Gcc
- (Output_File => Lib_File,
- Objects => Ofiles,
- Options => Options & Bexpall_Option,
- Driver_Name => Driver_Name,
- Options_2 => Thread_Opts.all);
- end Build_Dynamic_Library;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "a";
- end DLL_Ext;
-
- --------------------------------------
- -- Library_Major_Minor_Id_Supported --
- --------------------------------------
-
- function Library_Major_Minor_Id_Supported return Boolean is
- begin
- return False;
- end Library_Major_Minor_Id_Supported;
-
- ---------------------------
- -- Support_For_Libraries --
- ---------------------------
-
- function Support_For_Libraries return Library_Support is
- begin
- return Static_Only;
- end Support_For_Libraries;
-
-begin
- Archive_Indexer_Ptr := Archive_Indexer'Access;
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- DLL_Ext_Ptr := DLL_Ext'Access;
- Library_Major_Minor_Id_Supported_Ptr :=
- Library_Major_Minor_Id_Supported'Access;
- Support_For_Libraries_Ptr := Support_For_Libraries'Access;
-
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (Darwin Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Darwin version of the body
-
-with MLib; use MLib;
-with MLib.Fil;
-with MLib.Utl;
-with Opt; use Opt;
-with Output; use Output;
-
-package body MLib.Tgt.Specific is
-
- -- Non default subprograms
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function DLL_Ext return String;
-
- function Dynamic_Option return String;
-
- function Is_Archive_Ext (Ext : String) return Boolean;
-
- -- Local objects
-
- Shared_Libgcc : aliased String := "-shared-libgcc";
-
- Shared_Options : constant Argument_List :=
- (1 => Shared_Libgcc'Access);
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Auto_Init);
-
- Lib_File : constant String :=
- "lib" & Fil.Append_To (Lib_Filename, DLL_Ext);
-
- Lib_Path : constant String :=
- Lib_Dir & Directory_Separator & Lib_File;
-
- Symbolic_Link_Needed : Boolean := False;
-
- begin
- if Opt.Verbose_Mode then
- Write_Str ("building relocatable shared library ");
- Write_Line (Lib_File);
- end if;
-
- -- If specified, add automatic elaboration/finalization
-
- if Lib_Version = "" then
- Utl.Gcc
- (Output_File => Lib_Path,
- Objects => Ofiles,
- Options => Options & Shared_Options,
- Driver_Name => Driver_Name,
- Options_2 => No_Argument_List);
-
- else
- declare
- Maj_Version : constant String :=
- Major_Id_Name (Lib_File, Lib_Version);
- begin
- if Is_Absolute_Path (Lib_Version) then
- Utl.Gcc
- (Output_File => Lib_Version,
- Objects => Ofiles,
- Options => Options & Shared_Options,
- Driver_Name => Driver_Name,
- Options_2 => No_Argument_List);
- Symbolic_Link_Needed := Lib_Version /= Lib_Path;
-
- else
- Utl.Gcc
- (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
- Objects => Ofiles,
- Options => Options & Shared_Options,
- Driver_Name => Driver_Name,
- Options_2 => No_Argument_List);
- Symbolic_Link_Needed :=
- Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path;
- end if;
-
- if Symbolic_Link_Needed then
- Create_Sym_Links
- (Lib_Path, Lib_Version, Lib_Dir, Maj_Version);
- end if;
- end;
- end if;
- end Build_Dynamic_Library;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "dylib";
- end DLL_Ext;
-
- --------------------
- -- Dynamic_Option --
- --------------------
-
- function Dynamic_Option return String is
- begin
- return "-dynamiclib";
- end Dynamic_Option;
-
- --------------------
- -- Is_Archive_Ext --
- --------------------
-
- function Is_Archive_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".dylib" or else Ext = ".a";
- end Is_Archive_Ext;
-
-begin
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- DLL_Ext_Ptr := DLL_Ext'Access;
- Dynamic_Option_Ptr := Dynamic_Option'Access;
- Is_Archive_Ext_Ptr := Is_Archive_Ext'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (HP-UX Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2014, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the HP-UX version of the body
-
-with MLib.Fil;
-with MLib.Utl;
-with Opt;
-with Output; use Output;
-
-package body MLib.Tgt.Specific is
-
- -- Non default subprograms
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function DLL_Ext return String;
-
- function Is_Archive_Ext (Ext : String) return Boolean;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Auto_Init);
-
- Lib_File : constant String :=
- "lib" & Fil.Append_To (Lib_Filename, DLL_Ext);
-
- Lib_Path : constant String :=
- Lib_Dir & Directory_Separator & Lib_File;
-
- Version_Arg : String_Access;
- Symbolic_Link_Needed : Boolean := False;
-
- Common_Options : constant Argument_List :=
- Options & new String'(PIC_Option);
- -- Common set of options to the gcc command performing the link. On
- -- HPUX, this command eventually resorts to collect2, which may generate
- -- a C file and compile it on the fly. This compilation also generates
- -- position independent code for the final link to succeed.
- begin
- if Opt.Verbose_Mode then
- Write_Str ("building relocatable shared library ");
- Write_Line (Lib_Path);
- end if;
-
- if Lib_Version = "" then
- MLib.Utl.Gcc
- (Output_File => Lib_Path,
- Objects => Ofiles,
- Options => Common_Options,
- Options_2 => No_Argument_List,
- Driver_Name => Driver_Name);
-
- else
- declare
- Maj_Version : constant String :=
- Major_Id_Name (Lib_File, Lib_Version);
- begin
- if Maj_Version'Length /= 0 then
- Version_Arg := new String'("-Wl,+h," & Maj_Version);
-
- else
- Version_Arg := new String'("-Wl,+h," & Lib_Version);
- end if;
-
- if Is_Absolute_Path (Lib_Version) then
- MLib.Utl.Gcc
- (Output_File => Lib_Version,
- Objects => Ofiles,
- Options => Common_Options & Version_Arg,
- Options_2 => No_Argument_List,
- Driver_Name => Driver_Name);
- Symbolic_Link_Needed := Lib_Version /= Lib_Path;
-
- else
- MLib.Utl.Gcc
- (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
- Objects => Ofiles,
- Options => Common_Options & Version_Arg,
- Options_2 => No_Argument_List,
- Driver_Name => Driver_Name);
- Symbolic_Link_Needed :=
- Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path;
- end if;
-
- if Symbolic_Link_Needed then
- Create_Sym_Links
- (Lib_Path, Lib_Version, Lib_Dir, Maj_Version);
- end if;
- end;
- end if;
- end Build_Dynamic_Library;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "sl";
- end DLL_Ext;
-
- --------------------
- -- Is_Archive_Ext --
- --------------------
-
- function Is_Archive_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".a" or else Ext = ".so";
- end Is_Archive_Ext;
-
-begin
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- DLL_Ext_Ptr := DLL_Ext'Access;
- Is_Archive_Ext_Ptr := Is_Archive_Ext'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (GNU/Linux Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2008, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the GNU/Linux version of the body
-
-with MLib.Fil;
-with MLib.Utl;
-with Opt;
-with Output; use Output;
-
-package body MLib.Tgt.Specific is
-
- use MLib;
-
- -- Non default subprograms
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function Is_Archive_Ext (Ext : String) return Boolean;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Auto_Init);
- -- Initialization is done through the constructor mechanism
-
- Lib_File : constant String :=
- "lib" & Fil.Append_To (Lib_Filename, DLL_Ext);
-
- Lib_Path : constant String :=
- Lib_Dir & Directory_Separator & Lib_File;
-
- Version_Arg : String_Access;
- Symbolic_Link_Needed : Boolean := False;
-
- begin
- if Opt.Verbose_Mode then
- Write_Str ("building relocatable shared library ");
- Write_Line (Lib_Path);
- end if;
-
- if Lib_Version = "" then
- Utl.Gcc
- (Output_File => Lib_Path,
- Objects => Ofiles,
- Options => Options,
- Driver_Name => Driver_Name,
- Options_2 => No_Argument_List);
-
- else
- declare
- Maj_Version : constant String :=
- Major_Id_Name (Lib_File, Lib_Version);
- begin
- if Maj_Version'Length /= 0 then
- Version_Arg := new String'("-Wl,-soname," & Maj_Version);
-
- else
- Version_Arg := new String'("-Wl,-soname," & Lib_Version);
- end if;
-
- if Is_Absolute_Path (Lib_Version) then
- Utl.Gcc
- (Output_File => Lib_Version,
- Objects => Ofiles,
- Options => Options & Version_Arg,
- Driver_Name => Driver_Name,
- Options_2 => No_Argument_List);
- Symbolic_Link_Needed := Lib_Version /= Lib_Path;
-
- else
- Utl.Gcc
- (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
- Objects => Ofiles,
- Options => Options & Version_Arg,
- Driver_Name => Driver_Name,
- Options_2 => No_Argument_List);
- Symbolic_Link_Needed :=
- Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path;
- end if;
-
- if Symbolic_Link_Needed then
- Create_Sym_Links
- (Lib_Path, Lib_Version, Lib_Dir, Maj_Version);
- end if;
- end;
- end if;
- end Build_Dynamic_Library;
-
- --------------------
- -- Is_Archive_Ext --
- --------------------
-
- function Is_Archive_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".a" or else Ext = ".so";
- end Is_Archive_Ext;
-
-begin
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- Is_Archive_Ext_Ptr := Is_Archive_Ext'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (Windows Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Windows version of the body. Works only with GCC versions
--- supporting the "-shared" option.
-
-with Opt;
-with Output; use Output;
-
-with MLib.Fil;
-with MLib.Utl;
-
-package body MLib.Tgt.Specific is
-
- package Files renames MLib.Fil;
- package Tools renames MLib.Utl;
-
- -- Non default subprograms
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function DLL_Ext return String;
-
- function DLL_Prefix return String;
-
- function Is_Archive_Ext (Ext : String) return Boolean;
-
- function Library_Major_Minor_Id_Supported return Boolean;
-
- function PIC_Option return String;
-
- Shared_Libgcc : aliased String := "-shared-libgcc";
-
- Shared_Libgcc_Switch : constant Argument_List :=
- (1 => Shared_Libgcc'Access);
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Lib_Version);
- pragma Unreferenced (Auto_Init);
-
- Lib_File : constant String :=
- Lib_Dir & Directory_Separator &
- DLL_Prefix & Files.Append_To (Lib_Filename, DLL_Ext);
-
- -- Start of processing for Build_Dynamic_Library
-
- begin
- if Opt.Verbose_Mode then
- Write_Str ("building relocatable shared library ");
- Write_Line (Lib_File);
- end if;
-
- Tools.Gcc
- (Output_File => Lib_File,
- Objects => Ofiles,
- Options => Shared_Libgcc_Switch,
- Options_2 => Options,
- Driver_Name => Driver_Name);
- end Build_Dynamic_Library;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "dll";
- end DLL_Ext;
-
- ----------------
- -- DLL_Prefix --
- ----------------
-
- function DLL_Prefix return String is
- begin
- return "lib";
- end DLL_Prefix;
-
- --------------------
- -- Is_Archive_Ext --
- --------------------
-
- function Is_Archive_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".a" or else Ext = ".dll";
- end Is_Archive_Ext;
-
- --------------------------------------
- -- Library_Major_Minor_Id_Supported --
- --------------------------------------
-
- function Library_Major_Minor_Id_Supported return Boolean is
- begin
- return False;
- end Library_Major_Minor_Id_Supported;
-
- ----------------
- -- PIC_Option --
- ----------------
-
- function PIC_Option return String is
- begin
- return "";
- end PIC_Option;
-
-begin
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- DLL_Ext_Ptr := DLL_Ext'Access;
- DLL_Prefix_Ptr := DLL_Prefix'Access;
- Is_Archive_Ext_Ptr := Is_Archive_Ext'Access;
- PIC_Option_Ptr := PIC_Option'Access;
- Library_Major_Minor_Id_Supported_Ptr :=
- Library_Major_Minor_Id_Supported'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (Solaris Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-2008, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the Solaris version of the body
-
-with MLib.Fil;
-with MLib.Utl;
-with Opt;
-with Output; use Output;
-
-package body MLib.Tgt.Specific is
-
- -- Non default subprograms
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function Is_Archive_Ext (Ext : String) return Boolean;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Auto_Init);
-
- Lib_File : constant String :=
- "lib" & Fil.Append_To (Lib_Filename, DLL_Ext);
-
- Lib_Path : constant String :=
- Lib_Dir & Directory_Separator & Lib_File;
-
- Version_Arg : String_Access;
- Symbolic_Link_Needed : Boolean := False;
-
- begin
- if Opt.Verbose_Mode then
- Write_Str ("building relocatable shared library ");
- Write_Line (Lib_Path);
- end if;
-
- if Lib_Version = "" then
- Utl.Gcc
- (Output_File => Lib_Path,
- Objects => Ofiles,
- Options => Options,
- Options_2 => No_Argument_List,
- Driver_Name => Driver_Name);
-
- else
- declare
- Maj_Version : constant String :=
- Major_Id_Name (Lib_File, Lib_Version);
- begin
- if Maj_Version'Length /= 0 then
- Version_Arg := new String'("-Wl,-h," & Maj_Version);
-
- else
- Version_Arg := new String'("-Wl,-h," & Lib_Version);
- end if;
-
- if Is_Absolute_Path (Lib_Version) then
- Utl.Gcc
- (Output_File => Lib_Version,
- Objects => Ofiles,
- Options => Options & Version_Arg,
- Options_2 => No_Argument_List,
- Driver_Name => Driver_Name);
- Symbolic_Link_Needed := Lib_Version /= Lib_Path;
-
- else
- Utl.Gcc
- (Output_File => Lib_Dir & Directory_Separator & Lib_Version,
- Objects => Ofiles,
- Options => Options & Version_Arg,
- Options_2 => No_Argument_List,
- Driver_Name => Driver_Name);
- Symbolic_Link_Needed :=
- Lib_Dir & Directory_Separator & Lib_Version /= Lib_Path;
- end if;
-
- if Symbolic_Link_Needed then
- Create_Sym_Links
- (Lib_Path, Lib_Version, Lib_Dir, Maj_Version);
- end if;
- end;
- end if;
- end Build_Dynamic_Library;
-
- --------------------
- -- Is_Archive_Ext --
- --------------------
-
- function Is_Archive_Ext (Ext : String) return Boolean is
- begin
- return Ext = ".a" or else Ext = ".so";
- end Is_Archive_Ext;
-
-begin
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- Is_Archive_Ext_Ptr := Is_Archive_Ext'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (VxWorks Version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2013, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the VxWorks version of the body
-
-with Sdefault;
-
-package body MLib.Tgt.Specific is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Get_Target_Suffix return String;
- -- Returns the required suffix for some utilities
- -- (such as ar and ranlib) that depend on the real target.
-
- -- Non default subprograms
-
- function Archive_Builder return String;
-
- function Archive_Indexer return String;
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function DLL_Ext return String;
-
- function Dynamic_Option return String;
-
- function Library_Major_Minor_Id_Supported return Boolean;
-
- function PIC_Option return String;
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean;
-
- function Support_For_Libraries return Library_Support;
-
- ---------------------
- -- Archive_Builder --
- ---------------------
-
- function Archive_Builder return String is
- begin
- return "ar" & Get_Target_Suffix;
- end Archive_Builder;
-
- ---------------------
- -- Archive_Indexer --
- ---------------------
-
- function Archive_Indexer return String is
- begin
- return "ranlib" & Get_Target_Suffix;
- end Archive_Indexer;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Ofiles);
- pragma Unreferenced (Options);
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Lib_Filename);
- pragma Unreferenced (Lib_Dir);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Driver_Name);
- pragma Unreferenced (Lib_Version);
- pragma Unreferenced (Auto_Init);
-
- begin
- null;
- end Build_Dynamic_Library;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "";
- end DLL_Ext;
-
- --------------------
- -- Dynamic_Option --
- --------------------
-
- function Dynamic_Option return String is
- begin
- return "";
- end Dynamic_Option;
-
- -----------------------
- -- Get_Target_Suffix --
- -----------------------
-
- function Get_Target_Suffix return String is
- Target_Name : constant String := Sdefault.Target_Name.all;
- Index : Positive := Target_Name'First;
-
- begin
- while Index < Target_Name'Last
- and then Target_Name (Index + 1) /= '-'
- loop
- Index := Index + 1;
- end loop;
-
- if Target_Name (Target_Name'First .. Index) = "m68k" then
- return "68k";
- elsif Target_Name (Target_Name'First .. Index) = "mips" then
- return "mips";
- elsif Target_Name (Target_Name'First .. Index) = "powerpc" then
- return "ppc";
- elsif Target_Name (Target_Name'First .. Index) = "sparc" then
- return "sparc";
- elsif Target_Name (Target_Name'First .. Index) = "sparc64" then
- return "sparc64";
- elsif Target_Name (Target_Name'First .. Index) = "arm" then
- return "arm";
- elsif Target_Name (Target_Name'First .. Index) = "i586" then
- return "pentium";
- else
- return "";
- end if;
- end Get_Target_Suffix;
-
- --------------------------------------
- -- Library_Major_Minor_Id_Supported --
- --------------------------------------
-
- function Library_Major_Minor_Id_Supported return Boolean is
- begin
- return False;
- end Library_Major_Minor_Id_Supported;
-
- ----------------
- -- PIC_Option --
- ----------------
-
- function PIC_Option return String is
- begin
- return "";
- end PIC_Option;
-
- -----------------------------------------------
- -- Standalone_Library_Auto_Init_Is_Supported --
- -----------------------------------------------
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean is
- begin
- return False;
- end Standalone_Library_Auto_Init_Is_Supported;
-
- ---------------------------
- -- Support_For_Libraries --
- ---------------------------
-
- function Support_For_Libraries return Library_Support is
- begin
- return Static_Only;
- end Support_For_Libraries;
-
-begin
- Archive_Builder_Ptr := Archive_Builder'Access;
- Archive_Indexer_Ptr := Archive_Indexer'Access;
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- DLL_Ext_Ptr := DLL_Ext'Access;
- Dynamic_Option_Ptr := Dynamic_Option'Access;
- PIC_Option_Ptr := PIC_Option'Access;
- Library_Major_Minor_Id_Supported_Ptr :=
- Library_Major_Minor_Id_Supported'Access;
- Standalone_Library_Auto_Init_Is_Supported_Ptr :=
- Standalone_Library_Auto_Init_Is_Supported'Access;
- Support_For_Libraries_Ptr := Support_For_Libraries'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T. S P E C I F I C --
--- --
--- B o d y --
--- --
--- Copyright (C) 2003-2011, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This is the bare board version of the body
-
-with Sdefault;
-with Types; use Types;
-
-package body MLib.Tgt.Specific is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- function Get_Target_Prefix return String;
- -- Returns the required prefix for some utilities
- -- (such as ar and ranlib) that depend on the real target.
-
- -- Non default subprograms
-
- function Archive_Builder return String;
-
- function Archive_Indexer return String;
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- function DLL_Ext return String;
-
- function Dynamic_Option return String;
-
- function Library_Major_Minor_Id_Supported return Boolean;
-
- function PIC_Option return String;
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean;
-
- function Support_For_Libraries return Library_Support;
-
- ---------------------
- -- Archive_Builder --
- ---------------------
-
- function Archive_Builder return String is
- begin
- return Get_Target_Prefix & "ar";
- end Archive_Builder;
-
- ---------------------
- -- Archive_Indexer --
- ---------------------
-
- function Archive_Indexer return String is
- begin
- return Get_Target_Prefix & "ranlib";
- end Archive_Indexer;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- pragma Unreferenced (Ofiles);
- pragma Unreferenced (Options);
- pragma Unreferenced (Interfaces);
- pragma Unreferenced (Lib_Filename);
- pragma Unreferenced (Lib_Dir);
- pragma Unreferenced (Symbol_Data);
- pragma Unreferenced (Driver_Name);
- pragma Unreferenced (Lib_Version);
- pragma Unreferenced (Auto_Init);
-
- begin
- null;
- end Build_Dynamic_Library;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return "";
- end DLL_Ext;
-
- --------------------
- -- Dynamic_Option --
- --------------------
-
- function Dynamic_Option return String is
- begin
- return "";
- end Dynamic_Option;
-
- -----------------------
- -- Get_Target_Prefix --
- -----------------------
-
- function Get_Target_Prefix return String is
- Target_Name : constant String_Ptr := Sdefault.Target_Name;
-
- begin
- -- Target_name is the program prefix without '-' but with a trailing '/'
-
- return Target_Name (Target_Name'First .. Target_Name'Last - 1) & '-';
- end Get_Target_Prefix;
-
- --------------------------------------
- -- Library_Major_Minor_Id_Supported --
- --------------------------------------
-
- function Library_Major_Minor_Id_Supported return Boolean is
- begin
- return False;
- end Library_Major_Minor_Id_Supported;
-
- ----------------
- -- PIC_Option --
- ----------------
-
- function PIC_Option return String is
- begin
- return "";
- end PIC_Option;
-
- -----------------------------------------------
- -- Standalone_Library_Auto_Init_Is_Supported --
- -----------------------------------------------
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean is
- begin
- return False;
- end Standalone_Library_Auto_Init_Is_Supported;
-
- ---------------------------
- -- Support_For_Libraries --
- ---------------------------
-
- function Support_For_Libraries return Library_Support is
- begin
- return Static_Only;
- end Support_For_Libraries;
-
-begin
- Archive_Builder_Ptr := Archive_Builder'Access;
- Archive_Indexer_Ptr := Archive_Indexer'Access;
- Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access;
- DLL_Ext_Ptr := DLL_Ext'Access;
- Dynamic_Option_Ptr := Dynamic_Option'Access;
- Library_Major_Minor_Id_Supported_Ptr :=
- Library_Major_Minor_Id_Supported'Access;
- PIC_Option_Ptr := PIC_Option'Access;
- Standalone_Library_Auto_Init_Is_Supported_Ptr :=
- Standalone_Library_Auto_Init_Is_Supported'Access;
- Support_For_Libraries_Ptr := Support_For_Libraries'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- (Default empty version) --
--- --
--- B o d y --
--- --
--- Copyright (C) 2007, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Default version
-
-package body MLib.Tgt.Specific is
-
- -- By default, libraries are not supported at all
-
- function Support_For_Libraries return Library_Support;
- -- Function indicating if libraries are supported
-
- ---------------------------
- -- Support_For_Libraries --
- ---------------------------
-
- function Support_For_Libraries return Library_Support is
- begin
- return None;
- end Support_For_Libraries;
-
-begin
- Support_For_Libraries_Ptr := Support_For_Libraries'Access;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T . S P E C I F I C --
--- --
--- S p e c --
--- --
--- Copyright (C) 2007, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This child package of package MLib.Tgt has no interface.
--- For each platform, there is a specific body that defines the subprogram
--- that are different from the default defined in the body of MLib.Tgt,
--- and modify the corresponding access to subprogram value in the private
--- part of MLib.Tgt.
-
-package MLib.Tgt.Specific is
- pragma Elaborate_Body;
-end MLib.Tgt.Specific;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2010, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with MLib.Fil;
-with Prj.Com;
-
-with MLib.Tgt.Specific;
-pragma Warnings (Off, MLib.Tgt.Specific);
--- MLib.Tgt.Specific is with'ed only for elaboration purposes
-
-package body MLib.Tgt is
-
- ---------------------
- -- Archive_Builder --
- ---------------------
-
- function Archive_Builder return String is
- begin
- return Archive_Builder_Ptr.all;
- end Archive_Builder;
-
- -----------------------------
- -- Archive_Builder_Default --
- -----------------------------
-
- function Archive_Builder_Default return String is
- begin
- return "ar";
- end Archive_Builder_Default;
-
- -----------------------------
- -- Archive_Builder_Options --
- -----------------------------
-
- function Archive_Builder_Options return String_List_Access is
- begin
- return Archive_Builder_Options_Ptr.all;
- end Archive_Builder_Options;
-
- -------------------------------------
- -- Archive_Builder_Options_Default --
- -------------------------------------
-
- function Archive_Builder_Options_Default return String_List_Access is
- begin
- return new String_List'(1 => new String'("cr"));
- end Archive_Builder_Options_Default;
-
- ------------------------------------
- -- Archive_Builder_Append_Options --
- ------------------------------------
-
- function Archive_Builder_Append_Options return String_List_Access is
- begin
- return Archive_Builder_Append_Options_Ptr.all;
- end Archive_Builder_Append_Options;
-
- --------------------------------------------
- -- Archive_Builder_Append_Options_Default --
- --------------------------------------------
-
- function Archive_Builder_Append_Options_Default return String_List_Access is
- begin
- return new String_List'(1 => new String'("q"));
- end Archive_Builder_Append_Options_Default;
-
- -----------------
- -- Archive_Ext --
- -----------------
-
- function Archive_Ext return String is
- begin
- return Archive_Ext_Ptr.all;
- end Archive_Ext;
-
- -------------------------
- -- Archive_Ext_Default --
- -------------------------
-
- function Archive_Ext_Default return String is
- begin
- return "a";
- end Archive_Ext_Default;
-
- ---------------------
- -- Archive_Indexer --
- ---------------------
-
- function Archive_Indexer return String is
- begin
- return Archive_Indexer_Ptr.all;
- end Archive_Indexer;
-
- -----------------------------
- -- Archive_Indexer_Default --
- -----------------------------
-
- function Archive_Indexer_Default return String is
- begin
- return "ranlib";
- end Archive_Indexer_Default;
-
- -----------------------------
- -- Archive_Indexer_Options --
- -----------------------------
-
- function Archive_Indexer_Options return String_List_Access is
- begin
- return Archive_Indexer_Options_Ptr.all;
- end Archive_Indexer_Options;
-
- -------------------------------------
- -- Archive_Indexer_Options_Default --
- -------------------------------------
-
- function Archive_Indexer_Options_Default return String_List_Access is
- begin
- return new String_List (1 .. 0);
- end Archive_Indexer_Options_Default;
-
- ---------------------------
- -- Build_Dynamic_Library --
- ---------------------------
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False)
- is
- begin
- Build_Dynamic_Library_Ptr
- (Ofiles,
- Options,
- Interfaces,
- Lib_Filename,
- Lib_Dir,
- Symbol_Data,
- Driver_Name,
- Lib_Version,
- Auto_Init);
- end Build_Dynamic_Library;
-
- ------------------------------
- -- Default_Symbol_File_Name --
- ------------------------------
-
- function Default_Symbol_File_Name return String is
- begin
- return Default_Symbol_File_Name_Ptr.all;
- end Default_Symbol_File_Name;
-
- --------------------------------------
- -- Default_Symbol_File_Name_Default --
- --------------------------------------
-
- function Default_Symbol_File_Name_Default return String is
- begin
- return "";
- end Default_Symbol_File_Name_Default;
-
- -------------
- -- DLL_Ext --
- -------------
-
- function DLL_Ext return String is
- begin
- return DLL_Ext_Ptr.all;
- end DLL_Ext;
-
- ---------------------
- -- DLL_Ext_Default --
- ---------------------
-
- function DLL_Ext_Default return String is
- begin
- return "so";
- end DLL_Ext_Default;
-
- ----------------
- -- DLL_Prefix --
- ----------------
-
- function DLL_Prefix return String is
- begin
- return DLL_Prefix_Ptr.all;
- end DLL_Prefix;
-
- ------------------------
- -- DLL_Prefix_Default --
- ------------------------
-
- function DLL_Prefix_Default return String is
- begin
- return "lib";
- end DLL_Prefix_Default;
-
- --------------------
- -- Dynamic_Option --
- --------------------
-
- function Dynamic_Option return String is
- begin
- return Dynamic_Option_Ptr.all;
- end Dynamic_Option;
-
- ----------------------------
- -- Dynamic_Option_Default --
- ----------------------------
-
- function Dynamic_Option_Default return String is
- begin
- return "-shared";
- end Dynamic_Option_Default;
-
- -------------------
- -- Is_Object_Ext --
- -------------------
-
- function Is_Object_Ext (Ext : String) return Boolean is
- begin
- return Is_Object_Ext_Ptr (Ext);
- end Is_Object_Ext;
-
- ---------------------------
- -- Is_Object_Ext_Default --
- ---------------------------
-
- function Is_Object_Ext_Default (Ext : String) return Boolean is
- begin
- return Ext = ".o";
- end Is_Object_Ext_Default;
-
- --------------
- -- Is_C_Ext --
- --------------
-
- function Is_C_Ext (Ext : String) return Boolean is
- begin
- return Is_C_Ext_Ptr (Ext);
- end Is_C_Ext;
-
- ----------------------
- -- Is_C_Ext_Default --
- ----------------------
-
- function Is_C_Ext_Default (Ext : String) return Boolean is
- begin
- return Ext = ".c";
- end Is_C_Ext_Default;
-
- --------------------
- -- Is_Archive_Ext --
- --------------------
-
- function Is_Archive_Ext (Ext : String) return Boolean is
- begin
- return Is_Archive_Ext_Ptr (Ext);
- end Is_Archive_Ext;
-
- ----------------------------
- -- Is_Archive_Ext_Default --
- ----------------------------
-
- function Is_Archive_Ext_Default (Ext : String) return Boolean is
- begin
- return Ext = ".a";
- end Is_Archive_Ext_Default;
-
- -------------
- -- Libgnat --
- -------------
-
- function Libgnat return String is
- begin
- return Libgnat_Ptr.all;
- end Libgnat;
-
- ---------------------
- -- Libgnat_Default --
- ---------------------
-
- function Libgnat_Default return String is
- begin
- return "libgnat.a";
- end Libgnat_Default;
-
- ------------------------
- -- Library_Exists_For --
- ------------------------
-
- function Library_Exists_For
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return Boolean
- is
- begin
- return Library_Exists_For_Ptr (Project, In_Tree);
- end Library_Exists_For;
-
- --------------------------------
- -- Library_Exists_For_Default --
- --------------------------------
-
- function Library_Exists_For_Default
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return Boolean
- is
- pragma Unreferenced (In_Tree);
-
- begin
- if not Project.Library then
- Prj.Com.Fail ("INTERNAL ERROR: Library_Exists_For called " &
- "for non library project");
- return False;
-
- else
- declare
- Lib_Dir : constant String :=
- Get_Name_String (Project.Library_Dir.Display_Name);
- Lib_Name : constant String :=
- Get_Name_String (Project.Library_Name);
-
- begin
- if Project.Library_Kind = Static then
- return Is_Regular_File
- (Lib_Dir & Directory_Separator & "lib" &
- Fil.Append_To (Lib_Name, Archive_Ext));
-
- else
- return Is_Regular_File
- (Lib_Dir & Directory_Separator & DLL_Prefix &
- Fil.Append_To (Lib_Name, DLL_Ext));
- end if;
- end;
- end if;
- end Library_Exists_For_Default;
-
- ---------------------------
- -- Library_File_Name_For --
- ---------------------------
-
- function Library_File_Name_For
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return File_Name_Type
- is
- begin
- return Library_File_Name_For_Ptr (Project, In_Tree);
- end Library_File_Name_For;
-
- -----------------------------------
- -- Library_File_Name_For_Default --
- -----------------------------------
-
- function Library_File_Name_For_Default
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return File_Name_Type
- is
- pragma Unreferenced (In_Tree);
- begin
- if not Project.Library then
- Prj.Com.Fail ("INTERNAL ERROR: Library_File_Name_For called " &
- "for non library project");
- return No_File;
-
- else
- declare
- Lib_Name : constant String :=
- Get_Name_String (Project.Library_Name);
-
- begin
- if Project.Library_Kind =
- Static
- then
- Name_Len := 3;
- Name_Buffer (1 .. Name_Len) := "lib";
- Add_Str_To_Name_Buffer (Fil.Append_To (Lib_Name, Archive_Ext));
- else
- Name_Len := 0;
- Add_Str_To_Name_Buffer (DLL_Prefix);
- Add_Str_To_Name_Buffer (Fil.Append_To (Lib_Name, DLL_Ext));
- end if;
-
- return Name_Find;
- end;
- end if;
- end Library_File_Name_For_Default;
-
- --------------------------------------
- -- Library_Major_Minor_Id_Supported --
- --------------------------------------
-
- function Library_Major_Minor_Id_Supported return Boolean is
- begin
- return Library_Major_Minor_Id_Supported_Ptr.all;
- end Library_Major_Minor_Id_Supported;
-
- ----------------------------------------------
- -- Library_Major_Minor_Id_Supported_Default --
- ----------------------------------------------
-
- function Library_Major_Minor_Id_Supported_Default return Boolean is
- begin
- return True;
- end Library_Major_Minor_Id_Supported_Default;
-
- ----------------
- -- Object_Ext --
- ----------------
-
- function Object_Ext return String is
- begin
- return Object_Ext_Ptr.all;
- end Object_Ext;
-
- ------------------------
- -- Object_Ext_Default --
- ------------------------
-
- function Object_Ext_Default return String is
- begin
- return "o";
- end Object_Ext_Default;
-
- ----------------
- -- PIC_Option --
- ----------------
-
- function PIC_Option return String is
- begin
- return PIC_Option_Ptr.all;
- end PIC_Option;
-
- ------------------------
- -- PIC_Option_Default --
- ------------------------
-
- function PIC_Option_Default return String is
- begin
- return "-fPIC";
- end PIC_Option_Default;
-
- -----------------------------------------------
- -- Standalone_Library_Auto_Init_Is_Supported --
- -----------------------------------------------
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean is
- begin
- return Standalone_Library_Auto_Init_Is_Supported_Ptr.all;
- end Standalone_Library_Auto_Init_Is_Supported;
-
- -------------------------------------------------------
- -- Standalone_Library_Auto_Init_Is_Supported_Default --
- -------------------------------------------------------
-
- function Standalone_Library_Auto_Init_Is_Supported_Default return Boolean is
- begin
- return True;
- end Standalone_Library_Auto_Init_Is_Supported_Default;
-
- ---------------------------
- -- Support_For_Libraries --
- ---------------------------
-
- function Support_For_Libraries return Library_Support is
- begin
- return Support_For_Libraries_Ptr.all;
- end Support_For_Libraries;
-
- -----------------------------------
- -- Support_For_Libraries_Default --
- -----------------------------------
-
- function Support_For_Libraries_Default return Library_Support is
- begin
- return Full;
- end Support_For_Libraries_Default;
-
-end MLib.Tgt;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . T G T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2014, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides a set of target dependent routines to build static,
--- dynamic and shared libraries. There are several packages providing
--- the actual routines. This package calls them indirectly by means of
--- access-to-subprogram values. Each target-dependent package initializes
--- these values in its elaboration block.
-
-with Prj; use Prj;
-
-package MLib.Tgt is
-
- function Support_For_Libraries return Library_Support;
- -- Indicates how building libraries by gnatmake is supported by the GNAT
- -- implementation for the platform.
-
- function Standalone_Library_Auto_Init_Is_Supported return Boolean;
- -- Indicates if when building a dynamic Standalone Library,
- -- automatic initialization is supported. If it is, then it is the default,
- -- unless attribute Library_Auto_Init has the value "false".
-
- function Archive_Builder return String;
- -- Returns the name of the archive builder program, usually "ar"
-
- function Archive_Builder_Options return String_List_Access;
- -- A list of options to invoke the Archive_Builder, usually "cr" for "ar"
-
- function Archive_Builder_Append_Options return String_List_Access;
- -- A list of options to use with the archive builder to append object
- -- files ("q", for example).
-
- function Archive_Indexer return String;
- -- Returns the name of the program, if any, that generates an index to the
- -- contents of an archive, usually "ranlib". If there is no archive indexer
- -- to be used, returns an empty string.
-
- function Archive_Indexer_Options return String_List_Access;
- -- A list of options to invoke the Archive_Indexer, usually empty
-
- function Dynamic_Option return String;
- -- gcc option to create a dynamic library.
- -- For Unix, returns "-shared", for Windows returns "-mdll".
-
- function Libgnat return String;
- -- System dependent static GNAT library
-
- function Archive_Ext return String;
- -- System dependent static library extension, without leading dot.
- -- For Unix and Windows, return "a".
-
- function Object_Ext return String;
- -- System dependent object extension, without leading dot.
- -- On Unix, returns "o".
-
- function DLL_Prefix return String;
- -- System dependent dynamic library prefix.
- -- On Windows, returns "". On other platforms, returns "lib".
-
- function DLL_Ext return String;
- -- System dependent dynamic library extension, without leading dot.
- -- On Windows, returns "dll". On Unix, usually returns "so", but not
- -- always, e.g. on HP-UX the extension for shared libraries is "sl".
-
- function PIC_Option return String;
- -- Position independent code option
-
- function Is_Object_Ext (Ext : String) return Boolean;
- -- Returns True iff Ext is an object file extension
-
- function Is_C_Ext (Ext : String) return Boolean;
- -- Returns True iff Ext is a C file extension
-
- function Is_Archive_Ext (Ext : String) return Boolean;
- -- Returns True iff Ext is an extension for a library
-
- function Default_Symbol_File_Name return String;
- -- Returns the name of the symbol file when Library_Symbol_File is not
- -- specified. Return the empty string when symbol files are not supported.
-
- procedure Build_Dynamic_Library
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
- -- Build a dynamic/relocatable library
- --
- -- Ofiles is the list of all object files in the library
- --
- -- Options is a list of options to be passed to the tool
- -- (gcc or other) that effectively builds the dynamic library.
- --
- -- Interfaces is the list of ALI files for the interfaces of a SAL.
- -- It is empty if the library is not a SAL.
- --
- -- Lib_Filename is the name of the library, without any prefix or
- -- extension. For example, on Unix, if Lib_Filename is "toto", the
- -- name of the library file will be "libtoto.so".
- --
- -- Lib_Dir is the directory path where the library will be located
- --
- -- For OSes that support symbolic links, Lib_Version, if non null,
- -- is the actual file name of the library. For example on Unix, if
- -- Lib_Filename is "toto" and Lib_Version is "libtoto.so.2.1",
- -- "libtoto.so" will be a symbolic link to "libtoto.so.2.1" which
- -- will be the actual library file.
- --
- -- Symbol_Data is used for some platforms, to generate the symbols to be
- -- exported by the library (not certain if it is currently in use or not).
- --
- -- Note: Depending on the OS, some of the parameters may not be taken into
- -- account. For example, on Linux, Interfaces, Symbol_Data and Auto_Init
- -- are ignored.
-
- function Library_Exists_For
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return Boolean;
- -- Return True if the library file for a library project already exists.
- -- This function can only be called for library projects.
-
- function Library_File_Name_For
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return File_Name_Type;
- -- Returns the file name of the library file of a library project.
- -- This function can only be called for library projects.
-
- function Library_Major_Minor_Id_Supported return Boolean;
- -- Indicates if major and minor ids are supported for libraries.
- -- If they are supported, then a Library_Version such as libtoto.so.1.2
- -- will have a major id of 1 and a minor id of 2. Then libtoto.so,
- -- libtoto.so.1 and libtoto.so.1.2 will be created, all three designating
- -- the same file.
-
-private
- No_Argument_List : constant Argument_List := (1 .. 0 => null);
-
- -- Access to subprogram types for indirection
-
- type String_Function is access function return String;
- type Is_Ext_Function is access function (Ext : String) return Boolean;
- type String_List_Access_Function is access function
- return String_List_Access;
-
- type Build_Dynamic_Library_Function is access procedure
- (Ofiles : Argument_List;
- Options : Argument_List;
- Interfaces : Argument_List;
- Lib_Filename : String;
- Lib_Dir : String;
- Symbol_Data : Symbol_Record;
- Driver_Name : Name_Id := No_Name;
- Lib_Version : String := "";
- Auto_Init : Boolean := False);
-
- type Library_Exists_For_Function is access function
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return Boolean;
-
- type Library_File_Name_For_Function is access function
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return File_Name_Type;
-
- type Boolean_Function is access function return Boolean;
- type Library_Support_Function is access function return Library_Support;
-
- function Archive_Builder_Default return String;
- Archive_Builder_Ptr : String_Function := Archive_Builder_Default'Access;
-
- function Archive_Builder_Options_Default return String_List_Access;
- Archive_Builder_Options_Ptr : String_List_Access_Function :=
- Archive_Builder_Options_Default'Access;
-
- function Archive_Builder_Append_Options_Default return String_List_Access;
- Archive_Builder_Append_Options_Ptr : String_List_Access_Function :=
- Archive_Builder_Append_Options_Default'Access;
-
- function Archive_Ext_Default return String;
- Archive_Ext_Ptr : String_Function := Archive_Ext_Default'Access;
-
- function Archive_Indexer_Default return String;
- Archive_Indexer_Ptr : String_Function := Archive_Indexer_Default'Access;
-
- function Archive_Indexer_Options_Default return String_List_Access;
- Archive_Indexer_Options_Ptr : String_List_Access_Function :=
- Archive_Indexer_Options_Default'Access;
-
- function Default_Symbol_File_Name_Default return String;
- Default_Symbol_File_Name_Ptr : String_Function :=
- Default_Symbol_File_Name_Default'Access;
-
- Build_Dynamic_Library_Ptr : Build_Dynamic_Library_Function;
-
- function DLL_Ext_Default return String;
- DLL_Ext_Ptr : String_Function := DLL_Ext_Default'Access;
-
- function DLL_Prefix_Default return String;
- DLL_Prefix_Ptr : String_Function := DLL_Prefix_Default'Access;
-
- function Dynamic_Option_Default return String;
- Dynamic_Option_Ptr : String_Function := Dynamic_Option_Default'Access;
-
- function Is_Object_Ext_Default (Ext : String) return Boolean;
- Is_Object_Ext_Ptr : Is_Ext_Function := Is_Object_Ext_Default'Access;
-
- function Is_C_Ext_Default (Ext : String) return Boolean;
- Is_C_Ext_Ptr : Is_Ext_Function := Is_C_Ext_Default'Access;
-
- function Is_Archive_Ext_Default (Ext : String) return Boolean;
- Is_Archive_Ext_Ptr : Is_Ext_Function := Is_Archive_Ext_Default'Access;
-
- function Libgnat_Default return String;
- Libgnat_Ptr : String_Function := Libgnat_Default'Access;
-
- function Library_Exists_For_Default
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return Boolean;
- Library_Exists_For_Ptr : Library_Exists_For_Function :=
- Library_Exists_For_Default'Access;
-
- function Library_File_Name_For_Default
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref) return File_Name_Type;
- Library_File_Name_For_Ptr : Library_File_Name_For_Function :=
- Library_File_Name_For_Default'Access;
-
- function Object_Ext_Default return String;
- Object_Ext_Ptr : String_Function := Object_Ext_Default'Access;
-
- function PIC_Option_Default return String;
- PIC_Option_Ptr : String_Function := PIC_Option_Default'Access;
-
- function Standalone_Library_Auto_Init_Is_Supported_Default return Boolean;
- Standalone_Library_Auto_Init_Is_Supported_Ptr : Boolean_Function :=
- Standalone_Library_Auto_Init_Is_Supported_Default'Access;
-
- function Support_For_Libraries_Default return Library_Support;
- Support_For_Libraries_Ptr : Library_Support_Function :=
- Support_For_Libraries_Default'Access;
-
- function Library_Major_Minor_Id_Supported_Default return Boolean;
- Library_Major_Minor_Id_Supported_Ptr : Boolean_Function :=
- Library_Major_Minor_Id_Supported_Default'Access;
-end MLib.Tgt;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . U T L --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-2014, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with MLib.Fil; use MLib.Fil;
-with MLib.Tgt; use MLib.Tgt;
-with Opt;
-with Osint;
-with Output; use Output;
-
-with Interfaces.C.Strings; use Interfaces.C.Strings;
-
-package body MLib.Utl is
-
- Adalib_Path : String_Access := null;
- -- Path of the GNAT adalib directory, specified in procedure
- -- Specify_Adalib_Dir. Used in function Lib_Directory.
-
- Gcc_Name : String_Access;
- -- Default value of the "gcc" executable used in procedure Gcc
-
- Gcc_Exec : String_Access;
- -- The full path name of the "gcc" executable
-
- Ar_Name : String_Access;
- -- The name of the archive builder for the platform, set when procedure Ar
- -- is called for the first time.
-
- Ar_Exec : String_Access;
- -- The full path name of the archive builder
-
- Ar_Options : String_List_Access;
- -- The minimum options used when invoking the archive builder
-
- Ar_Append_Options : String_List_Access;
- -- The options to be used when invoking the archive builder to add chunks
- -- of object files, when building the archive in chunks.
-
- Opt_Length : Natural := 0;
- -- The max number of options for the Archive_Builder
-
- Initial_Size : Natural := 0;
- -- The minimum number of bytes for the invocation of the Archive Builder
- -- (without name of the archive or object files).
-
- Ranlib_Name : String_Access;
- -- The name of the archive indexer for the platform, if there is one
-
- Ranlib_Exec : String_Access := null;
- -- The full path name of the archive indexer
-
- Ranlib_Options : String_List_Access := null;
- -- The options to be used when invoking the archive indexer, if any
-
- --------
- -- Ar --
- --------
-
- procedure Ar (Output_File : String; Objects : Argument_List) is
- Full_Output_File : constant String :=
- Ext_To (Output_File, Archive_Ext);
-
- Arguments : Argument_List_Access;
- Last_Arg : Natural := 0;
- Success : Boolean;
- Line_Length : Natural := 0;
-
- Maximum_Size : Integer;
- pragma Import (C, Maximum_Size, "__gnat_link_max");
- -- Maximum number of bytes to put in an invocation of the
- -- Archive_Builder.
-
- Size : Integer;
- -- The number of bytes for the invocation of the archive builder
-
- Current_Object : Natural;
-
- procedure Display;
- -- Display an invocation of the Archive Builder
-
- -------------
- -- Display --
- -------------
-
- procedure Display is
- begin
- if not Opt.Quiet_Output then
- Write_Str (Ar_Name.all);
- Line_Length := Ar_Name'Length;
-
- for J in 1 .. Last_Arg loop
-
- -- Make sure the Output buffer does not overflow
-
- if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then
- Write_Eol;
- Line_Length := 0;
- end if;
-
- Write_Char (' ');
-
- -- Only output the first object files when not in verbose mode
-
- if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then
- Write_Str ("...");
- exit;
- end if;
-
- Write_Str (Arguments (J).all);
- Line_Length := Line_Length + 1 + Arguments (J)'Length;
- end loop;
-
- Write_Eol;
- end if;
-
- end Display;
-
- begin
- if Ar_Exec = null then
- Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake");
- Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
-
- if Ar_Exec = null then
- Free (Ar_Name);
- Ar_Name := new String'(Archive_Builder);
- Ar_Exec := Locate_Exec_On_Path (Ar_Name.all);
- end if;
-
- if Ar_Exec = null then
- Fail (Ar_Name.all & " not found in path");
-
- elsif Opt.Verbose_Mode then
- Write_Str ("found ");
- Write_Line (Ar_Exec.all);
- end if;
-
- Ar_Options := Archive_Builder_Options;
-
- Initial_Size := 0;
- for J in Ar_Options'Range loop
- Initial_Size := Initial_Size + Ar_Options (J)'Length + 1;
- end loop;
-
- Ar_Append_Options := Archive_Builder_Append_Options;
-
- Opt_Length := Ar_Options'Length;
-
- if Ar_Append_Options /= null then
- Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length);
-
- Size := 0;
- for J in Ar_Append_Options'Range loop
- Size := Size + Ar_Append_Options (J)'Length + 1;
- end loop;
-
- Initial_Size := Integer'Max (Initial_Size, Size);
- end if;
-
- -- ranlib
-
- Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake");
-
- if Ranlib_Name'Length > 0 then
- Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
-
- if Ranlib_Exec = null then
- Free (Ranlib_Name);
- Ranlib_Name := new String'(Archive_Indexer);
- Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all);
- end if;
-
- if Ranlib_Exec /= null and then Opt.Verbose_Mode then
- Write_Str ("found ");
- Write_Line (Ranlib_Exec.all);
- end if;
- end if;
-
- Ranlib_Options := Archive_Indexer_Options;
- end if;
-
- Arguments :=
- new String_List (1 .. 1 + Opt_Length + Objects'Length);
- Arguments (1 .. Ar_Options'Length) := Ar_Options.all; -- "ar cr ..."
- Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File);
-
- Delete_File (Full_Output_File);
-
- Size := Initial_Size + Full_Output_File'Length + 1;
-
- -- Check the full size of a call of the archive builder with all the
- -- object files.
-
- for J in Objects'Range loop
- Size := Size + Objects (J)'Length + 1;
- end loop;
-
- -- If the size is not too large or if it is not possible to build the
- -- archive in chunks, build the archive in a single invocation.
-
- if Size <= Maximum_Size or else Ar_Append_Options = null then
- Last_Arg := Ar_Options'Length + 1 + Objects'Length;
- Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects;
-
- Display;
-
- Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
-
- else
- -- Build the archive in several invocation, making sure to not
- -- go over the maximum size for each invocation.
-
- Last_Arg := Ar_Options'Length + 1;
- Current_Object := Objects'First;
- Size := Initial_Size + Full_Output_File'Length + 1;
-
- -- First invocation
-
- while Current_Object <= Objects'Last loop
- Size := Size + Objects (Current_Object)'Length + 1;
- exit when Size > Maximum_Size;
- Last_Arg := Last_Arg + 1;
- Arguments (Last_Arg) := Objects (Current_Object);
- Current_Object := Current_Object + 1;
- end loop;
-
- Display;
-
- Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
-
- Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all;
- Arguments
- (Ar_Append_Options'Length + 1) := new String'(Full_Output_File);
-
- -- Appending invocation(s)
-
- Big_Loop : while Success and then Current_Object <= Objects'Last loop
- Last_Arg := Ar_Append_Options'Length + 1;
- Size := Initial_Size + Full_Output_File'Length + 1;
-
- Inner_Loop : while Current_Object <= Objects'Last loop
- Size := Size + Objects (Current_Object)'Length + 1;
- exit Inner_Loop when Size > Maximum_Size;
- Last_Arg := Last_Arg + 1;
- Arguments (Last_Arg) := Objects (Current_Object);
- Current_Object := Current_Object + 1;
- end loop Inner_Loop;
-
- Display;
-
- Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success);
- end loop Big_Loop;
- end if;
-
- if not Success then
- Fail (Ar_Name.all & " execution error.");
- end if;
-
- -- If we have found ranlib, run it over the library
-
- if Ranlib_Exec /= null then
- if not Opt.Quiet_Output then
- Write_Str (Ranlib_Name.all);
- Write_Char (' ');
-
- for J in Ranlib_Options'Range loop
- Write_Str (Ranlib_Options (J).all);
- Write_Char (' ');
- end loop;
-
- Write_Line (Arguments (Ar_Options'Length + 1).all);
- end if;
-
- Spawn
- (Ranlib_Exec.all,
- Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)),
- Success);
-
- if not Success then
- Fail (Ranlib_Name.all & " execution error.");
- end if;
- end if;
- end Ar;
-
- -----------------
- -- Delete_File --
- -----------------
-
- procedure Delete_File (Filename : String) is
- File : constant String := Filename & ASCII.NUL;
- Success : Boolean;
-
- begin
- Delete_File (File'Address, Success);
-
- if Opt.Verbose_Mode then
- if Success then
- Write_Str ("deleted ");
-
- else
- Write_Str ("could not delete ");
- end if;
-
- Write_Line (Filename);
- end if;
- end Delete_File;
-
- ---------
- -- Gcc --
- ---------
-
- procedure Gcc
- (Output_File : String;
- Objects : Argument_List;
- Options : Argument_List;
- Options_2 : Argument_List;
- Driver_Name : Name_Id := No_Name)
- is
- Link_Bytes : Integer := 0;
- -- Projected number of bytes for the linker command line
-
- Link_Max : Integer;
- pragma Import (C, Link_Max, "__gnat_link_max");
- -- Maximum number of bytes on the command line supported by the OS
- -- linker. Passed this limit the response file mechanism must be used
- -- if supported.
-
- Object_List_File_Supported : Boolean;
- for Object_List_File_Supported'Size use Character'Size;
- pragma Import
- (C, Object_List_File_Supported, "__gnat_objlist_file_supported");
- -- Predicate indicating whether the linker has an option whereby the
- -- names of object files can be passed to the linker in a file.
-
- Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr;
- pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option");
- -- Pointer to a string representing the linker option which specifies
- -- the response file.
-
- Object_File_Option : constant String := Value (Object_File_Option_Ptr);
- -- The linker option which specifies the response file as a string
-
- Using_GNU_response_file : constant Boolean :=
- Object_File_Option'Length > 0
- and then
- Object_File_Option
- (Object_File_Option'Last) = '@';
- -- Whether a GNU response file is used
-
- Tname : String_Access;
- Tname_FD : File_Descriptor := Invalid_FD;
- -- Temporary file used by linker to pass list of object files on
- -- certain systems with limitations on size of arguments.
-
- Closing_Status : Boolean;
- -- For call to Close
-
- Arguments :
- Argument_List
- (1 .. 7 + Objects'Length + Options'Length + Options_2'Length);
-
- A : Natural := 0;
- Success : Boolean;
-
- Out_Opt : constant String_Access := new String'("-o");
- Out_V : constant String_Access := new String'(Output_File);
- Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory);
- Lib_Opt : constant String_Access := new String'(Dynamic_Option);
-
- Driver : String_Access;
-
- type Object_Position is (First, Second, Last);
-
- Position : Object_Position;
-
- procedure Write_RF (S : String);
- -- Write a string to the response file and check if it was successful.
- -- Fail the program if it was not successful (disk full).
-
- --------------
- -- Write_RF --
- --------------
-
- procedure Write_RF (S : String) is
- Success : Boolean := True;
- Back_Slash : constant Character := '\';
-
- begin
- -- If a GNU response file is used, space and backslash need to be
- -- escaped because they are interpreted as a string separator and
- -- an escape character respectively by the underlying mechanism.
- -- On the other hand, quote and double-quote are not escaped since
- -- they are interpreted as string delimiters on both sides.
-
- if Using_GNU_response_file then
- for J in S'Range loop
- if S (J) = ' ' or else S (J) = '\' then
- if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then
- Success := False;
- end if;
- end if;
-
- if Write (Tname_FD, S (J)'Address, 1) /= 1 then
- Success := False;
- end if;
- end loop;
-
- else
- if Write (Tname_FD, S'Address, S'Length) /= S'Length then
- Success := False;
- end if;
- end if;
-
- if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then
- Success := False;
- end if;
-
- if not Success then
- Fail ("cannot generate response file to link library: disk full");
- end if;
- end Write_RF;
-
- -- Start of processing for Gcc
-
- begin
- if Driver_Name = No_Name then
- if Gcc_Exec = null then
- if Gcc_Name = null then
- Gcc_Name := Osint.Program_Name ("gcc", "gnatmake");
- end if;
-
- Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all);
-
- if Gcc_Exec = null then
- Fail (Gcc_Name.all & " not found in path");
- end if;
- end if;
-
- Driver := Gcc_Exec;
-
- else
- Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name));
-
- if Driver = null then
- Fail (Get_Name_String (Driver_Name) & " not found in path");
- end if;
- end if;
-
- Link_Bytes := 0;
-
- if Lib_Opt'Length /= 0 then
- A := A + 1;
- Arguments (A) := Lib_Opt;
- Link_Bytes := Link_Bytes + Lib_Opt'Length + 1;
- end if;
-
- A := A + 1;
- Arguments (A) := Out_Opt;
- Link_Bytes := Link_Bytes + Out_Opt'Length + 1;
-
- A := A + 1;
- Arguments (A) := Out_V;
- Link_Bytes := Link_Bytes + Out_V'Length + 1;
-
- A := A + 1;
- Arguments (A) := Lib_Dir;
- Link_Bytes := Link_Bytes + Lib_Dir'Length + 1;
-
- A := A + Options'Length;
- Arguments (A - Options'Length + 1 .. A) := Options;
-
- for J in Options'Range loop
- Link_Bytes := Link_Bytes + Options (J)'Length + 1;
- end loop;
-
- if not Opt.Quiet_Output then
- if Opt.Verbose_Mode then
- Write_Str (Driver.all);
-
- elsif Driver_Name /= No_Name then
- Write_Str (Get_Name_String (Driver_Name));
-
- else
- Write_Str (Gcc_Name.all);
- end if;
-
- for J in 1 .. A loop
- if Opt.Verbose_Mode or else J < 4 then
- Write_Char (' ');
- Write_Str (Arguments (J).all);
-
- else
- Write_Str (" ...");
- exit;
- end if;
- end loop;
-
- -- Do not display all the object files if not in verbose mode, only
- -- the first one.
-
- Position := First;
- for J in Objects'Range loop
- if Opt.Verbose_Mode or else Position = First then
- Write_Char (' ');
- Write_Str (Objects (J).all);
- Position := Second;
-
- elsif Position = Second then
- Write_Str (" ...");
- Position := Last;
- exit;
- end if;
- end loop;
-
- for J in Options_2'Range loop
- if not Opt.Verbose_Mode then
- if Position = Second then
- Write_Str (" ...");
- end if;
-
- exit;
- end if;
-
- Write_Char (' ');
- Write_Str (Options_2 (J).all);
- end loop;
-
- Write_Eol;
- end if;
-
- for J in Objects'Range loop
- Link_Bytes := Link_Bytes + Objects (J)'Length + 1;
- end loop;
-
- for J in Options_2'Range loop
- Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1;
- end loop;
-
- if Object_List_File_Supported and then Link_Bytes > Link_Max then
-
- -- Create a temporary file containing the object files, one object
- -- file per line for maximal compatibility with linkers supporting
- -- this option.
-
- Create_Temp_File (Tname_FD, Tname);
-
- for J in Objects'Range loop
- Write_RF (Objects (J).all);
- end loop;
-
- Close (Tname_FD, Closing_Status);
-
- if not Closing_Status then
- Fail ("cannot generate response file to link library: disk full");
- end if;
-
- A := A + 1;
- Arguments (A) := new String'(Object_File_Option & Tname.all);
-
- else
- A := A + Objects'Length;
- Arguments (A - Objects'Length + 1 .. A) := Objects;
- end if;
-
- A := A + Options_2'Length;
- Arguments (A - Options_2'Length + 1 .. A) := Options_2;
-
- Spawn (Driver.all, Arguments (1 .. A), Success);
-
- if Success then
- -- Delete the temporary file used in conjunction with linking
- -- if one was created.
-
- if Tname_FD /= Invalid_FD then
- Delete_File (Tname.all);
- end if;
-
- else
- if Driver_Name = No_Name then
- Fail (Gcc_Name.all & " execution error");
- else
- Fail (Get_Name_String (Driver_Name) & " execution error");
- end if;
- end if;
- end Gcc;
-
- -------------------
- -- Lib_Directory --
- -------------------
-
- function Lib_Directory return String is
- Libgnat : constant String := Tgt.Libgnat;
-
- begin
- -- If procedure Specify_Adalib_Dir has been called, used the specified
- -- value.
-
- if Adalib_Path /= null then
- return Adalib_Path.all;
- end if;
-
- Name_Len := Libgnat'Length;
- Name_Buffer (1 .. Name_Len) := Libgnat;
- Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library));
-
- -- Remove libgnat.a
-
- return Name_Buffer (1 .. Name_Len - Libgnat'Length);
- end Lib_Directory;
-
- ------------------------
- -- Specify_Adalib_Dir --
- ------------------------
-
- procedure Specify_Adalib_Dir (Path : String) is
- begin
- if Path'Length = 0 then
- Adalib_Path := null;
- else
- Adalib_Path := new String'(Path);
- end if;
- end Specify_Adalib_Dir;
-
-end MLib.Utl;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B . U T L --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2008, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides an easy way of calling various tools such as gcc,
--- ar, etc...
-
-package MLib.Utl is
-
- procedure Delete_File (Filename : String);
- -- Delete the file Filename and output the name of the deleted file in
- -- verbose mode.
-
- procedure Gcc
- (Output_File : String;
- Objects : Argument_List;
- Options : Argument_List;
- Options_2 : Argument_List;
- Driver_Name : Name_Id := No_Name);
- -- Driver_Name indicates the "driver" to invoke; by default, the "driver"
- -- is gcc. This procedure invokes the driver to create a shared library.
- -- Options are passed to gcc before the objects, Options_2 after.
- -- Output_File is the name of the library file to create. Objects are the
- -- names of the object files to put in the library.
-
- procedure Ar
- (Output_File : String;
- Objects : Argument_List);
- -- Run ar to move all the binaries inside the archive. If ranlib is on
- -- the path, run it also. Output_File is the path name of the archive to
- -- create. Objects is the list of the path names of the object files to be
- -- put in the archive. This procedure currently assumes that it is always
- -- called in the context of gnatmake. If other executables start using this
- -- procedure, an additional parameter would need to be added, and calls to
- -- Osint.Program_Name updated accordingly in the body.
-
- function Lib_Directory return String;
- -- Return the directory containing libgnat
-
- procedure Specify_Adalib_Dir (Path : String);
- -- Specify the path of the GNAT adalib directory, to be returned by
- -- function Lib_Directory without looking for it. This is used only in
- -- gprlib, because we cannot rely on the search in Lib_Directory, as the
- -- GNAT version may be different for gprbuild/gprlib and the compiler.
-
-end MLib.Utl;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B --
--- --
--- B o d y --
--- --
--- Copyright (C) 1999-2014, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Interfaces.C.Strings;
-with System;
-
-with Opt;
-with Output; use Output;
-
-with MLib.Utl; use MLib.Utl;
-
-with Prj.Com;
-
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-
-package body MLib is
-
- -------------------
- -- Build_Library --
- -------------------
-
- procedure Build_Library
- (Ofiles : Argument_List;
- Output_File : String;
- Output_Dir : String)
- is
- begin
- if Opt.Verbose_Mode and not Opt.Quiet_Output then
- Write_Line ("building a library...");
- Write_Str (" make ");
- Write_Line (Output_File);
- end if;
-
- Ar (Output_Dir &
- "lib" & Output_File & ".a", Objects => Ofiles);
- end Build_Library;
-
- ------------------------
- -- Check_Library_Name --
- ------------------------
-
- procedure Check_Library_Name (Name : String) is
- begin
- if Name'Length = 0 then
- Prj.Com.Fail ("library name cannot be empty");
- end if;
-
- if Name'Length > Max_Characters_In_Library_Name then
- Prj.Com.Fail ("illegal library name """
- & Name
- & """: too long");
- end if;
-
- if not Is_Letter (Name (Name'First)) then
- Prj.Com.Fail ("illegal library name """
- & Name
- & """: should start with a letter");
- end if;
-
- for Index in Name'Range loop
- if not Is_Alphanumeric (Name (Index)) then
- Prj.Com.Fail ("illegal library name """
- & Name
- & """: should include only letters and digits");
- end if;
- end loop;
- end Check_Library_Name;
-
- --------------------
- -- Copy_ALI_Files --
- --------------------
-
- procedure Copy_ALI_Files
- (Files : Argument_List;
- To : Path_Name_Type;
- Interfaces : String_List)
- is
- Success : Boolean := False;
- To_Dir : constant String := Get_Name_String (To);
- Is_Interface : Boolean := False;
-
- procedure Verbose_Copy (Index : Positive);
- -- In verbose mode, output a message that the indexed file is copied
- -- to the destination directory.
-
- ------------------
- -- Verbose_Copy --
- ------------------
-
- procedure Verbose_Copy (Index : Positive) is
- begin
- if Opt.Verbose_Mode then
- Write_Str ("Copying """);
- Write_Str (Files (Index).all);
- Write_Str (""" to """);
- Write_Str (To_Dir);
- Write_Line ("""");
- end if;
- end Verbose_Copy;
-
- -- Start of processing for Copy_ALI_Files
-
- begin
- if Interfaces'Length = 0 then
-
- -- If there are no Interfaces, copy all the ALI files as is
-
- for Index in Files'Range loop
- Verbose_Copy (Index);
- Set_Writable
- (To_Dir &
- Directory_Separator &
- Base_Name (Files (Index).all));
- Copy_File
- (Files (Index).all,
- To_Dir,
- Success,
- Mode => Overwrite,
- Preserve => Preserve);
-
- exit when not Success;
- end loop;
-
- else
- -- Copy only the interface ALI file, and put the special indicator
- -- "SL" on the P line.
-
- for Index in Files'Range loop
-
- declare
- File_Name : String := Base_Name (Files (Index).all);
-
- begin
- Canonical_Case_File_Name (File_Name);
-
- -- Check if this is one of the interface ALIs
-
- Is_Interface := False;
-
- for Index in Interfaces'Range loop
- if File_Name = Interfaces (Index).all then
- Is_Interface := True;
- exit;
- end if;
- end loop;
-
- -- If it is an interface ALI, copy line by line. Insert
- -- the interface indication at the end of the P line.
- -- Do not copy ALI files that are not Interfaces.
-
- if Is_Interface then
- Success := False;
- Verbose_Copy (Index);
- Set_Writable
- (To_Dir &
- Directory_Separator &
- Base_Name (Files (Index).all));
-
- declare
- FD : File_Descriptor;
- Len : Integer;
- Actual_Len : Integer;
- S : String_Access;
- Curr : Natural;
- P_Line_Found : Boolean;
- Status : Boolean;
-
- begin
- -- Open the file
-
- Name_Len := Files (Index)'Length;
- Name_Buffer (1 .. Name_Len) := Files (Index).all;
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ASCII.NUL;
-
- FD := Open_Read (Name_Buffer'Address, Binary);
-
- if FD /= Invalid_FD then
- Len := Integer (File_Length (FD));
-
- -- ??? Why "+3" here
-
- S := new String (1 .. Len + 3);
-
- -- Read the file. This loop is probably not necessary
- -- since on most (all?) targets, the whole file is
- -- read in at once, but we have encountered systems
- -- in the past where this was not true, and we retain
- -- this loop in case we encounter that in the future.
-
- Curr := S'First;
- while Curr <= Len loop
- Actual_Len := Read (FD, S (Curr)'Address, Len);
-
- -- Exit if we could not read for some reason
-
- exit when Actual_Len = 0;
-
- Curr := Curr + Actual_Len;
- end loop;
-
- -- We are done with the input file, so we close it
- -- ignoring any bad status.
-
- Close (FD, Status);
-
- P_Line_Found := False;
-
- -- Look for the P line. When found, add marker SL
- -- at the beginning of the P line.
-
- for Index in 1 .. Len - 3 loop
- if (S (Index) = ASCII.LF
- or else
- S (Index) = ASCII.CR)
- and then S (Index + 1) = 'P'
- then
- S (Index + 5 .. Len + 3) := S (Index + 2 .. Len);
- S (Index + 2 .. Index + 4) := " SL";
- P_Line_Found := True;
- exit;
- end if;
- end loop;
-
- if P_Line_Found then
-
- -- Create new modified ALI file
-
- Name_Len := To_Dir'Length;
- Name_Buffer (1 .. Name_Len) := To_Dir;
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Directory_Separator;
- Name_Buffer
- (Name_Len + 1 .. Name_Len + File_Name'Length) :=
- File_Name;
- Name_Len := Name_Len + File_Name'Length + 1;
- Name_Buffer (Name_Len) := ASCII.NUL;
-
- FD := Create_File (Name_Buffer'Address, Binary);
-
- -- Write the modified text and close the newly
- -- created file.
-
- if FD /= Invalid_FD then
- Actual_Len := Write (FD, S (1)'Address, Len + 3);
-
- Close (FD, Status);
-
- -- Set Success to True only if the newly
- -- created file has been correctly written.
-
- Success := Status and then Actual_Len = Len + 3;
-
- if Success then
-
- -- Set_Read_Only is used here, rather than
- -- Set_Non_Writable, so that gprbuild can
- -- he compiled with older compilers.
-
- Set_Read_Only
- (Name_Buffer (1 .. Name_Len - 1));
- end if;
- end if;
- end if;
- end if;
- end;
-
- -- This is not an interface ALI
-
- else
- Success := True;
- end if;
- end;
-
- if not Success then
- Prj.Com.Fail ("could not copy ALI files to library dir");
- end if;
- end loop;
- end if;
- end Copy_ALI_Files;
-
- ----------------------
- -- Create_Sym_Links --
- ----------------------
-
- procedure Create_Sym_Links
- (Lib_Path : String;
- Lib_Version : String;
- Lib_Dir : String;
- Maj_Version : String)
- is
- function Symlink
- (Oldpath : System.Address;
- Newpath : System.Address) return Integer;
- pragma Import (C, Symlink, "__gnat_symlink");
-
- Version_Path : String_Access;
-
- Success : Boolean;
- Result : Integer;
- pragma Unreferenced (Success, Result);
-
- begin
- Version_Path := new String (1 .. Lib_Version'Length + 1);
- Version_Path (1 .. Lib_Version'Length) := Lib_Version;
- Version_Path (Version_Path'Last) := ASCII.NUL;
-
- if Maj_Version'Length = 0 then
- declare
- Newpath : String (1 .. Lib_Path'Length + 1);
- begin
- Newpath (1 .. Lib_Path'Length) := Lib_Path;
- Newpath (Newpath'Last) := ASCII.NUL;
- Delete_File (Lib_Path, Success);
- Result := Symlink (Version_Path (1)'Address, Newpath'Address);
- end;
-
- else
- declare
- Newpath1 : String (1 .. Lib_Path'Length + 1);
- Maj_Path : constant String :=
- Lib_Dir & Directory_Separator & Maj_Version;
- Newpath2 : String (1 .. Maj_Path'Length + 1);
- Maj_Ver : String (1 .. Maj_Version'Length + 1);
-
- begin
- Newpath1 (1 .. Lib_Path'Length) := Lib_Path;
- Newpath1 (Newpath1'Last) := ASCII.NUL;
-
- Newpath2 (1 .. Maj_Path'Length) := Maj_Path;
- Newpath2 (Newpath2'Last) := ASCII.NUL;
-
- Maj_Ver (1 .. Maj_Version'Length) := Maj_Version;
- Maj_Ver (Maj_Ver'Last) := ASCII.NUL;
-
- Delete_File (Maj_Path, Success);
-
- Result := Symlink (Version_Path (1)'Address, Newpath2'Address);
-
- Delete_File (Lib_Path, Success);
-
- Result := Symlink (Maj_Ver'Address, Newpath1'Address);
- end;
- end if;
- end Create_Sym_Links;
-
- --------------------------------
- -- Linker_Library_Path_Option --
- --------------------------------
-
- function Linker_Library_Path_Option return String_Access is
-
- Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr;
- pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option");
- -- Pointer to string representing the native linker option which
- -- specifies the path where the dynamic loader should find shared
- -- libraries. Equal to null string if this system doesn't support it.
-
- S : constant String := Interfaces.C.Strings.Value (Run_Path_Option_Ptr);
-
- begin
- if S'Length = 0 then
- return null;
- else
- return new String'(S);
- end if;
- end Linker_Library_Path_Option;
-
- -------------------
- -- Major_Id_Name --
- -------------------
-
- function Major_Id_Name
- (Lib_Filename : String;
- Lib_Version : String)
- return String
- is
- Maj_Version : constant String := Lib_Version;
- Last_Maj : Positive;
- Last : Positive;
- Ok_Maj : Boolean := False;
-
- begin
- Last_Maj := Maj_Version'Last;
- while Last_Maj > Maj_Version'First loop
- if Maj_Version (Last_Maj) in '0' .. '9' then
- Last_Maj := Last_Maj - 1;
-
- else
- Ok_Maj := Last_Maj /= Maj_Version'Last and then
- Maj_Version (Last_Maj) = '.';
-
- if Ok_Maj then
- Last_Maj := Last_Maj - 1;
- end if;
-
- exit;
- end if;
- end loop;
-
- if Ok_Maj then
- Last := Last_Maj;
- while Last > Maj_Version'First loop
- if Maj_Version (Last) in '0' .. '9' then
- Last := Last - 1;
-
- else
- Ok_Maj := Last /= Last_Maj and then
- Maj_Version (Last) = '.';
-
- if Ok_Maj then
- Last := Last - 1;
- Ok_Maj :=
- Maj_Version (Maj_Version'First .. Last) = Lib_Filename;
- end if;
-
- exit;
- end if;
- end loop;
- end if;
-
- if Ok_Maj then
- return Maj_Version (Maj_Version'First .. Last_Maj);
- else
- return "";
- end if;
- end Major_Id_Name;
-
- -------------------------------
- -- Separate_Run_Path_Options --
- -------------------------------
-
- function Separate_Run_Path_Options return Boolean is
- Separate_Paths : Boolean;
- for Separate_Paths'Size use Character'Size;
- pragma Import (C, Separate_Paths, "__gnat_separate_run_path_options");
- begin
- return Separate_Paths;
- end Separate_Run_Path_Options;
-
-end MLib;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- M L I B --
--- --
--- S p e c --
--- --
--- Copyright (C) 1999-2014, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides the core high level routines used by GNATMLIB
--- and GNATMAKE to build libraries
-
-with Namet; use Namet;
-with Osint; use Osint;
-
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-
-package MLib is
-
- No_Argument_List : aliased String_List := (1 .. 0 => null);
- No_Argument : constant String_List_Access := No_Argument_List'Access;
-
- Max_Characters_In_Library_Name : constant := 20;
- -- Maximum number of characters in a library name.
- -- Used by Check_Library_Name below.
-
- type Fail_Proc is access procedure (S1 : String);
-
- Fail : Fail_Proc := Osint.Fail'Access;
- -- This procedure is used in the MLib hierarchy, instead of
- -- directly calling Osint.Fail.
- -- It is redirected to Make.Make_Failed by gnatmake.
-
- procedure Check_Library_Name (Name : String);
- -- Verify that the name of a library has the following characteristics
- -- - starts with a letter
- -- - includes only letters and digits
- -- - contains not more than Max_Characters_In_Library_Name characters
-
- procedure Build_Library
- (Ofiles : Argument_List;
- Output_File : String;
- Output_Dir : String);
- -- Build a static library from a set of object files
-
- procedure Copy_ALI_Files
- (Files : Argument_List;
- To : Path_Name_Type;
- Interfaces : String_List);
- -- Copy all ALI files Files to directory To.
- -- Mark Interfaces ALI files as interfaces, if any.
-
- procedure Create_Sym_Links
- (Lib_Path : String;
- Lib_Version : String;
- Lib_Dir : String;
- Maj_Version : String);
-
- function Linker_Library_Path_Option return String_Access;
- -- Linker option to specify to the linker the library directory path.
- -- If non null, the library directory path is to be appended.
- -- Should be deallocated by the caller, when no longer needed.
-
- function Major_Id_Name
- (Lib_Filename : String;
- Lib_Version : String) return String;
- -- Returns the major id library file name, if it exists.
- -- For example, if Lib_Filename is "libtoto.so" and Lib_Version is
- -- "libtoto.so.1.2", then "libtoto.so.1" is returned.
-
- function Separate_Run_Path_Options return Boolean;
- -- Return True if separate rpath arguments must be passed to the linker
- -- for each directory in the rpath.
-
-private
- Preserve : Attribute := Time_Stamps;
- -- Used by Copy_ALI_Files
-
-end MLib;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . A T T R . P M --
--- --
--- B o d y --
--- --
--- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package body Prj.Attr.PM is
-
- -------------------
- -- Add_Attribute --
- -------------------
-
- procedure Add_Attribute
- (To_Package : Package_Node_Id;
- Attribute_Name : Name_Id;
- Attribute_Node : out Attribute_Node_Id)
- is
- begin
- -- Only add attribute if package is already defined and is not unknown
-
- if To_Package /= Empty_Package and then
- To_Package /= Unknown_Package
- then
- Attrs.Append (
- (Name => Attribute_Name,
- Var_Kind => Undefined,
- Optional_Index => False,
- Attr_Kind => Unknown,
- Read_Only => False,
- Others_Allowed => False,
- Default => Empty_Value,
- Next =>
- Package_Attributes.Table (To_Package.Value).First_Attribute));
-
- Package_Attributes.Table (To_Package.Value).First_Attribute :=
- Attrs.Last;
- Attribute_Node := (Value => Attrs.Last);
- end if;
- end Add_Attribute;
-
- -------------------------
- -- Add_Unknown_Package --
- -------------------------
-
- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id) is
- begin
- Package_Attributes.Increment_Last;
- Id := (Value => Package_Attributes.Last);
- Package_Attributes.Table (Id.Value) :=
- (Name => Name,
- Known => False,
- First_Attribute => Empty_Attr);
- end Add_Unknown_Package;
-
-end Prj.Attr.PM;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . A T T R . P M --
--- --
--- S p e c --
--- --
--- Copyright (C) 2005-2007, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains insecure procedures that are intended to be used
--- only inside the Prj and MLib hierarchies. It should not be imported by
--- other tools, such as GPS.
-
-package Prj.Attr.PM is
-
- -- The following procedures are not secure and should only be used by the
- -- Project Manager, that is the packages of the Prj or MLib hierarchies.
- -- What does "not secure" mean???
-
- procedure Add_Unknown_Package (Name : Name_Id; Id : out Package_Node_Id);
- -- Add a new unknown package. The Name cannot be the name of a predefined
- -- or already registered package, but this is not checked.
-
- procedure Add_Attribute
- (To_Package : Package_Node_Id;
- Attribute_Name : Name_Id;
- Attribute_Node : out Attribute_Node_Id);
- -- Add an attribute to the list for package To_Package. Attribute_Name
- -- cannot be the name of an existing attribute of the package, but this is
- -- not checked. Does nothing if To_Package is Empty_Package.
-
-end Prj.Attr.PM;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . A T T R --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Osint;
-with Prj.Com; use Prj.Com;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-
-package body Prj.Attr is
-
- use GNAT;
-
- -- Data for predefined attributes and packages
-
- -- Names are in lower case and end with '#' or 'D'
-
- -- Package names are preceded by 'P'
-
- -- Attribute names are preceded by two or three letters:
-
- -- The first letter is one of
- -- 'S' for Single
- -- 's' for Single with optional index
- -- 'L' for List
- -- 'l' for List of strings with optional indexes
-
- -- The second letter is one of
- -- 'V' for single variable
- -- 'A' for associative array
- -- 'a' for case insensitive associative array
- -- 'b' for associative array, case insensitive if file names are case
- -- insensitive
- -- 'c' same as 'b', with optional index
-
- -- The third optional letter is
- -- 'R' the attribute is read-only
- -- 'O' others is allowed as an index for an associative array
-
- -- If the character after the name in lower case letter is a 'D' (for
- -- default), then 'D' must be followed by an enumeration value of type
- -- Attribute_Default_Value, followed by a '#'.
-
- -- Example:
- -- "SVobject_dirDdot_value#"
-
- -- End is indicated by two consecutive '#'.
-
- Initialization_Data : constant String :=
-
- -- project level attributes
-
- -- General
-
- "SVRname#" &
- "SVRproject_dir#" &
- "lVmain#" &
- "LVlanguages#" &
- "Lbroots#" &
- "SVexternally_built#" &
-
- -- Directories
-
- "SVobject_dirDdot_value#" &
- "SVexec_dirDobject_dir_value#" &
- "LVsource_dirsDdot_value#" &
- "Lainherit_source_path#" &
- "LVexcluded_source_dirs#" &
- "LVignore_source_sub_dirs#" &
-
- -- Source files
-
- "LVsource_files#" &
- "LVlocally_removed_files#" &
- "LVexcluded_source_files#" &
- "SVsource_list_file#" &
- "SVexcluded_source_list_file#" &
- "LVinterfaces#" &
-
- -- Projects (in aggregate projects)
-
- "LVproject_files#" &
- "LVproject_path#" &
- "SAexternal#" &
-
- -- Libraries
-
- "SVlibrary_dir#" &
- "SVlibrary_name#" &
- "SVlibrary_kind#" &
- "SVlibrary_version#" &
- "LVlibrary_interface#" &
- "SVlibrary_standalone#" &
- "LVlibrary_encapsulated_options#" &
- "SVlibrary_encapsulated_supported#" &
- "SVlibrary_auto_init#" &
- "LVleading_library_options#" &
- "LVlibrary_options#" &
- "Lalibrary_rpath_options#" &
- "SVlibrary_src_dir#" &
- "SVlibrary_ali_dir#" &
- "SVlibrary_gcc#" &
- "SVlibrary_symbol_file#" &
- "SVlibrary_symbol_policy#" &
- "SVlibrary_reference_symbol_file#" &
-
- -- Configuration - General
-
- "SVdefault_language#" &
- "LVrun_path_option#" &
- "SVrun_path_origin#" &
- "SVseparate_run_path_options#" &
- "Satoolchain_version#" &
- "Satoolchain_description#" &
- "Saobject_generated#" &
- "Saobjects_linked#" &
- "SVtargetDtarget_value#" &
- "SaruntimeDruntime_value#" &
-
- -- Configuration - Libraries
-
- "SVlibrary_builder#" &
- "SVlibrary_support#" &
-
- -- Configuration - Archives
-
- "LVarchive_builder#" &
- "LVarchive_builder_append_option#" &
- "LVarchive_indexer#" &
- "SVarchive_suffix#" &
- "LVlibrary_partial_linker#" &
-
- -- Configuration - Shared libraries
-
- "SVshared_library_prefix#" &
- "SVshared_library_suffix#" &
- "SVsymbolic_link_supported#" &
- "SVlibrary_major_minor_id_supported#" &
- "SVlibrary_auto_init_supported#" &
- "LVshared_library_minimum_switches#" &
- "LVlibrary_version_switches#" &
- "SVlibrary_install_name_option#" &
- "Saruntime_library_dir#" &
- "Saruntime_source_dir#" &
-
- -- package Naming
- -- Some attributes are obsolescent, and renamed in the tree (see
- -- Prj.Dect.Rename_Obsolescent_Attributes).
-
- "Pnaming#" &
- "Saspecification_suffix#" & -- Always renamed to "spec_suffix" in tree
- "Saspec_suffix#" &
- "Saimplementation_suffix#" & -- Always renamed to "body_suffix" in tree
- "Sabody_suffix#" &
- "SVseparate_suffix#" &
- "SVcasing#" &
- "SVdot_replacement#" &
- "saspecification#" & -- Always renamed to "spec" in project tree
- "saspec#" &
- "saimplementation#" & -- Always renamed to "body" in project tree
- "sabody#" &
- "Laspecification_exceptions#" &
- "Laimplementation_exceptions#" &
-
- -- package Compiler
-
- "Pcompiler#" &
- "Ladefault_switches#" &
- "LcOswitches#" &
- "SVlocal_configuration_pragmas#" &
- "Salocal_config_file#" &
-
- -- Configuration - Compiling
-
- "Sadriver#" &
- "Salanguage_kind#" &
- "Sadependency_kind#" &
- "Larequired_switches#" &
- "Laleading_required_switches#" &
- "Latrailing_required_switches#" &
- "Lapic_option#" &
- "Sapath_syntax#" &
- "Lasource_file_switches#" &
- "Saobject_file_suffix#" &
- "Laobject_file_switches#" &
- "Lamulti_unit_switches#" &
- "Samulti_unit_object_separator#" &
-
- -- Configuration - Mapping files
-
- "Lamapping_file_switches#" &
- "Samapping_spec_suffix#" &
- "Samapping_body_suffix#" &
-
- -- Configuration - Config files
-
- "Laconfig_file_switches#" &
- "Saconfig_body_file_name#" &
- "Saconfig_body_file_name_index#" &
- "Saconfig_body_file_name_pattern#" &
- "Saconfig_spec_file_name#" &
- "Saconfig_spec_file_name_index#" &
- "Saconfig_spec_file_name_pattern#" &
- "Saconfig_file_unique#" &
-
- -- Configuration - Dependencies
-
- "Ladependency_switches#" &
- "Ladependency_driver#" &
-
- -- Configuration - Search paths
-
- "Lainclude_switches#" &
- "Sainclude_path#" &
- "Sainclude_path_file#" &
- "Laobject_path_switches#" &
-
- -- package Builder
-
- "Pbuilder#" &
- "Ladefault_switches#" &
- "LcOswitches#" &
- "Lcglobal_compilation_switches#" &
- "Scexecutable#" &
- "SVexecutable_suffix#" &
- "SVglobal_configuration_pragmas#" &
- "Saglobal_config_file#" &
-
- -- package gnatls
-
- "Pgnatls#" &
- "LVswitches#" &
-
- -- package Binder
-
- "Pbinder#" &
- "Ladefault_switches#" &
- "LcOswitches#" &
-
- -- Configuration - Binding
-
- "Sadriver#" &
- "Larequired_switches#" &
- "Saprefix#" &
- "Saobjects_path#" &
- "Saobjects_path_file#" &
-
- -- package Linker
-
- "Plinker#" &
- "LVrequired_switches#" &
- "Ladefault_switches#" &
- "LcOleading_switches#" &
- "LcOswitches#" &
- "LcOtrailing_switches#" &
- "LVlinker_options#" &
- "SVmap_file_option#" &
-
- -- Configuration - Linking
-
- "SVdriver#" &
-
- -- Configuration - Response files
-
- "SVmax_command_line_length#" &
- "SVresponse_file_format#" &
- "LVresponse_file_switches#" &
-
- -- package Clean
-
- "Pclean#" &
- "LVswitches#" &
- "Lasource_artifact_extensions#" &
- "Laobject_artifact_extensions#" &
- "LVartifacts_in_exec_dir#" &
- "LVartifacts_in_object_dir#" &
-
- -- package Cross_Reference
-
- "Pcross_reference#" &
- "Ladefault_switches#" &
- "LbOswitches#" &
-
- -- package Finder
-
- "Pfinder#" &
- "Ladefault_switches#" &
- "LbOswitches#" &
-
- -- package Pretty_Printer
-
- "Ppretty_printer#" &
- "Ladefault_switches#" &
- "LbOswitches#" &
-
- -- package gnatstub
-
- "Pgnatstub#" &
- "Ladefault_switches#" &
- "LbOswitches#" &
-
- -- package Check
-
- "Pcheck#" &
- "Ladefault_switches#" &
- "LbOswitches#" &
-
- -- package Eliminate
-
- "Peliminate#" &
- "Ladefault_switches#" &
- "LbOswitches#" &
-
- -- package Metrics
-
- "Pmetrics#" &
- "Ladefault_switches#" &
- "LbOswitches#" &
-
- -- package Ide
-
- "Pide#" &
- "Ladefault_switches#" &
- "SVremote_host#" &
- "SVprogram_host#" &
- "SVcommunication_protocol#" &
- "Sacompiler_command#" &
- "SVdebugger_command#" &
- "SVgnatlist#" &
- "SVvcs_kind#" &
- "SVvcs_file_check#" &
- "SVvcs_log_check#" &
- "SVdocumentation_dir#" &
-
- -- package Install
-
- "Pinstall#" &
- "SVprefix#" &
- "SVsources_subdir#" &
- "SVexec_subdir#" &
- "SVlib_subdir#" &
- "SVproject_subdir#" &
- "SVactive#" &
- "LAartifacts#" &
- "LArequired_artifacts#" &
- "SVmode#" &
- "SVinstall_name#" &
-
- -- package Remote
-
- "Premote#" &
- "SVroot_dir#" &
- "LVexcluded_patterns#" &
- "LVincluded_patterns#" &
- "LVincluded_artifact_patterns#" &
-
- -- package Stack
-
- "Pstack#" &
- "LVswitches#" &
-
- -- package Codepeer
-
- "Pcodepeer#" &
- "SVoutput_directory#" &
- "SVdatabase_directory#" &
- "SVmessage_patterns#" &
- "SVadditional_patterns#" &
- "LVswitches#" &
- "LVexcluded_source_files#" &
-
- -- package Prove
-
- "Pprove#" &
-
- -- package GnatTest
-
- "Pgnattest#" &
-
- "#";
-
- Initialized : Boolean := False;
- -- A flag to avoid multiple initialization
-
- Package_Names : String_List_Access := new Strings.String_List (1 .. 20);
- Last_Package_Name : Natural := 0;
- -- Package_Names (1 .. Last_Package_Name) contains the list of the known
- -- package names, coming from the Initialization_Data string or from
- -- calls to one of the two procedures Register_New_Package.
-
- procedure Add_Package_Name (Name : String);
- -- Add a package name in the Package_Name list, extending it, if necessary
-
- function Name_Id_Of (Name : String) return Name_Id;
- -- Returns the Name_Id for Name in lower case
-
- ----------------------
- -- Add_Package_Name --
- ----------------------
-
- procedure Add_Package_Name (Name : String) is
- begin
- if Last_Package_Name = Package_Names'Last then
- declare
- New_List : constant Strings.String_List_Access :=
- new Strings.String_List (1 .. Package_Names'Last * 2);
- begin
- New_List (Package_Names'Range) := Package_Names.all;
- Package_Names := New_List;
- end;
- end if;
-
- Last_Package_Name := Last_Package_Name + 1;
- Package_Names (Last_Package_Name) := new String'(Name);
- end Add_Package_Name;
-
- --------------------------
- -- Attribute_Default_Of --
- --------------------------
-
- function Attribute_Default_Of
- (Attribute : Attribute_Node_Id) return Attribute_Default_Value
- is
- begin
- if Attribute = Empty_Attribute then
- return Empty_Value;
- else
- return Attrs.Table (Attribute.Value).Default;
- end if;
- end Attribute_Default_Of;
-
- -----------------------
- -- Attribute_Kind_Of --
- -----------------------
-
- function Attribute_Kind_Of
- (Attribute : Attribute_Node_Id) return Attribute_Kind
- is
- begin
- if Attribute = Empty_Attribute then
- return Unknown;
- else
- return Attrs.Table (Attribute.Value).Attr_Kind;
- end if;
- end Attribute_Kind_Of;
-
- -----------------------
- -- Attribute_Name_Of --
- -----------------------
-
- function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id is
- begin
- if Attribute = Empty_Attribute then
- return No_Name;
- else
- return Attrs.Table (Attribute.Value).Name;
- end if;
- end Attribute_Name_Of;
-
- --------------------------
- -- Attribute_Node_Id_Of --
- --------------------------
-
- function Attribute_Node_Id_Of
- (Name : Name_Id;
- Starting_At : Attribute_Node_Id) return Attribute_Node_Id
- is
- Id : Attr_Node_Id := Starting_At.Value;
-
- begin
- while Id /= Empty_Attr
- and then Attrs.Table (Id).Name /= Name
- loop
- Id := Attrs.Table (Id).Next;
- end loop;
-
- return (Value => Id);
- end Attribute_Node_Id_Of;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- Start : Positive := Initialization_Data'First;
- Finish : Positive := Start;
- Current_Package : Pkg_Node_Id := Empty_Pkg;
- Current_Attribute : Attr_Node_Id := Empty_Attr;
- Is_An_Attribute : Boolean := False;
- Var_Kind : Variable_Kind := Undefined;
- Optional_Index : Boolean := False;
- Attr_Kind : Attribute_Kind := Single;
- Package_Name : Name_Id := No_Name;
- Attribute_Name : Name_Id := No_Name;
- First_Attribute : Attr_Node_Id := Attr.First_Attribute;
- Read_Only : Boolean;
- Others_Allowed : Boolean;
- Default : Attribute_Default_Value;
-
- function Attribute_Location return String;
- -- Returns a string depending if we are in the project level attributes
- -- or in the attributes of a package.
-
- ------------------------
- -- Attribute_Location --
- ------------------------
-
- function Attribute_Location return String is
- begin
- if Package_Name = No_Name then
- return "project level attributes";
-
- else
- return "attribute of package """ &
- Get_Name_String (Package_Name) & """";
- end if;
- end Attribute_Location;
-
- -- Start of processing for Initialize
-
- begin
- -- Don't allow Initialize action to be repeated
-
- if Initialized then
- return;
- end if;
-
- -- Make sure the two tables are empty
-
- Attrs.Init;
- Package_Attributes.Init;
-
- while Initialization_Data (Start) /= '#' loop
- Is_An_Attribute := True;
- case Initialization_Data (Start) is
- when 'P' =>
-
- -- New allowed package
-
- Start := Start + 1;
-
- Finish := Start;
- while Initialization_Data (Finish) /= '#' loop
- Finish := Finish + 1;
- end loop;
-
- Package_Name :=
- Name_Id_Of (Initialization_Data (Start .. Finish - 1));
-
- for Index in First_Package .. Package_Attributes.Last loop
- if Package_Name = Package_Attributes.Table (Index).Name then
- Osint.Fail ("duplicate name """
- & Initialization_Data (Start .. Finish - 1)
- & """ in predefined packages.");
- end if;
- end loop;
-
- Is_An_Attribute := False;
- Current_Attribute := Empty_Attr;
- Package_Attributes.Increment_Last;
- Current_Package := Package_Attributes.Last;
- Package_Attributes.Table (Current_Package) :=
- (Name => Package_Name,
- Known => True,
- First_Attribute => Empty_Attr);
- Start := Finish + 1;
-
- Add_Package_Name (Get_Name_String (Package_Name));
-
- when 'S' =>
- Var_Kind := Single;
- Optional_Index := False;
-
- when 's' =>
- Var_Kind := Single;
- Optional_Index := True;
-
- when 'L' =>
- Var_Kind := List;
- Optional_Index := False;
-
- when 'l' =>
- Var_Kind := List;
- Optional_Index := True;
-
- when others =>
- raise Program_Error;
- end case;
-
- if Is_An_Attribute then
-
- -- New attribute
-
- Start := Start + 1;
- case Initialization_Data (Start) is
- when 'V' =>
- Attr_Kind := Single;
-
- when 'A' =>
- Attr_Kind := Associative_Array;
-
- when 'a' =>
- Attr_Kind := Case_Insensitive_Associative_Array;
-
- when 'b' =>
- if Osint.File_Names_Case_Sensitive then
- Attr_Kind := Associative_Array;
- else
- Attr_Kind := Case_Insensitive_Associative_Array;
- end if;
-
- when 'c' =>
- if Osint.File_Names_Case_Sensitive then
- Attr_Kind := Optional_Index_Associative_Array;
- else
- Attr_Kind :=
- Optional_Index_Case_Insensitive_Associative_Array;
- end if;
-
- when others =>
- raise Program_Error;
- end case;
-
- Start := Start + 1;
-
- Read_Only := False;
- Others_Allowed := False;
- Default := Empty_Value;
-
- if Initialization_Data (Start) = 'R' then
- Read_Only := True;
- Default := Read_Only_Value;
- Start := Start + 1;
-
- elsif Initialization_Data (Start) = 'O' then
- Others_Allowed := True;
- Start := Start + 1;
- end if;
-
- Finish := Start;
-
- while Initialization_Data (Finish) /= '#'
- and then
- Initialization_Data (Finish) /= 'D'
- loop
- Finish := Finish + 1;
- end loop;
-
- Attribute_Name :=
- Name_Id_Of (Initialization_Data (Start .. Finish - 1));
-
- if Initialization_Data (Finish) = 'D' then
- Start := Finish + 1;
-
- Finish := Start;
- while Initialization_Data (Finish) /= '#' loop
- Finish := Finish + 1;
- end loop;
-
- declare
- Default_Name : constant String :=
- Initialization_Data (Start .. Finish - 1);
- pragma Unsuppress (All_Checks);
- begin
- Default := Attribute_Default_Value'Value (Default_Name);
- exception
- when Constraint_Error =>
- Osint.Fail
- ("illegal default value """ &
- Default_Name &
- """ for attribute " &
- Get_Name_String (Attribute_Name));
- end;
- end if;
-
- Attrs.Increment_Last;
-
- if Current_Attribute = Empty_Attr then
- First_Attribute := Attrs.Last;
-
- if Current_Package /= Empty_Pkg then
- Package_Attributes.Table (Current_Package).First_Attribute
- := Attrs.Last;
- end if;
-
- else
- -- Check that there are no duplicate attributes
-
- for Index in First_Attribute .. Attrs.Last - 1 loop
- if Attribute_Name = Attrs.Table (Index).Name then
- Osint.Fail ("duplicate attribute """
- & Initialization_Data (Start .. Finish - 1)
- & """ in " & Attribute_Location);
- end if;
- end loop;
-
- Attrs.Table (Current_Attribute).Next :=
- Attrs.Last;
- end if;
-
- Current_Attribute := Attrs.Last;
- Attrs.Table (Current_Attribute) :=
- (Name => Attribute_Name,
- Var_Kind => Var_Kind,
- Optional_Index => Optional_Index,
- Attr_Kind => Attr_Kind,
- Read_Only => Read_Only,
- Others_Allowed => Others_Allowed,
- Default => Default,
- Next => Empty_Attr);
- Start := Finish + 1;
- end if;
- end loop;
-
- Initialized := True;
- end Initialize;
-
- ------------------
- -- Is_Read_Only --
- ------------------
-
- function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean is
- begin
- return Attrs.Table (Attribute.Value).Read_Only;
- end Is_Read_Only;
-
- ----------------
- -- Name_Id_Of --
- ----------------
-
- function Name_Id_Of (Name : String) return Name_Id is
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Name);
- To_Lower (Name_Buffer (1 .. Name_Len));
- return Name_Find;
- end Name_Id_Of;
-
- --------------------
- -- Next_Attribute --
- --------------------
-
- function Next_Attribute
- (After : Attribute_Node_Id) return Attribute_Node_Id
- is
- begin
- if After = Empty_Attribute then
- return Empty_Attribute;
- else
- return (Value => Attrs.Table (After.Value).Next);
- end if;
- end Next_Attribute;
-
- -----------------------
- -- Optional_Index_Of --
- -----------------------
-
- function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean is
- begin
- if Attribute = Empty_Attribute then
- return False;
- else
- return Attrs.Table (Attribute.Value).Optional_Index;
- end if;
- end Optional_Index_Of;
-
- function Others_Allowed_For
- (Attribute : Attribute_Node_Id) return Boolean
- is
- begin
- if Attribute = Empty_Attribute then
- return False;
- else
- return Attrs.Table (Attribute.Value).Others_Allowed;
- end if;
- end Others_Allowed_For;
-
- -----------------------
- -- Package_Name_List --
- -----------------------
-
- function Package_Name_List return Strings.String_List is
- begin
- return Package_Names (1 .. Last_Package_Name);
- end Package_Name_List;
-
- ------------------------
- -- Package_Node_Id_Of --
- ------------------------
-
- function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id is
- begin
- for Index in Package_Attributes.First .. Package_Attributes.Last loop
- if Package_Attributes.Table (Index).Name = Name then
- if Package_Attributes.Table (Index).Known then
- return (Value => Index);
- else
- return Unknown_Package;
- end if;
- end if;
- end loop;
-
- -- If there is no package with this name, return Empty_Package
-
- return Empty_Package;
- end Package_Node_Id_Of;
-
- ----------------------------
- -- Register_New_Attribute --
- ----------------------------
-
- procedure Register_New_Attribute
- (Name : String;
- In_Package : Package_Node_Id;
- Attr_Kind : Defined_Attribute_Kind;
- Var_Kind : Defined_Variable_Kind;
- Index_Is_File_Name : Boolean := False;
- Opt_Index : Boolean := False;
- Default : Attribute_Default_Value := Empty_Value)
- is
- Attr_Name : Name_Id;
- First_Attr : Attr_Node_Id := Empty_Attr;
- Curr_Attr : Attr_Node_Id;
- Real_Attr_Kind : Attribute_Kind;
-
- begin
- if Name'Length = 0 then
- Fail ("cannot register an attribute with no name");
- raise Project_Error;
- end if;
-
- if In_Package = Empty_Package then
- Fail ("attempt to add attribute """
- & Name
- & """ to an undefined package");
- raise Project_Error;
- end if;
-
- Attr_Name := Name_Id_Of (Name);
-
- First_Attr :=
- Package_Attributes.Table (In_Package.Value).First_Attribute;
-
- -- Check if attribute name is a duplicate
-
- Curr_Attr := First_Attr;
- while Curr_Attr /= Empty_Attr loop
- if Attrs.Table (Curr_Attr).Name = Attr_Name then
- Fail ("duplicate attribute name """
- & Name
- & """ in package """
- & Get_Name_String
- (Package_Attributes.Table (In_Package.Value).Name)
- & """");
- raise Project_Error;
- end if;
-
- Curr_Attr := Attrs.Table (Curr_Attr).Next;
- end loop;
-
- Real_Attr_Kind := Attr_Kind;
-
- -- If Index_Is_File_Name, change the attribute kind if necessary
-
- if Index_Is_File_Name and then not Osint.File_Names_Case_Sensitive then
- case Attr_Kind is
- when Associative_Array =>
- Real_Attr_Kind := Case_Insensitive_Associative_Array;
-
- when Optional_Index_Associative_Array =>
- Real_Attr_Kind :=
- Optional_Index_Case_Insensitive_Associative_Array;
-
- when others =>
- null;
- end case;
- end if;
-
- -- Add the new attribute
-
- Attrs.Increment_Last;
- Attrs.Table (Attrs.Last) :=
- (Name => Attr_Name,
- Var_Kind => Var_Kind,
- Optional_Index => Opt_Index,
- Attr_Kind => Real_Attr_Kind,
- Read_Only => False,
- Others_Allowed => False,
- Default => Default,
- Next => First_Attr);
-
- Package_Attributes.Table (In_Package.Value).First_Attribute :=
- Attrs.Last;
- end Register_New_Attribute;
-
- --------------------------
- -- Register_New_Package --
- --------------------------
-
- procedure Register_New_Package (Name : String; Id : out Package_Node_Id) is
- Pkg_Name : Name_Id;
- Found : Boolean := False;
-
- begin
- if Name'Length = 0 then
- Fail ("cannot register a package with no name");
- Id := Empty_Package;
- return;
- end if;
-
- Pkg_Name := Name_Id_Of (Name);
-
- for Index in Package_Attributes.First .. Package_Attributes.Last loop
- if Package_Attributes.Table (Index).Name = Pkg_Name then
- if Package_Attributes.Table (Index).Known then
- Fail ("cannot register a package with a non unique name """
- & Name
- & """");
- Id := Empty_Package;
- return;
-
- else
- Found := True;
- Id := (Value => Index);
- exit;
- end if;
- end if;
- end loop;
-
- if not Found then
- Package_Attributes.Increment_Last;
- Id := (Value => Package_Attributes.Last);
- end if;
-
- Package_Attributes.Table (Id.Value) :=
- (Name => Pkg_Name,
- Known => True,
- First_Attribute => Empty_Attr);
-
- Add_Package_Name (Get_Name_String (Pkg_Name));
- end Register_New_Package;
-
- procedure Register_New_Package
- (Name : String;
- Attributes : Attribute_Data_Array)
- is
- Pkg_Name : Name_Id;
- Attr_Name : Name_Id;
- First_Attr : Attr_Node_Id := Empty_Attr;
- Curr_Attr : Attr_Node_Id;
- Attr_Kind : Attribute_Kind;
-
- begin
- if Name'Length = 0 then
- Fail ("cannot register a package with no name");
- raise Project_Error;
- end if;
-
- Pkg_Name := Name_Id_Of (Name);
-
- for Index in Package_Attributes.First .. Package_Attributes.Last loop
- if Package_Attributes.Table (Index).Name = Pkg_Name then
- Fail ("cannot register a package with a non unique name """
- & Name
- & """");
- raise Project_Error;
- end if;
- end loop;
-
- for Index in Attributes'Range loop
- Attr_Name := Name_Id_Of (Attributes (Index).Name);
-
- Curr_Attr := First_Attr;
- while Curr_Attr /= Empty_Attr loop
- if Attrs.Table (Curr_Attr).Name = Attr_Name then
- Fail ("duplicate attribute name """
- & Attributes (Index).Name
- & """ in new package """
- & Name
- & """");
- raise Project_Error;
- end if;
-
- Curr_Attr := Attrs.Table (Curr_Attr).Next;
- end loop;
-
- Attr_Kind := Attributes (Index).Attr_Kind;
-
- if Attributes (Index).Index_Is_File_Name
- and then not Osint.File_Names_Case_Sensitive
- then
- case Attr_Kind is
- when Associative_Array =>
- Attr_Kind := Case_Insensitive_Associative_Array;
-
- when Optional_Index_Associative_Array =>
- Attr_Kind :=
- Optional_Index_Case_Insensitive_Associative_Array;
-
- when others =>
- null;
- end case;
- end if;
-
- Attrs.Increment_Last;
- Attrs.Table (Attrs.Last) :=
- (Name => Attr_Name,
- Var_Kind => Attributes (Index).Var_Kind,
- Optional_Index => Attributes (Index).Opt_Index,
- Attr_Kind => Attr_Kind,
- Read_Only => False,
- Others_Allowed => False,
- Default => Attributes (Index).Default,
- Next => First_Attr);
- First_Attr := Attrs.Last;
- end loop;
-
- Package_Attributes.Increment_Last;
- Package_Attributes.Table (Package_Attributes.Last) :=
- (Name => Pkg_Name,
- Known => True,
- First_Attribute => First_Attr);
-
- Add_Package_Name (Get_Name_String (Pkg_Name));
- end Register_New_Package;
-
- ---------------------------
- -- Set_Attribute_Kind_Of --
- ---------------------------
-
- procedure Set_Attribute_Kind_Of
- (Attribute : Attribute_Node_Id;
- To : Attribute_Kind)
- is
- begin
- if Attribute /= Empty_Attribute then
- Attrs.Table (Attribute.Value).Attr_Kind := To;
- end if;
- end Set_Attribute_Kind_Of;
-
- --------------------------
- -- Set_Variable_Kind_Of --
- --------------------------
-
- procedure Set_Variable_Kind_Of
- (Attribute : Attribute_Node_Id;
- To : Variable_Kind)
- is
- begin
- if Attribute /= Empty_Attribute then
- Attrs.Table (Attribute.Value).Var_Kind := To;
- end if;
- end Set_Variable_Kind_Of;
-
- ----------------------
- -- Variable_Kind_Of --
- ----------------------
-
- function Variable_Kind_Of
- (Attribute : Attribute_Node_Id) return Variable_Kind
- is
- begin
- if Attribute = Empty_Attribute then
- return Undefined;
- else
- return Attrs.Table (Attribute.Value).Var_Kind;
- end if;
- end Variable_Kind_Of;
-
- ------------------------
- -- First_Attribute_Of --
- ------------------------
-
- function First_Attribute_Of
- (Pkg : Package_Node_Id) return Attribute_Node_Id
- is
- begin
- if Pkg = Empty_Package or else Pkg = Unknown_Package then
- return Empty_Attribute;
- else
- return
- (Value => Package_Attributes.Table (Pkg.Value).First_Attribute);
- end if;
- end First_Attribute_Of;
-
-end Prj.Attr;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . A T T R --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package defines packages and attributes in GNAT project files.
--- There are predefined packages and attributes.
-
--- It is also possible to define new packages with their attributes
-
-with Table;
-
-with GNAT.Strings;
-
-package Prj.Attr is
-
- function Package_Name_List return GNAT.Strings.String_List;
- -- Returns the list of valid package names, including those added by
- -- procedures Register_New_Package below. The String_Access components of
- -- the returned String_List should never be freed.
-
- procedure Initialize;
- -- Initialize the predefined project level attributes and the predefined
- -- packages and their attribute. This procedure should be called by
- -- Prj.Initialize.
-
- type Attribute_Kind is (
- Unknown,
- -- The attribute does not exist
-
- Single,
- -- Single variable attribute (not an associative array)
-
- Associative_Array,
- -- Associative array attribute with a case sensitive index
-
- Optional_Index_Associative_Array,
- -- Associative array attribute with a case sensitive index and an
- -- optional source index.
-
- Case_Insensitive_Associative_Array,
- -- Associative array attribute with a case insensitive index
-
- Optional_Index_Case_Insensitive_Associative_Array
- -- Associative array attribute with a case insensitive index and an
- -- optional source index.
- );
- -- Characteristics of an attribute. Optional_Index indicates that there
- -- may be an optional index in the index of the associative array, as in
- -- for Switches ("files.ada" at 2) use ...
-
- subtype Defined_Attribute_Kind is Attribute_Kind
- range Single .. Optional_Index_Case_Insensitive_Associative_Array;
- -- Subset of Attribute_Kinds that may be used for the attributes that is
- -- used when defining a new package.
-
- subtype All_Case_Insensitive_Associative_Array is Attribute_Kind range
- Case_Insensitive_Associative_Array ..
- Optional_Index_Case_Insensitive_Associative_Array;
- -- Subtype including both cases of Case_Insensitive_Associative_Array
-
- Max_Attribute_Name_Length : constant := 64;
- -- The maximum length of attribute names
-
- subtype Attribute_Name_Length is
- Positive range 1 .. Max_Attribute_Name_Length;
-
- type Attribute_Data (Name_Length : Attribute_Name_Length := 1) is record
- Name : String (1 .. Name_Length);
- pragma Warnings (Off, Name); -- Reorder it instead???
- -- The name of the attribute
-
- Attr_Kind : Defined_Attribute_Kind;
- -- The type of the attribute
-
- Index_Is_File_Name : Boolean;
- -- For associative arrays, indicate if the index is a file name, so
- -- that the attribute kind may be modified depending on the case
- -- sensitivity of file names. This is only taken into account when
- -- Attr_Kind is Associative_Array or Optional_Index_Associative_Array.
-
- Opt_Index : Boolean;
- -- True if there may be an optional index in the value of the index,
- -- as in:
- -- "file.ada" at 2
- -- ("main.adb", "file.ada" at 1)
-
- Var_Kind : Defined_Variable_Kind;
- -- The attribute value kind: single or list
-
- Default : Attribute_Default_Value := Empty_Value;
- -- The value of the attribute when referenced if the attribute has not
- -- yet been declared.
-
- end record;
- -- Name and characteristics of an attribute in a package registered
- -- explicitly with Register_New_Package (see below).
-
- type Attribute_Data_Array is array (Positive range <>) of Attribute_Data;
- -- A list of attribute name/characteristics to be used as parameter of
- -- procedure Register_New_Package below.
-
- -- In the subprograms below, when it is specified that the subprogram
- -- "fails", procedure Prj.Com.Fail is called. Unless it is specified
- -- otherwise, if Prj.Com.Fail returns, exception Prj.Prj_Error is raised.
-
- procedure Register_New_Package
- (Name : String;
- Attributes : Attribute_Data_Array);
- -- Add a new package with its attributes. This procedure can only be
- -- called after Initialize, but before any other call to a service of
- -- the Project Manager. Fail if the name of the package is empty or not
- -- unique, or if the names of the attributes are not different.
-
- ----------------
- -- Attributes --
- ----------------
-
- type Attribute_Node_Id is private;
- -- The type to refers to an attribute, self-initialized
-
- Empty_Attribute : constant Attribute_Node_Id;
- -- Indicates no attribute. Default value of Attribute_Node_Id objects
-
- Attribute_First : constant Attribute_Node_Id;
- -- First attribute node id of project level attributes
-
- function Attribute_Node_Id_Of
- (Name : Name_Id;
- Starting_At : Attribute_Node_Id) return Attribute_Node_Id;
- -- Returns the node id of an attribute at the project level or in
- -- a package. Starting_At indicates the first known attribute node where
- -- to start the search. Returns Empty_Attribute if the attribute cannot
- -- be found.
-
- function Attribute_Kind_Of
- (Attribute : Attribute_Node_Id) return Attribute_Kind;
- -- Returns the attribute kind of a known attribute. Returns Unknown if
- -- Attribute is Empty_Attribute.
- --
- -- To use this function, the following code should be used:
- --
- -- Pkg : constant Package_Node_Id :=
- -- Prj.Attr.Package_Node_Id_Of (Name => <package name>);
- -- Att : constant Attribute_Node_Id :=
- -- Prj.Attr.Attribute_Node_Id_Of
- -- (Name => <attribute name>,
- -- Starting_At => First_Attribute_Of (Pkg));
- -- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att);
- --
- -- However, do not use this function once you have an already parsed
- -- project tree. Instead, given a Project_Node_Id corresponding to the
- -- attribute declaration ("for Attr (index) use ..."), use for example:
- --
- -- if Case_Insensitive (Attr, Tree) then ...
-
- procedure Set_Attribute_Kind_Of
- (Attribute : Attribute_Node_Id;
- To : Attribute_Kind);
- -- Set the attribute kind of a known attribute. Does nothing if
- -- Attribute is Empty_Attribute.
-
- function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id;
- -- Returns the name of a known attribute. Returns No_Name if Attribute is
- -- Empty_Attribute.
-
- function Variable_Kind_Of
- (Attribute : Attribute_Node_Id) return Variable_Kind;
- -- Returns the variable kind of a known attribute. Returns Undefined if
- -- Attribute is Empty_Attribute.
-
- procedure Set_Variable_Kind_Of
- (Attribute : Attribute_Node_Id;
- To : Variable_Kind);
- -- Set the variable kind of a known attribute. Does nothing if Attribute is
- -- Empty_Attribute.
-
- function Attribute_Default_Of
- (Attribute : Attribute_Node_Id) return Attribute_Default_Value;
- -- Returns the default of the attribute, Read_Only_Value for read only
- -- attributes, Empty_Value when default not specified, or specified value.
-
- function Optional_Index_Of (Attribute : Attribute_Node_Id) return Boolean;
- -- Returns True if Attribute is a known attribute and may have an
- -- optional index. Returns False otherwise.
-
- function Is_Read_Only (Attribute : Attribute_Node_Id) return Boolean;
-
- function Next_Attribute
- (After : Attribute_Node_Id) return Attribute_Node_Id;
- -- Returns the attribute that follow After in the list of project level
- -- attributes or the list of attributes in a package.
- -- Returns Empty_Attribute if After is either Empty_Attribute or is the
- -- last of the list.
-
- function Others_Allowed_For (Attribute : Attribute_Node_Id) return Boolean;
- -- True iff the index for an associative array attributes may be others
-
- --------------
- -- Packages --
- --------------
-
- type Package_Node_Id is private;
- -- Type to refer to a package, self initialized
-
- Empty_Package : constant Package_Node_Id;
- -- Default value of Package_Node_Id objects
-
- Unknown_Package : constant Package_Node_Id;
- -- Value of an unknown package that has been found but is unknown
-
- procedure Register_New_Package (Name : String; Id : out Package_Node_Id);
- -- Add a new package. Fails if Name (the package name) is empty or is
- -- already the name of a package, and set Id to Empty_Package,
- -- if Prj.Com.Fail returns. Initially, the new package has no attributes.
- -- Id may be used to add attributes using procedure Register_New_Attribute
- -- below.
-
- procedure Register_New_Attribute
- (Name : String;
- In_Package : Package_Node_Id;
- Attr_Kind : Defined_Attribute_Kind;
- Var_Kind : Defined_Variable_Kind;
- Index_Is_File_Name : Boolean := False;
- Opt_Index : Boolean := False;
- Default : Attribute_Default_Value := Empty_Value);
- -- Add a new attribute to registered package In_Package. Fails if Name
- -- (the attribute name) is empty, if In_Package is Empty_Package or if
- -- the attribute name has a duplicate name. See definition of type
- -- Attribute_Data above for the meaning of parameters Attr_Kind, Var_Kind,
- -- Index_Is_File_Name, Opt_Index, and Default.
-
- function Package_Node_Id_Of (Name : Name_Id) return Package_Node_Id;
- -- Returns the package node id of the package with name Name. Returns
- -- Empty_Package if there is no package with this name.
-
- function First_Attribute_Of
- (Pkg : Package_Node_Id) return Attribute_Node_Id;
- -- Returns the first attribute in the list of attributes of package Pkg.
- -- Returns Empty_Attribute if Pkg is Empty_Package or Unknown_Package.
-
-private
- ----------------
- -- Attributes --
- ----------------
-
- Attributes_Initial : constant := 50;
- Attributes_Increment : constant := 100;
-
- Attribute_Node_Low_Bound : constant := 0;
- Attribute_Node_High_Bound : constant := 099_999_999;
-
- type Attr_Node_Id is
- range Attribute_Node_Low_Bound .. Attribute_Node_High_Bound;
- -- Index type for table Attrs in the body
-
- type Attribute_Node_Id is record
- Value : Attr_Node_Id := Attribute_Node_Low_Bound;
- end record;
- -- Full declaration of self-initialized private type
-
- Empty_Attr : constant Attr_Node_Id := Attribute_Node_Low_Bound;
-
- Empty_Attribute : constant Attribute_Node_Id := (Value => Empty_Attr);
-
- First_Attribute : constant Attr_Node_Id := Attribute_Node_Low_Bound + 1;
-
- First_Attribute_Node_Id : constant Attribute_Node_Id :=
- (Value => First_Attribute);
-
- Attribute_First : constant Attribute_Node_Id := First_Attribute_Node_Id;
-
- --------------
- -- Packages --
- --------------
-
- Packages_Initial : constant := 10;
- Packages_Increment : constant := 100;
-
- Package_Node_Low_Bound : constant := 0;
- Package_Node_High_Bound : constant := 099_999_999;
-
- type Pkg_Node_Id is
- range Package_Node_Low_Bound .. Package_Node_High_Bound;
- -- Index type for table Package_Attributes in the body
-
- type Package_Node_Id is record
- Value : Pkg_Node_Id := Package_Node_Low_Bound;
- end record;
- -- Full declaration of self-initialized private type
-
- Empty_Pkg : constant Pkg_Node_Id := Package_Node_Low_Bound;
- Empty_Package : constant Package_Node_Id := (Value => Empty_Pkg);
- Unknown_Pkg : constant Pkg_Node_Id := Package_Node_High_Bound;
- Unknown_Package : constant Package_Node_Id := (Value => Unknown_Pkg);
- First_Package : constant Pkg_Node_Id := Package_Node_Low_Bound + 1;
-
- First_Package_Node_Id : constant Package_Node_Id :=
- (Value => First_Package);
-
- Package_First : constant Package_Node_Id := First_Package_Node_Id;
-
- ----------------
- -- Attributes --
- ----------------
-
- type Attribute_Record is record
- Name : Name_Id;
- Var_Kind : Variable_Kind;
- Optional_Index : Boolean;
- Attr_Kind : Attribute_Kind;
- Read_Only : Boolean;
- Others_Allowed : Boolean;
- Default : Attribute_Default_Value;
- Next : Attr_Node_Id;
- end record;
- -- Data for an attribute
-
- package Attrs is
- new Table.Table (Table_Component_Type => Attribute_Record,
- Table_Index_Type => Attr_Node_Id,
- Table_Low_Bound => First_Attribute,
- Table_Initial => Attributes_Initial,
- Table_Increment => Attributes_Increment,
- Table_Name => "Prj.Attr.Attrs");
- -- The table of the attributes
-
- --------------
- -- Packages --
- --------------
-
- type Package_Record is record
- Name : Name_Id;
- Known : Boolean := True;
- First_Attribute : Attr_Node_Id;
- end record;
- -- Data for a package
-
- package Package_Attributes is
- new Table.Table (Table_Component_Type => Package_Record,
- Table_Index_Type => Pkg_Node_Id,
- Table_Low_Bound => First_Package,
- Table_Initial => Packages_Initial,
- Table_Increment => Packages_Increment,
- Table_Name => "Prj.Attr.Packages");
- -- The table of the packages
-
-end Prj.Attr;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . C O M --
--- --
--- S p e c --
--- --
--- Copyright (C) 2000-2008, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- The following package declares a Fail procedure that is used in the
--- Project Manager.
-
-with Osint;
-
-package Prj.Com is
-
- type Fail_Proc is access procedure (S : String);
-
- Fail : Fail_Proc := Osint.Fail'Access;
- -- This procedure is used in the project facility, instead of directly
- -- calling Osint.Fail. It may be specified by tools to do clean up before
- -- calling Osint.Fail, or to simply report an error and return.
-
-end Prj.Com;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . C O N F --
--- --
--- B o d y --
--- --
--- Copyright (C) 2006-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Makeutl; use Makeutl;
-with MLib.Tgt;
-with Opt; use Opt;
-with Output; use Output;
-with Prj.Env;
-with Prj.Err;
-with Prj.Part;
-with Prj.PP;
-with Prj.Proc; use Prj.Proc;
-with Prj.Tree; use Prj.Tree;
-with Prj.Util; use Prj.Util;
-with Prj; use Prj;
-with Snames; use Snames;
-
-with Ada.Directories; use Ada.Directories;
-with Ada.Exceptions; use Ada.Exceptions;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.HTable; use GNAT.HTable;
-
-package body Prj.Conf is
-
- Auto_Cgpr : constant String := "auto.cgpr";
-
- Config_Project_Env_Var : constant String := "GPR_CONFIG";
- -- Name of the environment variable that provides the name of the
- -- configuration file to use.
-
- Gprconfig_Name : constant String := "gprconfig";
-
- Warn_For_RTS : Boolean := True;
- -- Set to False when gprbuild parse again the project files, to avoid
- -- an incorrect warning.
-
- type Runtime_Root_Data;
- type Runtime_Root_Ptr is access Runtime_Root_Data;
- type Runtime_Root_Data is record
- Root : String_Access;
- Next : Runtime_Root_Ptr;
- end record;
- -- Data for a runtime root to be used when adding directories to the
- -- project path.
-
- type Compiler_Root_Data;
- type Compiler_Root_Ptr is access Compiler_Root_Data;
- type Compiler_Root_Data is record
- Root : String_Access;
- Runtimes : Runtime_Root_Ptr;
- Next : Compiler_Root_Ptr;
- end record;
- -- Data for a compiler root to be used when adding directories to the
- -- project path.
-
- First_Compiler_Root : Compiler_Root_Ptr := null;
- -- Head of the list of compiler roots
-
- package RTS_Languages is new GNAT.HTable.Simple_HTable
- (Header_Num => Prj.Header_Num,
- Element => Name_Id,
- No_Element => No_Name,
- Key => Name_Id,
- Hash => Prj.Hash,
- Equal => "=");
- -- Stores the runtime names for the various languages. This is in general
- -- set from a --RTS command line option.
-
- -----------------------
- -- Local_Subprograms --
- -----------------------
-
- function Check_Target
- (Config_File : Prj.Project_Id;
- Autoconf_Specified : Boolean;
- Project_Tree : Prj.Project_Tree_Ref;
- Target : String := "") return Boolean;
- -- Check that the config file's target matches Target.
- -- Target should be set to the empty string when the user did not specify
- -- a target. If the target in the configuration file is invalid, this
- -- function will raise Invalid_Config with an appropriate message.
- -- Autoconf_Specified should be set to True if the user has used
- -- autoconf.
-
- function Locate_Config_File (Name : String) return String_Access;
- -- Search for Name in the config files directory. Return full path if
- -- found, or null otherwise.
-
- procedure Raise_Invalid_Config (Msg : String);
- pragma No_Return (Raise_Invalid_Config);
- -- Raises exception Invalid_Config with given message
-
- procedure Apply_Config_File
- (Config_File : Prj.Project_Id;
- Project_Tree : Prj.Project_Tree_Ref);
- -- Apply the configuration file settings to all the projects in the
- -- project tree. The Project_Tree must have been parsed first, and
- -- processed through the first phase so that all its projects are known.
- --
- -- Currently, this will add new attributes and packages in the various
- -- projects, so that when the second phase of the processing is performed
- -- these attributes are automatically taken into account.
-
- type State is (No_State);
-
- procedure Look_For_Project_Paths
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out State);
- -- Check the compilers in the Project and add record them in the list
- -- rooted at First_Compiler_Root, with their runtimes, if they are not
- -- already in the list.
-
- procedure Update_Project_Path is new
- For_Every_Project_Imported
- (State => State,
- Action => Look_For_Project_Paths);
-
- ------------------------------------
- -- Add_Default_GNAT_Naming_Scheme --
- ------------------------------------
-
- procedure Add_Default_GNAT_Naming_Scheme
- (Config_File : in out Project_Node_Id;
- Project_Tree : Project_Node_Tree_Ref)
- is
- procedure Create_Attribute
- (Name : Name_Id;
- Value : String;
- Index : String := "";
- Pkg : Project_Node_Id := Empty_Node);
-
- ----------------------
- -- Create_Attribute --
- ----------------------
-
- procedure Create_Attribute
- (Name : Name_Id;
- Value : String;
- Index : String := "";
- Pkg : Project_Node_Id := Empty_Node)
- is
- Attr : Project_Node_Id;
- pragma Unreferenced (Attr);
-
- Expr : Name_Id := No_Name;
- Val : Name_Id := No_Name;
- Parent : Project_Node_Id := Config_File;
-
- begin
- if Index /= "" then
- Name_Len := Index'Length;
- Name_Buffer (1 .. Name_Len) := Index;
- Val := Name_Find;
- end if;
-
- if Pkg /= Empty_Node then
- Parent := Pkg;
- end if;
-
- Name_Len := Value'Length;
- Name_Buffer (1 .. Name_Len) := Value;
- Expr := Name_Find;
-
- Attr := Create_Attribute
- (Tree => Project_Tree,
- Prj_Or_Pkg => Parent,
- Name => Name,
- Index_Name => Val,
- Kind => Prj.Single,
- Value => Create_Literal_String (Expr, Project_Tree));
- end Create_Attribute;
-
- -- Local variables
-
- Name : Name_Id;
- Naming : Project_Node_Id;
- Compiler : Project_Node_Id;
-
- -- Start of processing for Add_Default_GNAT_Naming_Scheme
-
- begin
- if Config_File = Empty_Node then
-
- -- Create a dummy config file if none was found
-
- Name_Len := Auto_Cgpr'Length;
- Name_Buffer (1 .. Name_Len) := Auto_Cgpr;
- Name := Name_Find;
-
- -- An invalid project name to avoid conflicts with user-created ones
-
- Name_Len := 5;
- Name_Buffer (1 .. Name_Len) := "_auto";
-
- Config_File :=
- Create_Project
- (In_Tree => Project_Tree,
- Name => Name_Find,
- Full_Path => Path_Name_Type (Name),
- Is_Config_File => True);
-
- -- Setup library support
-
- case MLib.Tgt.Support_For_Libraries is
- when None =>
- null;
-
- when Static_Only =>
- Create_Attribute (Name_Library_Support, "static_only");
-
- when Full =>
- Create_Attribute (Name_Library_Support, "full");
- end case;
-
- if MLib.Tgt.Standalone_Library_Auto_Init_Is_Supported then
- Create_Attribute (Name_Library_Auto_Init_Supported, "true");
- else
- Create_Attribute (Name_Library_Auto_Init_Supported, "false");
- end if;
-
- -- Declare an empty target
-
- Create_Attribute (Name_Target, "");
-
- -- Setup Ada support (Ada is the default language here, since this
- -- is only called when no config file existed initially, ie for
- -- gnatmake).
-
- Create_Attribute (Name_Default_Language, "ada");
-
- Compiler := Create_Package (Project_Tree, Config_File, "compiler");
- Create_Attribute
- (Name_Driver, "gcc", "ada", Pkg => Compiler);
- Create_Attribute
- (Name_Language_Kind, "unit_based", "ada", Pkg => Compiler);
- Create_Attribute
- (Name_Dependency_Kind, "ALI_File", "ada", Pkg => Compiler);
-
- Naming := Create_Package (Project_Tree, Config_File, "naming");
- Create_Attribute (Name_Spec_Suffix, ".ads", "ada", Pkg => Naming);
- Create_Attribute (Name_Separate_Suffix, ".adb", "ada", Pkg => Naming);
- Create_Attribute (Name_Body_Suffix, ".adb", "ada", Pkg => Naming);
- Create_Attribute (Name_Dot_Replacement, "-", Pkg => Naming);
- Create_Attribute (Name_Casing, "lowercase", Pkg => Naming);
-
- if Current_Verbosity = High then
- Write_Line ("Automatically generated (in-memory) config file");
- Prj.PP.Pretty_Print
- (Project => Config_File,
- In_Tree => Project_Tree,
- Backward_Compatibility => False);
- end if;
- end if;
- end Add_Default_GNAT_Naming_Scheme;
-
- -----------------------
- -- Apply_Config_File --
- -----------------------
-
- procedure Apply_Config_File
- (Config_File : Prj.Project_Id;
- Project_Tree : Prj.Project_Tree_Ref)
- is
- procedure Add_Attributes
- (Project_Tree : Project_Tree_Ref;
- Conf_Decl : Declarations;
- User_Decl : in out Declarations);
- -- Process the attributes in the config declarations. For
- -- single string values, if the attribute is not declared in
- -- the user declarations, declare it with the value in the
- -- config declarations. For string list values, prepend the
- -- value in the user declarations with the value in the config
- -- declarations.
-
- --------------------
- -- Add_Attributes --
- --------------------
-
- procedure Add_Attributes
- (Project_Tree : Project_Tree_Ref;
- Conf_Decl : Declarations;
- User_Decl : in out Declarations)
- is
- Shared : constant Shared_Project_Tree_Data_Access :=
- Project_Tree.Shared;
- Conf_Attr_Id : Variable_Id;
- Conf_Attr : Variable;
- Conf_Array_Id : Array_Id;
- Conf_Array : Array_Data;
- Conf_Array_Elem_Id : Array_Element_Id;
- Conf_Array_Elem : Array_Element;
- Conf_List : String_List_Id;
- Conf_List_Elem : String_Element;
-
- User_Attr_Id : Variable_Id;
- User_Attr : Variable;
- User_Array_Id : Array_Id;
- User_Array : Array_Data;
- User_Array_Elem_Id : Array_Element_Id;
- User_Array_Elem : Array_Element;
-
- begin
- Conf_Attr_Id := Conf_Decl.Attributes;
- User_Attr_Id := User_Decl.Attributes;
-
- while Conf_Attr_Id /= No_Variable loop
- Conf_Attr := Shared.Variable_Elements.Table (Conf_Attr_Id);
- User_Attr := Shared.Variable_Elements.Table (User_Attr_Id);
-
- if not Conf_Attr.Value.Default then
- if User_Attr.Value.Default then
-
- -- No attribute declared in user project file: just copy
- -- the value of the configuration attribute.
-
- User_Attr.Value := Conf_Attr.Value;
- Shared.Variable_Elements.Table (User_Attr_Id) := User_Attr;
-
- elsif User_Attr.Value.Kind = List
- and then Conf_Attr.Value.Values /= Nil_String
- then
- -- List attribute declared in both the user project and the
- -- configuration project: prepend the user list with the
- -- configuration list.
-
- declare
- User_List : constant String_List_Id :=
- User_Attr.Value.Values;
- Conf_List : String_List_Id := Conf_Attr.Value.Values;
- Conf_Elem : String_Element;
- New_List : String_List_Id;
- New_Elem : String_Element;
-
- begin
- -- Create new list
-
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
- New_List :=
- String_Element_Table.Last (Shared.String_Elements);
-
- -- Value of attribute is new list
-
- User_Attr.Value.Values := New_List;
- Shared.Variable_Elements.Table (User_Attr_Id) :=
- User_Attr;
-
- loop
- -- Get each element of configuration list
-
- Conf_Elem := Shared.String_Elements.Table (Conf_List);
- New_Elem := Conf_Elem;
- Conf_List := Conf_Elem.Next;
-
- if Conf_List = Nil_String then
-
- -- If it is the last element in the list, connect
- -- to first element of user list, and we are done.
-
- New_Elem.Next := User_List;
- Shared.String_Elements.Table (New_List) := New_Elem;
- exit;
-
- else
- -- If it is not the last element in the list, add
- -- to new list.
-
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
- New_Elem.Next := String_Element_Table.Last
- (Shared.String_Elements);
- Shared.String_Elements.Table (New_List) := New_Elem;
- New_List := New_Elem.Next;
- end if;
- end loop;
- end;
- end if;
- end if;
-
- Conf_Attr_Id := Conf_Attr.Next;
- User_Attr_Id := User_Attr.Next;
- end loop;
-
- Conf_Array_Id := Conf_Decl.Arrays;
- while Conf_Array_Id /= No_Array loop
- Conf_Array := Shared.Arrays.Table (Conf_Array_Id);
-
- User_Array_Id := User_Decl.Arrays;
- while User_Array_Id /= No_Array loop
- User_Array := Shared.Arrays.Table (User_Array_Id);
- exit when User_Array.Name = Conf_Array.Name;
- User_Array_Id := User_Array.Next;
- end loop;
-
- -- If this associative array does not exist in the user project
- -- file, do a shallow copy of the full associative array.
-
- if User_Array_Id = No_Array then
- Array_Table.Increment_Last (Shared.Arrays);
- User_Array := Conf_Array;
- User_Array.Next := User_Decl.Arrays;
- User_Decl.Arrays := Array_Table.Last (Shared.Arrays);
- Shared.Arrays.Table (User_Decl.Arrays) := User_Array;
-
- -- Otherwise, check each array element
-
- else
- Conf_Array_Elem_Id := Conf_Array.Value;
- while Conf_Array_Elem_Id /= No_Array_Element loop
- Conf_Array_Elem :=
- Shared.Array_Elements.Table (Conf_Array_Elem_Id);
-
- User_Array_Elem_Id := User_Array.Value;
- while User_Array_Elem_Id /= No_Array_Element loop
- User_Array_Elem :=
- Shared.Array_Elements.Table (User_Array_Elem_Id);
- exit when User_Array_Elem.Index = Conf_Array_Elem.Index;
- User_Array_Elem_Id := User_Array_Elem.Next;
- end loop;
-
- -- If the array element doesn't exist in the user array,
- -- insert a shallow copy of the conf array element in the
- -- user array.
-
- if User_Array_Elem_Id = No_Array_Element then
- Array_Element_Table.Increment_Last
- (Shared.Array_Elements);
- User_Array_Elem := Conf_Array_Elem;
- User_Array_Elem.Next := User_Array.Value;
- User_Array.Value :=
- Array_Element_Table.Last (Shared.Array_Elements);
- Shared.Array_Elements.Table (User_Array.Value) :=
- User_Array_Elem;
- Shared.Arrays.Table (User_Array_Id) := User_Array;
-
- -- Otherwise, if the value is a string list, prepend the
- -- conf array element value to the array element.
-
- elsif Conf_Array_Elem.Value.Kind = List then
- Conf_List := Conf_Array_Elem.Value.Values;
-
- if Conf_List /= Nil_String then
- declare
- Link : constant String_List_Id :=
- User_Array_Elem.Value.Values;
- Previous : String_List_Id := Nil_String;
- Next : String_List_Id;
-
- begin
- loop
- Conf_List_Elem :=
- Shared.String_Elements.Table (Conf_List);
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
- Next :=
- String_Element_Table.Last
- (Shared.String_Elements);
- Shared.String_Elements.Table (Next) :=
- Conf_List_Elem;
-
- if Previous = Nil_String then
- User_Array_Elem.Value.Values := Next;
- Shared.Array_Elements.Table
- (User_Array_Elem_Id) := User_Array_Elem;
-
- else
- Shared.String_Elements.Table
- (Previous).Next := Next;
- end if;
-
- Previous := Next;
-
- Conf_List := Conf_List_Elem.Next;
-
- if Conf_List = Nil_String then
- Shared.String_Elements.Table
- (Previous).Next := Link;
- exit;
- end if;
- end loop;
- end;
- end if;
- end if;
-
- Conf_Array_Elem_Id := Conf_Array_Elem.Next;
- end loop;
- end if;
-
- Conf_Array_Id := Conf_Array.Next;
- end loop;
- end Add_Attributes;
-
- Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
-
- Conf_Decl : constant Declarations := Config_File.Decl;
- Conf_Pack_Id : Package_Id;
- Conf_Pack : Package_Element;
-
- User_Decl : Declarations;
- User_Pack_Id : Package_Id;
- User_Pack : Package_Element;
- Proj : Project_List;
-
- begin
- Debug_Output ("Applying config file to a project tree");
-
- Proj := Project_Tree.Projects;
- while Proj /= null loop
- if Proj.Project /= Config_File then
- User_Decl := Proj.Project.Decl;
- Add_Attributes
- (Project_Tree => Project_Tree,
- Conf_Decl => Conf_Decl,
- User_Decl => User_Decl);
-
- Conf_Pack_Id := Conf_Decl.Packages;
- while Conf_Pack_Id /= No_Package loop
- Conf_Pack := Shared.Packages.Table (Conf_Pack_Id);
-
- User_Pack_Id := User_Decl.Packages;
- while User_Pack_Id /= No_Package loop
- User_Pack := Shared.Packages.Table (User_Pack_Id);
- exit when User_Pack.Name = Conf_Pack.Name;
- User_Pack_Id := User_Pack.Next;
- end loop;
-
- if User_Pack_Id = No_Package then
- Package_Table.Increment_Last (Shared.Packages);
- User_Pack := Conf_Pack;
- User_Pack.Next := User_Decl.Packages;
- User_Decl.Packages := Package_Table.Last (Shared.Packages);
- Shared.Packages.Table (User_Decl.Packages) := User_Pack;
-
- else
- Add_Attributes
- (Project_Tree => Project_Tree,
- Conf_Decl => Conf_Pack.Decl,
- User_Decl => Shared.Packages.Table
- (User_Pack_Id).Decl);
- end if;
-
- Conf_Pack_Id := Conf_Pack.Next;
- end loop;
-
- Proj.Project.Decl := User_Decl;
-
- -- For aggregate projects, we need to apply the config to all
- -- their aggregated trees as well.
-
- if Proj.Project.Qualifier in Aggregate_Project then
- declare
- List : Aggregated_Project_List;
- begin
- List := Proj.Project.Aggregated_Projects;
- while List /= null loop
- Debug_Output
- ("Recursively apply config to aggregated tree",
- List.Project.Name);
- Apply_Config_File
- (Config_File, Project_Tree => List.Tree);
- List := List.Next;
- end loop;
- end;
- end if;
- end if;
-
- Proj := Proj.Next;
- end loop;
- end Apply_Config_File;
-
- ------------------
- -- Check_Target --
- ------------------
-
- function Check_Target
- (Config_File : Project_Id;
- Autoconf_Specified : Boolean;
- Project_Tree : Prj.Project_Tree_Ref;
- Target : String := "") return Boolean
- is
- Shared : constant Shared_Project_Tree_Data_Access :=
- Project_Tree.Shared;
- Variable : constant Variable_Value :=
- Value_Of
- (Name_Target, Config_File.Decl.Attributes, Shared);
- Tgt_Name : Name_Id := No_Name;
- OK : Boolean;
-
- begin
- if Variable /= Nil_Variable_Value and then not Variable.Default then
- Tgt_Name := Variable.Value;
- end if;
-
- OK :=
- Target = ""
- or else
- (Tgt_Name /= No_Name
- and then (Length_Of_Name (Tgt_Name) = 0
- or else Target = Get_Name_String (Tgt_Name)));
-
- if not OK then
- if Autoconf_Specified then
- if Verbose_Mode then
- Write_Line ("inconsistent targets, performing autoconf");
- end if;
-
- return False;
-
- else
- if Tgt_Name /= No_Name then
- Raise_Invalid_Config
- ("mismatched targets: """
- & Get_Name_String (Tgt_Name) & """ in configuration, """
- & Target & """ specified");
- else
- Raise_Invalid_Config
- ("no target specified in configuration file");
- end if;
- end if;
- end if;
-
- return True;
- end Check_Target;
-
- --------------------------------------
- -- Get_Or_Create_Configuration_File --
- --------------------------------------
-
- procedure Get_Or_Create_Configuration_File
- (Project : Project_Id;
- Conf_Project : Project_Id;
- Project_Tree : Project_Tree_Ref;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Allow_Automatic_Generation : Boolean;
- Config_File_Name : String := "";
- Autoconf_Specified : Boolean;
- Target_Name : String := "";
- Normalized_Hostname : String;
- Packages_To_Check : String_List_Access := null;
- Config : out Prj.Project_Id;
- Config_File_Path : out String_Access;
- Automatically_Generated : out Boolean;
- On_Load_Config : Config_File_Hook := null)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Project_Tree.Shared;
-
- At_Least_One_Compiler_Command : Boolean := False;
- -- Set to True if at least one attribute Ide'Compiler_Command is
- -- specified for one language of the system.
-
- Conf_File_Name : String_Access := new String'(Config_File_Name);
- -- The configuration project file name. May be modified if there are
- -- switches --config= in the Builder package of the main project.
-
- Selected_Target : String_Access := new String'(Target_Name);
-
- function Default_File_Name return String;
- -- Return the name of the default config file that should be tested
-
- procedure Do_Autoconf;
- -- Generate a new config file through gprconfig. In case of error, this
- -- raises the Invalid_Config exception with an appropriate message
-
- procedure Check_Builder_Switches;
- -- Check for switches --config and --RTS in package Builder
-
- procedure Get_Project_Target;
- -- If Target_Name is empty, get the specified target in the project
- -- file, if any.
-
- procedure Get_Project_Runtimes;
- -- Get the various Runtime (<lang>) in the project file or any project
- -- it extends, if any are specified.
-
- function Get_Config_Switches return Argument_List_Access;
- -- Return the --config switches to use for gprconfig
-
- function Get_Db_Switches return Argument_List_Access;
- -- Return the --db switches to use for gprconfig
-
- function Might_Have_Sources (Project : Project_Id) return Boolean;
- -- True if the specified project might have sources (ie the user has not
- -- explicitly specified it. We haven't checked the file system, nor do
- -- we need to at this stage.
-
- ----------------------------
- -- Check_Builder_Switches --
- ----------------------------
-
- procedure Check_Builder_Switches is
- Get_RTS_Switches : constant Boolean :=
- RTS_Languages.Get_First = No_Name;
- -- If no switch --RTS have been specified on the command line, look
- -- for --RTS switches in the Builder switches.
-
- Builder : constant Package_Id :=
- Value_Of (Name_Builder, Project.Decl.Packages, Shared);
-
- Switch_Array_Id : Array_Element_Id;
- -- The Switches to be checked
-
- procedure Check_Switches;
- -- Check the switches in Switch_Array_Id
-
- --------------------
- -- Check_Switches --
- --------------------
-
- procedure Check_Switches is
- Switch_Array : Array_Element;
- Switch_List : String_List_Id := Nil_String;
- Switch : String_Element;
- Lang : Name_Id;
- Lang_Last : Positive;
-
- begin
- while Switch_Array_Id /= No_Array_Element loop
- Switch_Array :=
- Shared.Array_Elements.Table (Switch_Array_Id);
-
- Switch_List := Switch_Array.Value.Values;
- List_Loop : while Switch_List /= Nil_String loop
- Switch := Shared.String_Elements.Table (Switch_List);
-
- if Switch.Value /= No_Name then
- Get_Name_String (Switch.Value);
-
- if Conf_File_Name'Length = 0
- and then Name_Len > 9
- and then Name_Buffer (1 .. 9) = "--config="
- then
- Conf_File_Name :=
- new String'(Name_Buffer (10 .. Name_Len));
-
- elsif Get_RTS_Switches
- and then Name_Len >= 7
- and then Name_Buffer (1 .. 5) = "--RTS"
- then
- if Name_Buffer (6) = '=' then
- if not Runtime_Name_Set_For (Name_Ada) then
- Set_Runtime_For
- (Name_Ada,
- Name_Buffer (7 .. Name_Len));
- end if;
-
- elsif Name_Len > 7
- and then Name_Buffer (6) = ':'
- and then Name_Buffer (7) /= '='
- then
- Lang_Last := 7;
- while Lang_Last < Name_Len
- and then Name_Buffer (Lang_Last + 1) /= '='
- loop
- Lang_Last := Lang_Last + 1;
- end loop;
-
- if Name_Buffer (Lang_Last + 1) = '=' then
- declare
- RTS : constant String :=
- Name_Buffer (Lang_Last + 2 .. Name_Len);
- begin
- Name_Buffer (1 .. Lang_Last - 6) :=
- Name_Buffer (7 .. Lang_Last);
- Name_Len := Lang_Last - 6;
- To_Lower (Name_Buffer (1 .. Name_Len));
- Lang := Name_Find;
-
- if not Runtime_Name_Set_For (Lang) then
- Set_Runtime_For (Lang, RTS);
- end if;
- end;
- end if;
- end if;
- end if;
- end if;
-
- Switch_List := Switch.Next;
- end loop List_Loop;
-
- Switch_Array_Id := Switch_Array.Next;
- end loop;
- end Check_Switches;
-
- -- Start of processing for Check_Builder_Switches
-
- begin
- if Builder /= No_Package then
- Switch_Array_Id :=
- Value_Of
- (Name => Name_Switches,
- In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
- Shared => Shared);
- Check_Switches;
-
- Switch_Array_Id :=
- Value_Of
- (Name => Name_Default_Switches,
- In_Arrays => Shared.Packages.Table (Builder).Decl.Arrays,
- Shared => Shared);
- Check_Switches;
- end if;
- end Check_Builder_Switches;
-
- ------------------------
- -- Get_Project_Target --
- ------------------------
-
- procedure Get_Project_Target is
- begin
- if Selected_Target'Length = 0 then
-
- -- Check if attribute Target is specified in the main
- -- project, or in a project it extends. If it is, use this
- -- target to invoke gprconfig.
-
- declare
- Variable : Variable_Value;
- Proj : Project_Id;
- Tgt_Name : Name_Id := No_Name;
-
- begin
- Proj := Project;
- Project_Loop :
- while Proj /= No_Project loop
- Variable :=
- Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
-
- if Variable /= Nil_Variable_Value
- and then not Variable.Default
- and then Variable.Value /= No_Name
- then
- Tgt_Name := Variable.Value;
- exit Project_Loop;
- end if;
-
- Proj := Proj.Extends;
- end loop Project_Loop;
-
- if Tgt_Name /= No_Name then
- Selected_Target := new String'(Get_Name_String (Tgt_Name));
- end if;
- end;
- end if;
- end Get_Project_Target;
-
- --------------------------
- -- Get_Project_Runtimes --
- --------------------------
-
- procedure Get_Project_Runtimes is
- Element : Array_Element;
- Id : Array_Element_Id;
- Lang : Name_Id;
- Proj : Project_Id;
-
- begin
- Proj := Project;
- while Proj /= No_Project loop
- Id := Value_Of (Name_Runtime, Proj.Decl.Arrays, Shared);
- while Id /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Id);
- Lang := Element.Index;
-
- if not Runtime_Name_Set_For (Lang) then
- Set_Runtime_For
- (Lang, RTS_Name => Get_Name_String (Element.Value.Value));
- end if;
-
- Id := Element.Next;
- end loop;
-
- Proj := Proj.Extends;
- end loop;
- end Get_Project_Runtimes;
-
- -----------------------
- -- Default_File_Name --
- -----------------------
-
- function Default_File_Name return String is
- Ada_RTS : constant String := Runtime_Name_For (Name_Ada);
- Tmp : String_Access;
-
- begin
- if Selected_Target'Length /= 0 then
- if Ada_RTS /= "" then
- return
- Selected_Target.all & '-' &
- Ada_RTS & Config_Project_File_Extension;
- else
- return
- Selected_Target.all & Config_Project_File_Extension;
- end if;
-
- elsif Ada_RTS /= "" then
- return Ada_RTS & Config_Project_File_Extension;
-
- else
- Tmp := Getenv (Config_Project_Env_Var);
-
- declare
- T : constant String := Tmp.all;
-
- begin
- Free (Tmp);
-
- if T'Length = 0 then
- return Default_Config_Name;
- else
- return T;
- end if;
- end;
- end if;
- end Default_File_Name;
-
- -----------------
- -- Do_Autoconf --
- -----------------
-
- procedure Do_Autoconf is
- Obj_Dir : constant Variable_Value :=
- Value_Of
- (Name_Object_Dir,
- Conf_Project.Decl.Attributes,
- Shared);
-
- Gprconfig_Path : String_Access;
- Success : Boolean;
-
- begin
- Gprconfig_Path := Locate_Exec_On_Path (Gprconfig_Name);
-
- if Gprconfig_Path = null then
- Raise_Invalid_Config
- ("could not locate gprconfig for auto-configuration");
- end if;
-
- -- First, find the object directory of the Conf_Project
-
- -- If the object directory is a relative one and Build_Tree_Dir is
- -- set, first add it.
-
- Name_Len := 0;
-
- if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
-
- if Build_Tree_Dir /= null then
- Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
-
- if Get_Name_String (Conf_Project.Directory.Display_Name)'Length
- < Root_Dir'Length
- then
- Raise_Invalid_Config
- ("cannot relocate deeper than object directory");
- end if;
-
- Add_Str_To_Name_Buffer
- (Relative_Path
- (Get_Name_String (Conf_Project.Directory.Display_Name),
- Root_Dir.all));
- else
- Get_Name_String (Conf_Project.Directory.Display_Name);
- end if;
-
- else
- if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
- Get_Name_String (Obj_Dir.Value);
-
- else
- if Build_Tree_Dir /= null then
- if Get_Name_String
- (Conf_Project.Directory.Display_Name)'Length <
- Root_Dir'Length
- then
- Raise_Invalid_Config
- ("cannot relocate deeper than object directory");
- end if;
-
- Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
- Add_Str_To_Name_Buffer
- (Relative_Path
- (Get_Name_String (Conf_Project.Directory.Display_Name),
- Root_Dir.all));
- else
- Add_Str_To_Name_Buffer
- (Get_Name_String (Conf_Project.Directory.Display_Name));
- end if;
-
- Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
- end if;
- end if;
-
- if Subdirs /= null then
- Add_Char_To_Name_Buffer (Directory_Separator);
- Add_Str_To_Name_Buffer (Subdirs.all);
- end if;
-
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '/' then
- Name_Buffer (J) := Directory_Separator;
- end if;
- end loop;
-
- -- Make sure that Obj_Dir ends with a directory separator
-
- if Name_Buffer (Name_Len) /= Directory_Separator then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Directory_Separator;
- end if;
-
- declare
- Obj_Dir : constant String := Name_Buffer (1 .. Name_Len);
- Config_Switches : Argument_List_Access;
- Db_Switches : Argument_List_Access;
- Args : Argument_List (1 .. 5);
- Arg_Last : Positive;
- Obj_Dir_Exists : Boolean := True;
-
- begin
- -- Check if the object directory exists. If Setup_Projects is True
- -- (-p) and directory does not exist, attempt to create it.
- -- Otherwise, if directory does not exist, fail without calling
- -- gprconfig.
-
- if not Is_Directory (Obj_Dir)
- and then (Setup_Projects or else Subdirs /= null)
- then
- begin
- Create_Path (Obj_Dir);
-
- if not Quiet_Output then
- Write_Str ("object directory """);
- Write_Str (Obj_Dir);
- Write_Line (""" created");
- end if;
-
- exception
- when others =>
- Raise_Invalid_Config
- ("could not create object directory " & Obj_Dir);
- end;
- end if;
-
- if not Is_Directory (Obj_Dir) then
- case Env.Flags.Require_Obj_Dirs is
- when Error =>
- Raise_Invalid_Config
- ("object directory " & Obj_Dir & " does not exist");
-
- when Warning =>
- Prj.Err.Error_Msg
- (Env.Flags,
- "?object directory " & Obj_Dir & " does not exist");
- Obj_Dir_Exists := False;
-
- when Silent =>
- null;
- end case;
- end if;
-
- -- Get the config switches. This should be done only now, as some
- -- runtimes may have been found in the Builder switches.
-
- Config_Switches := Get_Config_Switches;
-
- -- Get eventual --db switches
-
- Db_Switches := Get_Db_Switches;
-
- -- Invoke gprconfig
-
- Args (1) := new String'("--batch");
- Args (2) := new String'("-o");
-
- -- If no config file was specified, set the auto.cgpr one
-
- if Conf_File_Name'Length = 0 then
- if Obj_Dir_Exists then
- Args (3) := new String'(Obj_Dir & Auto_Cgpr);
-
- else
- declare
- Path_FD : File_Descriptor;
- Path_Name : Path_Name_Type;
-
- begin
- Prj.Env.Create_Temp_File
- (Shared => Project_Tree.Shared,
- Path_FD => Path_FD,
- Path_Name => Path_Name,
- File_Use => "configuration file");
-
- if Path_FD /= Invalid_FD then
- declare
- Temp_Dir : constant String :=
- Containing_Directory
- (Get_Name_String (Path_Name));
- begin
- GNAT.OS_Lib.Close (Path_FD);
- Args (3) :=
- new String'(Temp_Dir &
- Directory_Separator &
- Auto_Cgpr);
- Delete_File (Get_Name_String (Path_Name));
- end;
-
- else
- -- We'll have an error message later on
-
- Args (3) := new String'(Obj_Dir & Auto_Cgpr);
- end if;
- end;
- end if;
- else
- Args (3) := Conf_File_Name;
- end if;
-
- Arg_Last := 3;
-
- if Selected_Target /= null and then
- Selected_Target.all /= ""
-
- then
- Args (4) :=
- new String'("--target=" & Selected_Target.all);
- Arg_Last := 4;
-
- elsif Normalized_Hostname /= "" then
- if At_Least_One_Compiler_Command then
- Args (4) := new String'("--target=all");
- else
- Args (4) := new String'("--target=" & Normalized_Hostname);
- end if;
-
- Arg_Last := 4;
- end if;
-
- if not Verbose_Mode then
- Arg_Last := Arg_Last + 1;
- Args (Arg_Last) := new String'("-q");
- end if;
-
- if Verbose_Mode then
- Write_Str (Gprconfig_Name);
-
- for J in 1 .. Arg_Last loop
- Write_Char (' ');
- Write_Str (Args (J).all);
- end loop;
-
- for J in Config_Switches'Range loop
- Write_Char (' ');
- Write_Str (Config_Switches (J).all);
- end loop;
-
- for J in Db_Switches'Range loop
- Write_Char (' ');
- Write_Str (Db_Switches (J).all);
- end loop;
-
- Write_Eol;
-
- elsif not Quiet_Output then
-
- -- Display no message if we are creating auto.cgpr, unless in
- -- verbose mode.
-
- if Config_File_Name'Length > 0 or else Verbose_Mode then
- Write_Str ("creating ");
- Write_Str (Simple_Name (Args (3).all));
- Write_Eol;
- end if;
- end if;
-
- Spawn (Gprconfig_Path.all, Args (1 .. Arg_Last) &
- Config_Switches.all & Db_Switches.all,
- Success);
-
- Free (Config_Switches);
-
- Config_File_Path := Locate_Config_File (Args (3).all);
-
- if Config_File_Path = null then
- Raise_Invalid_Config
- ("could not create " & Args (3).all);
- end if;
-
- for F in Args'Range loop
- Free (Args (F));
- end loop;
- end;
- end Do_Autoconf;
-
- ---------------------
- -- Get_Db_Switches --
- ---------------------
-
- function Get_Db_Switches return Argument_List_Access is
- Result : Argument_List_Access;
- Nmb_Arg : Natural;
- begin
- Nmb_Arg :=
- (2 * Db_Switch_Args.Last) + Boolean'Pos (not Load_Standard_Base);
- Result := new Argument_List (1 .. Nmb_Arg);
-
- if Nmb_Arg /= 0 then
- for J in 1 .. Db_Switch_Args.Last loop
- Result (2 * J - 1) :=
- new String'("--db");
- Result (2 * J) :=
- new String'(Get_Name_String (Db_Switch_Args.Table (J)));
- end loop;
-
- if not Load_Standard_Base then
- Result (Result'Last) := new String'("--db-");
- end if;
- end if;
-
- return Result;
- end Get_Db_Switches;
-
- -------------------------
- -- Get_Config_Switches --
- -------------------------
-
- function Get_Config_Switches return Argument_List_Access is
-
- package Language_Htable is new GNAT.HTable.Simple_HTable
- (Header_Num => Prj.Header_Num,
- Element => Name_Id,
- No_Element => No_Name,
- Key => Name_Id,
- Hash => Prj.Hash,
- Equal => "=");
- -- Hash table to keep the languages used in the project tree
-
- IDE : constant Package_Id :=
- Value_Of (Name_Ide, Project.Decl.Packages, Shared);
-
- procedure Add_Config_Switches_For_Project
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out Integer);
- -- Add all --config switches for this project. This is also called
- -- for aggregate projects.
-
- -------------------------------------
- -- Add_Config_Switches_For_Project --
- -------------------------------------
-
- procedure Add_Config_Switches_For_Project
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out Integer)
- is
- pragma Unreferenced (With_State);
-
- Shared : constant Shared_Project_Tree_Data_Access := Tree.Shared;
-
- Variable : Variable_Value;
- Check_Default : Boolean;
- Lang : Name_Id;
- List : String_List_Id;
- Elem : String_Element;
-
- begin
- if Might_Have_Sources (Project) then
- Variable :=
- Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
-
- if Variable = Nil_Variable_Value or else Variable.Default then
-
- -- Languages is not declared. If it is not an extending
- -- project, or if it extends a project with no Languages,
- -- check for Default_Language.
-
- Check_Default := Project.Extends = No_Project;
-
- if not Check_Default then
- Variable :=
- Value_Of
- (Name_Languages,
- Project.Extends.Decl.Attributes,
- Shared);
- Check_Default :=
- Variable /= Nil_Variable_Value
- and then Variable.Values = Nil_String;
- end if;
-
- if Check_Default then
- Variable :=
- Value_Of
- (Name_Default_Language,
- Project.Decl.Attributes,
- Shared);
-
- if Variable /= Nil_Variable_Value
- and then not Variable.Default
- then
- Get_Name_String (Variable.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Lang := Name_Find;
- Language_Htable.Set (Lang, Lang);
-
- -- If no default language is declared, default to Ada
-
- else
- Language_Htable.Set (Name_Ada, Name_Ada);
- end if;
- end if;
-
- elsif Variable.Values /= Nil_String then
-
- -- Attribute Languages is declared with a non empty list:
- -- put all the languages in Language_HTable.
-
- List := Variable.Values;
- while List /= Nil_String loop
- Elem := Shared.String_Elements.Table (List);
-
- Get_Name_String (Elem.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Lang := Name_Find;
- Language_Htable.Set (Lang, Lang);
-
- List := Elem.Next;
- end loop;
- end if;
- end if;
- end Add_Config_Switches_For_Project;
-
- procedure For_Every_Imported_Project is new For_Every_Project_Imported
- (State => Integer, Action => Add_Config_Switches_For_Project);
- -- Document this procedure ???
-
- -- Local variables
-
- Name : Name_Id;
- Count : Natural;
- Result : Argument_List_Access;
- Variable : Variable_Value;
- Dummy : Integer := 0;
-
- -- Start of processing for Get_Config_Switches
-
- begin
- For_Every_Imported_Project
- (By => Project,
- Tree => Project_Tree,
- With_State => Dummy,
- Include_Aggregated => True);
-
- Name := Language_Htable.Get_First;
- Count := 0;
- while Name /= No_Name loop
- Count := Count + 1;
- Name := Language_Htable.Get_Next;
- end loop;
-
- Result := new String_List (1 .. Count);
-
- Count := 1;
- Name := Language_Htable.Get_First;
- while Name /= No_Name loop
-
- -- Check if IDE'Compiler_Command is declared for the language.
- -- If it is, use its value to invoke gprconfig.
-
- Variable :=
- Value_Of
- (Name,
- Attribute_Or_Array_Name => Name_Compiler_Command,
- In_Package => IDE,
- Shared => Shared,
- Force_Lower_Case_Index => True);
-
- declare
- Config_Command : constant String :=
- "--config=" & Get_Name_String (Name);
-
- Runtime_Name : constant String := Runtime_Name_For (Name);
-
- begin
- -- In CodePeer mode, we do not take into account any compiler
- -- command from the package IDE.
-
- if CodePeer_Mode
- or else Variable = Nil_Variable_Value
- or else Length_Of_Name (Variable.Value) = 0
- then
- Result (Count) :=
- new String'(Config_Command & ",," & Runtime_Name);
-
- else
- At_Least_One_Compiler_Command := True;
-
- declare
- Compiler_Command : constant String :=
- Get_Name_String (Variable.Value);
-
- begin
- if Is_Absolute_Path (Compiler_Command) then
- Result (Count) :=
- new String'
- (Config_Command & ",," & Runtime_Name & ","
- & Containing_Directory (Compiler_Command) & ","
- & Simple_Name (Compiler_Command));
- else
- Result (Count) :=
- new String'
- (Config_Command & ",," & Runtime_Name & ",,"
- & Compiler_Command);
- end if;
- end;
- end if;
- end;
-
- Count := Count + 1;
- Name := Language_Htable.Get_Next;
- end loop;
-
- return Result;
- end Get_Config_Switches;
-
- ------------------------
- -- Might_Have_Sources --
- ------------------------
-
- function Might_Have_Sources (Project : Project_Id) return Boolean is
- Variable : Variable_Value;
-
- begin
- Variable :=
- Value_Of (Name_Source_Dirs, Project.Decl.Attributes, Shared);
-
- if Variable = Nil_Variable_Value
- or else Variable.Default
- or else Variable.Values /= Nil_String
- then
- Variable :=
- Value_Of (Name_Source_Files, Project.Decl.Attributes, Shared);
- return Variable = Nil_Variable_Value
- or else Variable.Default
- or else Variable.Values /= Nil_String;
-
- else
- return False;
- end if;
- end Might_Have_Sources;
-
- -- Local Variables
-
- Success : Boolean;
- Config_Project_Node : Project_Node_Id := Empty_Node;
-
- -- Start of processing for Get_Or_Create_Configuration_File
-
- begin
- pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
-
- Free (Config_File_Path);
- Config := No_Project;
-
- Get_Project_Target;
- Get_Project_Runtimes;
- Check_Builder_Switches;
-
- -- Do not attempt to find a configuration project file when
- -- Config_File_Name is No_Configuration_File.
-
- if Config_File_Name = No_Configuration_File then
- Config_File_Path := null;
-
- else
- if Conf_File_Name'Length > 0 then
- Config_File_Path := Locate_Config_File (Conf_File_Name.all);
- else
- Config_File_Path := Locate_Config_File (Default_File_Name);
- end if;
-
- if Config_File_Path = null then
- if not Allow_Automatic_Generation
- and then Conf_File_Name'Length > 0
- then
- Raise_Invalid_Config
- ("could not locate main configuration project "
- & Conf_File_Name.all);
- end if;
- end if;
- end if;
-
- Automatically_Generated :=
- Allow_Automatic_Generation and then Config_File_Path = null;
-
- <<Process_Config_File>>
-
- if Automatically_Generated then
-
- -- This might raise an Invalid_Config exception
-
- Do_Autoconf;
-
- -- If the config file is not auto-generated, warn if there is any --RTS
- -- switch, but not when the config file is generated in memory.
-
- elsif Warn_For_RTS
- and then RTS_Languages.Get_First /= No_Name
- and then Opt.Warning_Mode /= Opt.Suppress
- and then On_Load_Config = null
- then
- Write_Line
- ("warning: " &
- "runtimes are taken into account only in auto-configuration");
- end if;
-
- -- Parse the configuration file
-
- if Verbose_Mode and then Config_File_Path /= null then
- Write_Str ("Checking configuration ");
- Write_Line (Config_File_Path.all);
- end if;
-
- if Config_File_Path /= null then
- Prj.Part.Parse
- (In_Tree => Project_Node_Tree,
- Project => Config_Project_Node,
- Project_File_Name => Config_File_Path.all,
- Errout_Handling => Prj.Part.Finalize_If_Error,
- Packages_To_Check => Packages_To_Check,
- Current_Directory => Current_Directory,
- Is_Config_File => True,
- Env => Env);
- else
- Config_Project_Node := Empty_Node;
- end if;
-
- if On_Load_Config /= null then
- On_Load_Config
- (Config_File => Config_Project_Node,
- Project_Node_Tree => Project_Node_Tree);
- end if;
-
- if Config_Project_Node /= Empty_Node then
- Prj.Proc.Process_Project_Tree_Phase_1
- (In_Tree => Project_Tree,
- Project => Config,
- Packages_To_Check => Packages_To_Check,
- Success => Success,
- From_Project_Node => Config_Project_Node,
- From_Project_Node_Tree => Project_Node_Tree,
- Env => Env,
- Reset_Tree => False,
- On_New_Tree_Loaded => null);
- end if;
-
- if Config_Project_Node = Empty_Node or else Config = No_Project then
- Raise_Invalid_Config
- ("processing of configuration project """
- & Config_File_Path.all & """ failed");
- end if;
-
- -- Check that the target of the configuration file is the one the user
- -- specified on the command line. We do not need to check that when in
- -- auto-conf mode, since the appropriate target was passed to gprconfig.
-
- if not Automatically_Generated
- and then not
- Check_Target
- (Config, Autoconf_Specified, Project_Tree, Selected_Target.all)
- then
- Automatically_Generated := True;
- goto Process_Config_File;
- end if;
- end Get_Or_Create_Configuration_File;
-
- ------------------------
- -- Locate_Config_File --
- ------------------------
-
- function Locate_Config_File (Name : String) return String_Access is
- Prefix_Path : constant String := Executable_Prefix_Path;
- begin
- if Prefix_Path'Length /= 0 then
- return Locate_Regular_File
- (Name,
- "." & Path_Separator &
- Prefix_Path & "share" & Directory_Separator & "gpr");
- else
- return Locate_Regular_File (Name, ".");
- end if;
- end Locate_Config_File;
-
- ------------------------------------
- -- Parse_Project_And_Apply_Config --
- ------------------------------------
-
- procedure Parse_Project_And_Apply_Config
- (Main_Project : out Prj.Project_Id;
- User_Project_Node : out Prj.Tree.Project_Node_Id;
- Config_File_Name : String := "";
- Autoconf_Specified : Boolean;
- Project_File_Name : String;
- Project_Tree : Prj.Project_Tree_Ref;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Packages_To_Check : String_List_Access;
- Allow_Automatic_Generation : Boolean := True;
- Automatically_Generated : out Boolean;
- Config_File_Path : out String_Access;
- Target_Name : String := "";
- Normalized_Hostname : String;
- On_Load_Config : Config_File_Hook := null;
- Implicit_Project : Boolean := False;
- On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null)
- is
- Success : Boolean := False;
- Target_Try_Again : Boolean := True;
- Config_Try_Again : Boolean;
-
- Finalization : Prj.Part.Errout_Mode := Prj.Part.Always_Finalize;
-
- S : State := No_State;
-
- Conf_File_Name : String_Access := new String'(Config_File_Name);
-
- procedure Add_Directory (Dir : String);
- -- Add a directory at the end of the Project Path
-
- Auto_Generated : Boolean;
-
- -------------------
- -- Add_Directory --
- -------------------
-
- procedure Add_Directory (Dir : String) is
- begin
- if Opt.Verbose_Mode then
- Write_Line (" Adding directory """ & Dir & """");
- end if;
-
- Prj.Env.Add_Directories (Env.Project_Path, Dir);
- end Add_Directory;
-
- begin
- pragma Assert (Prj.Env.Is_Initialized (Env.Project_Path));
-
- -- Start with ignoring missing withed projects
-
- Set_Ignore_Missing_With (Env.Flags, True);
-
- -- Note: If in fact the config file is automatically generated, then
- -- Automatically_Generated will be set to True after invocation of
- -- Process_Project_And_Apply_Config.
-
- Automatically_Generated := False;
-
- -- Record Target_Value and Target_Origin
-
- if Target_Name = "" then
- Opt.Target_Value := new String'(Normalized_Hostname);
- Opt.Target_Origin := Default;
- else
- Opt.Target_Value := new String'(Target_Name);
- Opt.Target_Origin := Specified;
- end if;
-
- <<Parse_Again>>
-
- -- Parse the user project tree
-
- Project_Node_Tree.Incomplete_With := False;
- Env.Flags.Incomplete_Withs := False;
- Prj.Initialize (Project_Tree);
-
- Main_Project := No_Project;
-
- Prj.Part.Parse
- (In_Tree => Project_Node_Tree,
- Project => User_Project_Node,
- Project_File_Name => Project_File_Name,
- Errout_Handling => Finalization,
- Packages_To_Check => Packages_To_Check,
- Current_Directory => Current_Directory,
- Is_Config_File => False,
- Env => Env,
- Implicit_Project => Implicit_Project);
-
- Finalization := Prj.Part.Finalize_If_Error;
-
- if User_Project_Node = Empty_Node then
- return;
- end if;
-
- -- If --target was not specified on the command line, then do Phase 1 to
- -- check if attribute Target is declared in the main project.
-
- if Opt.Target_Origin /= Specified then
- Main_Project := No_Project;
- Process_Project_Tree_Phase_1
- (In_Tree => Project_Tree,
- Project => Main_Project,
- Packages_To_Check => Packages_To_Check,
- Success => Success,
- From_Project_Node => User_Project_Node,
- From_Project_Node_Tree => Project_Node_Tree,
- Env => Env,
- Reset_Tree => True,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
-
- if not Success then
- Main_Project := No_Project;
- return;
- end if;
-
- declare
- Variable : constant Variable_Value :=
- Value_Of
- (Name_Target,
- Main_Project.Decl.Attributes,
- Project_Tree.Shared);
- begin
- if Variable /= Nil_Variable_Value
- and then not Variable.Default
- and then
- Get_Name_String (Variable.Value) /= Opt.Target_Value.all
- then
- if Target_Try_Again then
- Opt.Target_Value :=
- new String'(Get_Name_String (Variable.Value));
- Target_Try_Again := False;
- goto Parse_Again;
-
- else
- Fail_Program
- (Project_Tree,
- "inconsistent value of attribute Target");
- end if;
- end if;
- end;
- end if;
-
- -- If there are missing withed projects, the projects will be parsed
- -- again after the project path is extended with directories rooted
- -- at the compiler roots.
-
- Config_Try_Again := Project_Node_Tree.Incomplete_With;
-
- Process_Project_And_Apply_Config
- (Main_Project => Main_Project,
- User_Project_Node => User_Project_Node,
- Config_File_Name => Conf_File_Name.all,
- Autoconf_Specified => Autoconf_Specified,
- Project_Tree => Project_Tree,
- Project_Node_Tree => Project_Node_Tree,
- Env => Env,
- Packages_To_Check => Packages_To_Check,
- Allow_Automatic_Generation => Allow_Automatic_Generation,
- Automatically_Generated => Auto_Generated,
- Config_File_Path => Config_File_Path,
- Target_Name => Target_Name,
- Normalized_Hostname => Normalized_Hostname,
- On_Load_Config => On_Load_Config,
- On_New_Tree_Loaded => On_New_Tree_Loaded,
- Do_Phase_1 => Opt.Target_Origin = Specified);
-
- if Auto_Generated then
- Automatically_Generated := True;
- end if;
-
- -- Exit if there was an error. Otherwise, if Config_Try_Again is True,
- -- update the project path and try again.
-
- if Main_Project /= No_Project and then Config_Try_Again then
- Set_Ignore_Missing_With (Env.Flags, False);
-
- if Config_File_Path /= null then
- Conf_File_Name := new String'(Config_File_Path.all);
- end if;
-
- -- For the second time the project files are parsed, the warning for
- -- --RTS= being only taken into account in auto-configuration are
- -- suppressed, as we are no longer in auto-configuration.
-
- Warn_For_RTS := False;
-
- -- Add the default directories corresponding to the compilers
-
- Update_Project_Path
- (By => Main_Project,
- Tree => Project_Tree,
- With_State => S,
- Include_Aggregated => True,
- Imported_First => False);
-
- declare
- Compiler_Root : Compiler_Root_Ptr;
- Prefix : String_Access;
- Runtime_Root : Runtime_Root_Ptr;
- Path_Value : constant String_Access := Getenv ("PATH");
-
- begin
- if Opt.Verbose_Mode then
- Write_Line ("Setting the default project search directories");
-
- if Prj.Current_Verbosity = High then
- if Path_Value = null or else Path_Value'Length = 0 then
- Write_Line ("No environment variable PATH");
-
- else
- Write_Line ("PATH =");
- Write_Line (" " & Path_Value.all);
- end if;
- end if;
- end if;
-
- -- Reorder the compiler roots in the PATH order
-
- if First_Compiler_Root /= null
- and then First_Compiler_Root.Next /= null
- then
- declare
- Pred : Compiler_Root_Ptr;
- First_New_Comp : Compiler_Root_Ptr := null;
- New_Comp : Compiler_Root_Ptr := null;
- First : Positive := Path_Value'First;
- Last : Positive;
- Path_Last : Positive;
- begin
- while First <= Path_Value'Last loop
- Last := First;
-
- if Path_Value (First) /= Path_Separator then
- while Last < Path_Value'Last
- and then Path_Value (Last + 1) /= Path_Separator
- loop
- Last := Last + 1;
- end loop;
-
- Path_Last := Last;
- while Path_Last > First
- and then
- Path_Value (Path_Last) = Directory_Separator
- loop
- Path_Last := Path_Last - 1;
- end loop;
-
- if Path_Last > First + 4
- and then
- Path_Value (Path_Last - 2 .. Path_Last) = "bin"
- and then
- Path_Value (Path_Last - 3) = Directory_Separator
- then
- Path_Last := Path_Last - 4;
- Pred := null;
- Compiler_Root := First_Compiler_Root;
- while Compiler_Root /= null
- and then Compiler_Root.Root.all /=
- Path_Value (First .. Path_Last)
- loop
- Pred := Compiler_Root;
- Compiler_Root := Compiler_Root.Next;
- end loop;
-
- if Compiler_Root /= null then
- if Pred = null then
- First_Compiler_Root :=
- First_Compiler_Root.Next;
- else
- Pred.Next := Compiler_Root.Next;
- end if;
-
- if First_New_Comp = null then
- First_New_Comp := Compiler_Root;
- else
- New_Comp.Next := Compiler_Root;
- end if;
-
- New_Comp := Compiler_Root;
- New_Comp.Next := null;
- end if;
- end if;
- end if;
-
- First := Last + 1;
- end loop;
-
- if First_New_Comp /= null then
- New_Comp.Next := First_Compiler_Root;
- First_Compiler_Root := First_New_Comp;
- end if;
- end;
- end if;
-
- -- Now that the compiler roots are in a correct order, add the
- -- directories corresponding to these compiler roots in the
- -- project path.
-
- Compiler_Root := First_Compiler_Root;
- while Compiler_Root /= null loop
- Prefix := Compiler_Root.Root;
-
- Runtime_Root := Compiler_Root.Runtimes;
- while Runtime_Root /= null loop
- Add_Directory
- (Runtime_Root.Root.all &
- Directory_Separator &
- "lib" &
- Directory_Separator &
- "gnat");
- Add_Directory
- (Runtime_Root.Root.all &
- Directory_Separator &
- "share" &
- Directory_Separator &
- "gpr");
- Runtime_Root := Runtime_Root.Next;
- end loop;
-
- Add_Directory
- (Prefix.all &
- Directory_Separator &
- Opt.Target_Value.all &
- Directory_Separator &
- "lib" &
- Directory_Separator &
- "gnat");
- Add_Directory
- (Prefix.all &
- Directory_Separator &
- Opt.Target_Value.all &
- Directory_Separator &
- "share" &
- Directory_Separator &
- "gpr");
- Add_Directory
- (Prefix.all &
- Directory_Separator &
- "share" &
- Directory_Separator &
- "gpr");
- Add_Directory
- (Prefix.all &
- Directory_Separator &
- "lib" &
- Directory_Separator &
- "gnat");
- Compiler_Root := Compiler_Root.Next;
- end loop;
- end;
-
- -- And parse again the project files. There will be no missing
- -- withed projects, as Ignore_Missing_With is set to False in
- -- the environment flags, so there is no risk of endless loop here.
-
- goto Parse_Again;
- end if;
- end Parse_Project_And_Apply_Config;
-
- --------------------------------------
- -- Process_Project_And_Apply_Config --
- --------------------------------------
-
- procedure Process_Project_And_Apply_Config
- (Main_Project : out Prj.Project_Id;
- User_Project_Node : Prj.Tree.Project_Node_Id;
- Config_File_Name : String := "";
- Autoconf_Specified : Boolean;
- Project_Tree : Prj.Project_Tree_Ref;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Packages_To_Check : String_List_Access;
- Allow_Automatic_Generation : Boolean := True;
- Automatically_Generated : out Boolean;
- Config_File_Path : out String_Access;
- Target_Name : String := "";
- Normalized_Hostname : String;
- On_Load_Config : Config_File_Hook := null;
- Reset_Tree : Boolean := True;
- On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null;
- Do_Phase_1 : Boolean := True)
- is
- Shared : constant Shared_Project_Tree_Data_Access :=
- Project_Tree.Shared;
- Main_Config_Project : Project_Id;
- Success : Boolean;
-
- Conf_Project : Project_Id := No_Project;
- -- The object directory of this project is used to store the config
- -- project file in auto-configuration. Set by Check_Project below.
-
- procedure Check_Project (Project : Project_Id);
- -- Look for a non aggregate project. If one is found, put its project Id
- -- in Conf_Project.
-
- -------------------
- -- Check_Project --
- -------------------
-
- procedure Check_Project (Project : Project_Id) is
- begin
- if Project.Qualifier = Aggregate
- or else
- Project.Qualifier = Aggregate_Library
- then
- declare
- List : Aggregated_Project_List := Project.Aggregated_Projects;
-
- begin
- -- Look for a non aggregate project until one is found
-
- while Conf_Project = No_Project and then List /= null loop
- Check_Project (List.Project);
- List := List.Next;
- end loop;
- end;
-
- else
- Conf_Project := Project;
- end if;
- end Check_Project;
-
- -- Start of processing for Process_Project_And_Apply_Config
-
- begin
- Automatically_Generated := False;
-
- if Do_Phase_1 then
- Main_Project := No_Project;
- Process_Project_Tree_Phase_1
- (In_Tree => Project_Tree,
- Project => Main_Project,
- Packages_To_Check => Packages_To_Check,
- Success => Success,
- From_Project_Node => User_Project_Node,
- From_Project_Node_Tree => Project_Node_Tree,
- Env => Env,
- Reset_Tree => Reset_Tree,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
-
- if not Success then
- Main_Project := No_Project;
- return;
- end if;
- end if;
-
- if Project_Tree.Source_Info_File_Name /= null then
- if not Is_Absolute_Path (Project_Tree.Source_Info_File_Name.all) then
- declare
- Obj_Dir : constant Variable_Value :=
- Value_Of
- (Name_Object_Dir,
- Main_Project.Decl.Attributes,
- Shared);
-
- begin
- if Obj_Dir = Nil_Variable_Value or else Obj_Dir.Default then
- Get_Name_String (Main_Project.Directory.Display_Name);
-
- else
- if Is_Absolute_Path (Get_Name_String (Obj_Dir.Value)) then
- Get_Name_String (Obj_Dir.Value);
-
- else
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (Get_Name_String (Main_Project.Directory.Display_Name));
- Add_Str_To_Name_Buffer (Get_Name_String (Obj_Dir.Value));
- end if;
- end if;
-
- Add_Char_To_Name_Buffer (Directory_Separator);
- Add_Str_To_Name_Buffer (Project_Tree.Source_Info_File_Name.all);
- Free (Project_Tree.Source_Info_File_Name);
- Project_Tree.Source_Info_File_Name :=
- new String'(Name_Buffer (1 .. Name_Len));
- end;
- end if;
-
- Read_Source_Info_File (Project_Tree);
- end if;
-
- -- Get the first project that is not an aggregate project or an
- -- aggregate library project. The object directory of this project will
- -- be used to store the config project file in auto-configuration.
-
- Check_Project (Main_Project);
-
- -- Fail if there is only aggregate projects and aggregate library
- -- projects in the project tree.
-
- if Conf_Project = No_Project then
- Raise_Invalid_Config ("there are no non-aggregate projects");
- end if;
-
- -- Find configuration file
-
- Get_Or_Create_Configuration_File
- (Config => Main_Config_Project,
- Project => Main_Project,
- Conf_Project => Conf_Project,
- Project_Tree => Project_Tree,
- Project_Node_Tree => Project_Node_Tree,
- Env => Env,
- Allow_Automatic_Generation => Allow_Automatic_Generation,
- Config_File_Name => Config_File_Name,
- Autoconf_Specified => Autoconf_Specified,
- Target_Name => Target_Name,
- Normalized_Hostname => Normalized_Hostname,
- Packages_To_Check => Packages_To_Check,
- Config_File_Path => Config_File_Path,
- Automatically_Generated => Automatically_Generated,
- On_Load_Config => On_Load_Config);
-
- Apply_Config_File (Main_Config_Project, Project_Tree);
-
- -- Finish processing the user's project
-
- Prj.Proc.Process_Project_Tree_Phase_2
- (In_Tree => Project_Tree,
- Project => Main_Project,
- Success => Success,
- From_Project_Node => User_Project_Node,
- From_Project_Node_Tree => Project_Node_Tree,
- Env => Env);
-
- if Success then
- if Project_Tree.Source_Info_File_Name /= null
- and then not Project_Tree.Source_Info_File_Exists
- then
- Write_Source_Info_File (Project_Tree);
- end if;
-
- else
- Main_Project := No_Project;
- end if;
- end Process_Project_And_Apply_Config;
-
- --------------------------
- -- Raise_Invalid_Config --
- --------------------------
-
- procedure Raise_Invalid_Config (Msg : String) is
- begin
- Raise_Exception (Invalid_Config'Identity, Msg);
- end Raise_Invalid_Config;
-
- ----------------------
- -- Runtime_Name_For --
- ----------------------
-
- function Runtime_Name_For (Language : Name_Id) return String is
- begin
- if RTS_Languages.Get (Language) /= No_Name then
- return Get_Name_String (RTS_Languages.Get (Language));
- else
- return "";
- end if;
- end Runtime_Name_For;
-
- --------------------------
- -- Runtime_Name_Set_For --
- --------------------------
-
- function Runtime_Name_Set_For (Language : Name_Id) return Boolean is
- begin
- return RTS_Languages.Get (Language) /= No_Name;
- end Runtime_Name_Set_For;
-
- ---------------------
- -- Set_Runtime_For --
- ---------------------
-
- procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String) is
- begin
- Name_Len := RTS_Name'Length;
- Name_Buffer (1 .. Name_Len) := RTS_Name;
- RTS_Languages.Set (Language, Name_Find);
- end Set_Runtime_For;
-
- ----------------------------
- -- Look_For_Project_Paths --
- ----------------------------
-
- procedure Look_For_Project_Paths
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out State)
- is
- Lang_Id : Language_Ptr;
- Compiler_Root : Compiler_Root_Ptr;
- Runtime_Root : Runtime_Root_Ptr;
- Comp_Driver : String_Access;
- Comp_Dir : String_Access;
- Prefix : String_Access;
-
- pragma Unreferenced (Tree);
-
- begin
- With_State := No_State;
-
- Lang_Id := Project.Languages;
- while Lang_Id /= No_Language_Index loop
- if Lang_Id.Config.Compiler_Driver /= No_File then
- Comp_Driver :=
- new String'
- (Get_Name_String (Lang_Id.Config.Compiler_Driver));
-
- -- Get the absolute path of the compiler driver
-
- if not Is_Absolute_Path (Comp_Driver.all) then
- Comp_Driver := Locate_Exec_On_Path (Comp_Driver.all);
- end if;
-
- if Comp_Driver /= null and then Comp_Driver'Length > 0 then
- Comp_Dir :=
- new String'
- (Containing_Directory (Comp_Driver.all));
-
- -- Consider only the compiler drivers that are in "bin"
- -- subdirectories.
-
- if Simple_Name (Comp_Dir.all) = "bin" then
- Prefix :=
- new String'(Containing_Directory (Comp_Dir.all));
-
- -- Check if the compiler root is already in the list. If it
- -- is not, add it to the list.
-
- Compiler_Root := First_Compiler_Root;
- while Compiler_Root /= null loop
- exit when Prefix.all = Compiler_Root.Root.all;
- Compiler_Root := Compiler_Root.Next;
- end loop;
-
- if Compiler_Root = null then
- First_Compiler_Root :=
- new Compiler_Root_Data'
- (Root => Prefix,
- Runtimes => null,
- Next => First_Compiler_Root);
- Compiler_Root := First_Compiler_Root;
- end if;
-
- -- If there is a runtime for this compiler, check if it is
- -- recorded with the compiler root. If it is not, record
- -- the runtime.
-
- declare
- Runtime : constant String :=
- Runtime_Name_For (Lang_Id.Name);
- Root : String_Access;
-
- begin
- if Runtime'Length > 0 then
- if Is_Absolute_Path (Runtime) then
- Root := new String'(Runtime);
-
- else
- Root :=
- new String'
- (Prefix.all &
- Directory_Separator &
- Opt.Target_Value.all &
- Directory_Separator &
- Runtime);
- end if;
-
- Runtime_Root := Compiler_Root.Runtimes;
- while Runtime_Root /= null loop
- exit when Root.all = Runtime_Root.Root.all;
- Runtime_Root := Runtime_Root.Next;
- end loop;
-
- if Runtime_Root = null then
- Compiler_Root.Runtimes :=
- new Runtime_Root_Data'
- (Root => Root,
- Next => Compiler_Root.Runtimes);
- end if;
- end if;
- end;
- end if;
- end if;
- end if;
-
- Lang_Id := Lang_Id.Next;
- end loop;
- end Look_For_Project_Paths;
-end Prj.Conf;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . C O N F --
--- --
--- S p e c --
--- --
--- Copyright (C) 2006-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- The following package manipulates the configuration files
-
-with Prj.Tree;
-with Prj.Proc;
-
-package Prj.Conf is
-
- type Config_File_Hook is access procedure
- (Config_File : in out Prj.Tree.Project_Node_Id;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref);
- -- Hook called after the config file has been parsed. This lets the
- -- application do last minute changes to it (GPS uses this to add the
- -- default naming schemes for instance). At that point, the config file
- -- has not been applied to the project yet. When no config file was found,
- -- and automatic generation is disabled, it is possible that Config_File
- -- is set to Empty_Node when this procedure is called. You can then decide
- -- to create a new config file if you need.
-
- No_Configuration_File : constant String := "/";
- -- When specified as a parameter Config_File_Name in the procedures below,
- -- no existing configuration project file is parsed. This is used by
- -- gnatmake, gnatclean and the GNAT driver to avoid parsing an existing
- -- default configuration project file.
-
- procedure Parse_Project_And_Apply_Config
- (Main_Project : out Prj.Project_Id;
- User_Project_Node : out Prj.Tree.Project_Node_Id;
- Config_File_Name : String := "";
- Autoconf_Specified : Boolean;
- Project_File_Name : String;
- Project_Tree : Prj.Project_Tree_Ref;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Packages_To_Check : String_List_Access;
- Allow_Automatic_Generation : Boolean := True;
- Automatically_Generated : out Boolean;
- Config_File_Path : out String_Access;
- Target_Name : String := "";
- Normalized_Hostname : String;
- On_Load_Config : Config_File_Hook := null;
- Implicit_Project : Boolean := False;
- On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null);
- -- Find the main configuration project and parse the project tree rooted at
- -- this configuration project.
- --
- -- Project_Node_Tree must have been initialized first (and possibly the
- -- value for external references and project path should also have been
- -- set).
- --
- -- If the processing fails, Main_Project is set to No_Project. If the error
- -- happened while parsing the project itself (i.e. creating the tree),
- -- User_Project_Node is also set to Empty_Node.
- --
- -- If Config_File_Name is No_Configuration_File, then no configuration
- -- project file is parsed. Normally, in this case On_Load_Config is not
- -- null, and it is used to create a configuration project file in memory.
- --
- -- Autoconf_Specified indicates whether the user has specified --autoconf.
- -- If this is the case, the config file might be (re)generated, as
- -- appropriate, to match languages and target if the one specified doesn't
- -- already match.
- --
- -- Normalized_Hostname is the host on which gprbuild is returned,
- -- normalized so that we can more easily compare it with what is stored in
- -- configuration files. It is used when the target is unspecified, although
- -- we need to know the target specified by the user (Target_Name) when
- -- computing the name of the default config file that should be used.
- --
- -- If specified, On_Load_Config is called just after the config file has
- -- been created/loaded. You can then modify it before it is later applied
- -- to the project itself.
- --
- -- Any error in generating or parsing the config file is reported via the
- -- Invalid_Config exception, with an appropriate message. Any error while
- -- parsing the project file results in No_Project.
- --
- -- If Implicit_Project is True, the main project file being parsed is
- -- deemed to be in the current working directory, even if it is not the
- -- case. Implicit_Project is set to True when a tool such as gprbuild is
- -- invoked without a project file and is using an implicit project file
- -- that is virtually in the current working directory, but is physically
- -- in another directory.
- --
- -- If specified, On_New_Tree_Loaded is called after each aggregated project
- -- has been processed successfully.
-
- procedure Process_Project_And_Apply_Config
- (Main_Project : out Prj.Project_Id;
- User_Project_Node : Prj.Tree.Project_Node_Id;
- Config_File_Name : String := "";
- Autoconf_Specified : Boolean;
- Project_Tree : Prj.Project_Tree_Ref;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Packages_To_Check : String_List_Access;
- Allow_Automatic_Generation : Boolean := True;
- Automatically_Generated : out Boolean;
- Config_File_Path : out String_Access;
- Target_Name : String := "";
- Normalized_Hostname : String;
- On_Load_Config : Config_File_Hook := null;
- Reset_Tree : Boolean := True;
- On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null;
- Do_Phase_1 : Boolean := True);
- -- Same as above, except the project must already have been parsed through
- -- Prj.Part.Parse, and only the processing of the project and the
- -- configuration is done at this level.
- --
- -- If Reset_Tree is true, all projects are first removed from the tree.
- -- When_No_Sources indicates what should be done when no sources are found
- -- for one of the languages of the project.
- --
- -- If Require_Sources_Other_Lang is true, then all languages must have at
- -- least one source file, or an error is reported via When_No_Sources. If
- -- it is false, this is only required for Ada (and only if it is a language
- -- of the project).
- --
- -- If Do_Phase_1 is False, then Prj.Proc.Process_Project_Tree_Phase_1
- -- should not be called, as it has already been invoked successfully.
-
- Invalid_Config : exception;
-
- procedure Get_Or_Create_Configuration_File
- (Project : Prj.Project_Id;
- Conf_Project : Project_Id;
- Project_Tree : Prj.Project_Tree_Ref;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Allow_Automatic_Generation : Boolean;
- Config_File_Name : String := "";
- Autoconf_Specified : Boolean;
- Target_Name : String := "";
- Normalized_Hostname : String;
- Packages_To_Check : String_List_Access := null;
- Config : out Prj.Project_Id;
- Config_File_Path : out String_Access;
- Automatically_Generated : out Boolean;
- On_Load_Config : Config_File_Hook := null);
- -- Compute the name of the configuration file that should be used. If no
- -- default configuration file is found, a new one will be automatically
- -- generated if Allow_Automatic_Generation is true. This configuration
- -- project file will be generated in the object directory of project
- -- Conf_Project.
- --
- -- Any error in generating or parsing the config file is reported via the
- -- Invalid_Config exception, with an appropriate message.
- --
- -- On exit, Configuration_Project_Path is never null (if none could be
- -- found, Os.Fail was called and the program exited anyway).
- --
- -- The choice and generation of a configuration file depends on several
- -- attributes of the user's project file (given by the Project argument),
- -- e.g. list of languages that must be supported. Project must therefore
- -- have been partially processed (phase one of the processing only).
- --
- -- Config_File_Name should be set to the name of the config file specified
- -- by the user (either through gprbuild's --config or --autoconf switches).
- -- In the latter case, Autoconf_Specified should be set to true to indicate
- -- that the configuration file can be regenerated to match target and
- -- languages. This name can either be an absolute path, or the base name
- -- that will be searched in the default config file directories (which
- -- depends on the installation path for the tools).
- --
- -- Target_Name is used to chose the configuration file that will be used
- -- from among several possibilities.
- --
- -- If a project file could be found, it is automatically parsed and
- -- processed (and Packages_To_Check is used to indicate which packages
- -- should be processed).
-
- procedure Add_Default_GNAT_Naming_Scheme
- (Config_File : in out Prj.Tree.Project_Node_Id;
- Project_Tree : Prj.Tree.Project_Node_Tree_Ref);
- -- A hook that will create a new config file (in memory), used for
- -- Get_Or_Create_Configuration_File and Process_Project_And_Apply_Config
- -- and add the default GNAT naming scheme to it. Nothing is done if the
- -- config_file already exists, to avoid overriding what the user might
- -- have put in there.
-
- --------------
- -- Runtimes --
- --------------
-
- procedure Set_Runtime_For (Language : Name_Id; RTS_Name : String);
- -- Specifies the runtime to use for a specific language. Most of the time
- -- this should be used for Ada, but other languages can also specify their
- -- own runtime. This is in general specified via the --RTS command line
- -- switch, and results in a specific component passed to gprconfig's
- -- --config switch then automatically generating a configuration file.
-
- function Runtime_Name_For (Language : Name_Id) return String;
- -- Returns the runtime name for a language. Returns an empty string if no
- -- runtime was specified for the language using option --RTS.
-
- function Runtime_Name_Set_For (Language : Name_Id) return Boolean;
- -- Returns True only if Set_Runtime_For has been called for the Language
-
-end Prj.Conf;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . D E C T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Err_Vars; use Err_Vars;
-with Opt; use Opt;
-with Prj.Attr; use Prj.Attr;
-with Prj.Attr.PM; use Prj.Attr.PM;
-with Prj.Err; use Prj.Err;
-with Prj.Strt; use Prj.Strt;
-with Prj.Tree; use Prj.Tree;
-with Snames;
-with Uintp; use Uintp;
-
-with GNAT; use GNAT;
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
-with GNAT.Strings;
-
-package body Prj.Dect is
-
- type Zone is (In_Project, In_Package, In_Case_Construction);
- -- Used to indicate if we are parsing a package (In_Package), a case
- -- construction (In_Case_Construction) or none of those two (In_Project).
-
- procedure Rename_Obsolescent_Attributes
- (In_Tree : Project_Node_Tree_Ref;
- Attribute : Project_Node_Id;
- Current_Package : Project_Node_Id);
- -- Rename obsolescent attributes in the tree. When the attribute has been
- -- renamed since its initial introduction in the design of projects, we
- -- replace the old name in the tree with the new name, so that the code
- -- does not have to check both names forever.
-
- procedure Check_Attribute_Allowed
- (In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id;
- Attribute : Project_Node_Id;
- Flags : Processing_Flags);
- -- Check whether the attribute is valid in this project. In particular,
- -- depending on the type of project (qualifier), some attributes might
- -- be disabled.
-
- procedure Check_Package_Allowed
- (In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags);
- -- Check whether the package is valid in this project
-
- procedure Parse_Attribute_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- Attribute : out Project_Node_Id;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Flags : Processing_Flags);
- -- Parse an attribute declaration
-
- procedure Parse_Case_Construction
- (In_Tree : Project_Node_Tree_Ref;
- Case_Construction : out Project_Node_Id;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags);
- -- Parse a case construction
-
- procedure Parse_Declarative_Items
- (In_Tree : Project_Node_Tree_Ref;
- Declarations : out Project_Node_Id;
- In_Zone : Zone;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags);
- -- Parse declarative items. Depending on In_Zone, some declarative items
- -- may be forbidden. Is_Config_File should be set to True if the project
- -- represents a config file (.cgpr) since some specific checks apply.
-
- procedure Parse_Package_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- Package_Declaration : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags);
- -- Parse a package declaration.
- -- Is_Config_File should be set to True if the project represents a config
- -- file (.cgpr) since some specific checks apply.
-
- procedure Parse_String_Type_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- String_Type : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Flags : Processing_Flags);
- -- type <name> is ( <literal_string> { , <literal_string> } ) ;
-
- procedure Parse_Variable_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- Variable : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags);
- -- Parse a variable assignment
- -- <variable_Name> := <expression>; OR
- -- <variable_Name> : <string_type_Name> := <string_expression>;
-
- -----------
- -- Parse --
- -----------
-
- procedure Parse
- (In_Tree : Project_Node_Tree_Ref;
- Declarations : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Extends : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags)
- is
- First_Declarative_Item : Project_Node_Id := Empty_Node;
-
- begin
- Declarations :=
- Default_Project_Node
- (Of_Kind => N_Project_Declaration, In_Tree => In_Tree);
- Set_Location_Of (Declarations, In_Tree, To => Token_Ptr);
- Set_Extended_Project_Of (Declarations, In_Tree, To => Extends);
- Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations);
- Parse_Declarative_Items
- (Declarations => First_Declarative_Item,
- In_Tree => In_Tree,
- In_Zone => In_Project,
- First_Attribute => Prj.Attr.Attribute_First,
- Current_Project => Current_Project,
- Current_Package => Empty_Node,
- Packages_To_Check => Packages_To_Check,
- Is_Config_File => Is_Config_File,
- Flags => Flags);
- Set_First_Declarative_Item_Of
- (Declarations, In_Tree, To => First_Declarative_Item);
- end Parse;
-
- -----------------------------------
- -- Rename_Obsolescent_Attributes --
- -----------------------------------
-
- procedure Rename_Obsolescent_Attributes
- (In_Tree : Project_Node_Tree_Ref;
- Attribute : Project_Node_Id;
- Current_Package : Project_Node_Id)
- is
- begin
- if Present (Current_Package)
- and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored
- then
- case Name_Of (Attribute, In_Tree) is
- when Snames.Name_Specification =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec);
-
- when Snames.Name_Specification_Suffix =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix);
-
- when Snames.Name_Implementation =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body);
-
- when Snames.Name_Implementation_Suffix =>
- Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix);
-
- when others =>
- null;
- end case;
- end if;
- end Rename_Obsolescent_Attributes;
-
- ---------------------------
- -- Check_Package_Allowed --
- ---------------------------
-
- procedure Check_Package_Allowed
- (In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags)
- is
- Qualif : constant Project_Qualifier :=
- Project_Qualifier_Of (Project, In_Tree);
- Name : constant Name_Id := Name_Of (Current_Package, In_Tree);
- begin
- if Name /= Snames.Name_Ide
- and then
- ((Qualif = Aggregate and then Name /= Snames.Name_Builder)
- or else
- (Qualif = Aggregate_Library and then Name /= Snames.Name_Builder
- and then Name /= Snames.Name_Install))
- then
- Error_Msg_Name_1 := Name;
- Error_Msg
- (Flags,
- "package %% is forbidden in aggregate projects",
- Location_Of (Current_Package, In_Tree));
- end if;
- end Check_Package_Allowed;
-
- -----------------------------
- -- Check_Attribute_Allowed --
- -----------------------------
-
- procedure Check_Attribute_Allowed
- (In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id;
- Attribute : Project_Node_Id;
- Flags : Processing_Flags)
- is
- Qualif : constant Project_Qualifier :=
- Project_Qualifier_Of (Project, In_Tree);
- Name : constant Name_Id := Name_Of (Attribute, In_Tree);
-
- begin
- case Qualif is
- when Aggregate
- | Aggregate_Library
- =>
- if Name = Snames.Name_Languages
- or else Name = Snames.Name_Source_Files
- or else Name = Snames.Name_Source_List_File
- or else Name = Snames.Name_Locally_Removed_Files
- or else Name = Snames.Name_Excluded_Source_Files
- or else Name = Snames.Name_Excluded_Source_List_File
- or else Name = Snames.Name_Interfaces
- or else Name = Snames.Name_Object_Dir
- or else Name = Snames.Name_Exec_Dir
- or else Name = Snames.Name_Source_Dirs
- or else Name = Snames.Name_Inherit_Source_Path
- or else
- (Qualif = Aggregate and then Name = Snames.Name_Library_Dir)
- or else
- (Qualif = Aggregate and then Name = Snames.Name_Library_Name)
- or else Name = Snames.Name_Main
- or else Name = Snames.Name_Roots
- or else Name = Snames.Name_Externally_Built
- or else Name = Snames.Name_Executable
- or else Name = Snames.Name_Executable_Suffix
- or else Name = Snames.Name_Default_Switches
- then
- Error_Msg_Name_1 := Name;
- Error_Msg
- (Flags,
- "%% is not valid in aggregate projects",
- Location_Of (Attribute, In_Tree));
- end if;
-
- when others =>
- if Name = Snames.Name_Project_Files
- or else Name = Snames.Name_Project_Path
- or else Name = Snames.Name_External
- then
- Error_Msg_Name_1 := Name;
- Error_Msg
- (Flags,
- "%% is only valid in aggregate projects",
- Location_Of (Attribute, In_Tree));
- end if;
- end case;
- end Check_Attribute_Allowed;
-
- ---------------------------------
- -- Parse_Attribute_Declaration --
- ---------------------------------
-
- procedure Parse_Attribute_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- Attribute : out Project_Node_Id;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Flags : Processing_Flags)
- is
- Current_Attribute : Attribute_Node_Id := First_Attribute;
- Full_Associative_Array : Boolean := False;
- Attribute_Name : Name_Id := No_Name;
- Optional_Index : Boolean := False;
- Pkg_Id : Package_Node_Id := Empty_Package;
-
- procedure Process_Attribute_Name;
- -- Read the name of the attribute, and check its type
-
- procedure Process_Associative_Array_Index;
- -- Read the index of the associative array and check its validity
-
- ----------------------------
- -- Process_Attribute_Name --
- ----------------------------
-
- procedure Process_Attribute_Name is
- Ignore : Boolean;
-
- begin
- Attribute_Name := Token_Name;
- Set_Name_Of (Attribute, In_Tree, To => Attribute_Name);
- Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
-
- -- Find the attribute
-
- Current_Attribute :=
- Attribute_Node_Id_Of (Attribute_Name, First_Attribute);
-
- -- If the attribute cannot be found, create the attribute if inside
- -- an unknown package.
-
- if Current_Attribute = Empty_Attribute then
- if Present (Current_Package)
- and then Expression_Kind_Of (Current_Package, In_Tree) = Ignored
- then
- Pkg_Id := Package_Id_Of (Current_Package, In_Tree);
- Add_Attribute (Pkg_Id, Token_Name, Current_Attribute);
-
- else
- -- If not a valid attribute name, issue an error if inside
- -- a package that need to be checked.
-
- Ignore := Present (Current_Package) and then
- Packages_To_Check /= All_Packages;
-
- if Ignore then
-
- -- Check that we are not in a package to check
-
- Get_Name_String (Name_Of (Current_Package, In_Tree));
-
- for Index in Packages_To_Check'Range loop
- if Name_Buffer (1 .. Name_Len) =
- Packages_To_Check (Index).all
- then
- Ignore := False;
- exit;
- end if;
- end loop;
- end if;
-
- if not Ignore then
- Error_Msg_Name_1 := Token_Name;
- Error_Msg (Flags, "undefined attribute %%", Token_Ptr);
- end if;
- end if;
-
- -- Set, if appropriate the index case insensitivity flag
-
- else
- if Is_Read_Only (Current_Attribute) then
- Error_Msg_Name_1 := Token_Name;
- Error_Msg
- (Flags, "read-only attribute %% cannot be given a value",
- Token_Ptr);
- end if;
-
- if Attribute_Kind_Of (Current_Attribute) in
- All_Case_Insensitive_Associative_Array
- then
- Set_Case_Insensitive (Attribute, In_Tree, To => True);
- end if;
- end if;
-
- Scan (In_Tree); -- past the attribute name
-
- -- Set the expression kind of the attribute
-
- if Current_Attribute /= Empty_Attribute then
- Set_Expression_Kind_Of
- (Attribute, In_Tree, To => Variable_Kind_Of (Current_Attribute));
- Optional_Index := Optional_Index_Of (Current_Attribute);
- end if;
- end Process_Attribute_Name;
-
- -------------------------------------
- -- Process_Associative_Array_Index --
- -------------------------------------
-
- procedure Process_Associative_Array_Index is
- begin
- -- If the attribute is not an associative array attribute, report
- -- an error. If this information is still unknown, set the kind
- -- to Associative_Array.
-
- if Current_Attribute /= Empty_Attribute
- and then Attribute_Kind_Of (Current_Attribute) = Single
- then
- Error_Msg (Flags,
- "the attribute """ &
- Get_Name_String (Attribute_Name_Of (Current_Attribute))
- & """ cannot be an associative array",
- Location_Of (Attribute, In_Tree));
-
- elsif Attribute_Kind_Of (Current_Attribute) = Unknown then
- Set_Attribute_Kind_Of (Current_Attribute, To => Associative_Array);
- end if;
-
- Scan (In_Tree); -- past the left parenthesis
-
- if Others_Allowed_For (Current_Attribute)
- and then Token = Tok_Others
- then
- Set_Associative_Array_Index_Of
- (Attribute, In_Tree, All_Other_Names);
- Scan (In_Tree); -- past others
-
- else
- if Others_Allowed_For (Current_Attribute) then
- Expect (Tok_String_Literal, "literal string or others");
- else
- Expect (Tok_String_Literal, "literal string");
- end if;
-
- if Token = Tok_String_Literal then
- Get_Name_String (Token_Name);
-
- if Case_Insensitive (Attribute, In_Tree) then
- To_Lower (Name_Buffer (1 .. Name_Len));
- end if;
-
- Set_Associative_Array_Index_Of (Attribute, In_Tree, Name_Find);
- Scan (In_Tree); -- past the literal string index
-
- if Token = Tok_At then
- case Attribute_Kind_Of (Current_Attribute) is
- when Optional_Index_Associative_Array
- | Optional_Index_Case_Insensitive_Associative_Array
- =>
- Scan (In_Tree);
- Expect (Tok_Integer_Literal, "integer literal");
-
- if Token = Tok_Integer_Literal then
-
- -- Set the source index value from given literal
-
- declare
- Index : constant Int :=
- UI_To_Int (Int_Literal_Value);
- begin
- if Index = 0 then
- Error_Msg
- (Flags, "index cannot be zero", Token_Ptr);
- else
- Set_Source_Index_Of
- (Attribute, In_Tree, To => Index);
- end if;
- end;
-
- Scan (In_Tree);
- end if;
-
- when others =>
- Error_Msg (Flags, "index not allowed here", Token_Ptr);
- Scan (In_Tree);
-
- if Token = Tok_Integer_Literal then
- Scan (In_Tree);
- end if;
- end case;
- end if;
- end if;
- end if;
-
- Expect (Tok_Right_Paren, "`)`");
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree); -- past the right parenthesis
- end if;
- end Process_Associative_Array_Index;
-
- begin
- Attribute :=
- Default_Project_Node
- (Of_Kind => N_Attribute_Declaration, In_Tree => In_Tree);
- Set_Location_Of (Attribute, In_Tree, To => Token_Ptr);
- Set_Previous_Line_Node (Attribute);
-
- -- Scan past "for"
-
- Scan (In_Tree);
-
- -- Body or External may be an attribute name
-
- if Token = Tok_Body then
- Token := Tok_Identifier;
- Token_Name := Snames.Name_Body;
- end if;
-
- if Token = Tok_External then
- Token := Tok_Identifier;
- Token_Name := Snames.Name_External;
- end if;
-
- Expect (Tok_Identifier, "identifier");
- Process_Attribute_Name;
- Rename_Obsolescent_Attributes (In_Tree, Attribute, Current_Package);
- Check_Attribute_Allowed (In_Tree, Current_Project, Attribute, Flags);
-
- -- Associative array attributes
-
- if Token = Tok_Left_Paren then
- Process_Associative_Array_Index;
-
- else
- -- If it is an associative array attribute and there are no left
- -- parenthesis, then this is a full associative array declaration.
- -- Flag it as such for later processing of its value.
-
- if Current_Attribute /= Empty_Attribute
- and then
- Attribute_Kind_Of (Current_Attribute) /= Single
- then
- if Attribute_Kind_Of (Current_Attribute) = Unknown then
- Set_Attribute_Kind_Of (Current_Attribute, To => Single);
-
- else
- Full_Associative_Array := True;
- end if;
- end if;
- end if;
-
- Expect (Tok_Use, "USE");
-
- if Token = Tok_Use then
- Scan (In_Tree);
-
- if Full_Associative_Array then
-
- -- Expect <project>'<same_attribute_name>, or
- -- <project>.<same_package_name>'<same_attribute_name>
-
- declare
- The_Project : Project_Node_Id := Empty_Node;
- -- The node of the project where the associative array is
- -- declared.
-
- The_Package : Project_Node_Id := Empty_Node;
- -- The node of the package where the associative array is
- -- declared, if any.
-
- Project_Name : Name_Id := No_Name;
- -- The name of the project where the associative array is
- -- declared.
-
- Location : Source_Ptr := No_Location;
- -- The location of the project name
-
- begin
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- Location := Token_Ptr;
-
- -- Find the project node in the imported project or
- -- in the project being extended.
-
- The_Project := Imported_Or_Extended_Project_Of
- (Current_Project, In_Tree, Token_Name);
-
- if No (The_Project) and then not In_Tree.Incomplete_With then
- Error_Msg (Flags, "unknown project", Location);
- Scan (In_Tree); -- past the project name
-
- else
- Project_Name := Token_Name;
- Scan (In_Tree); -- past the project name
-
- -- If this is inside a package, a dot followed by the
- -- name of the package must followed the project name.
-
- if Present (Current_Package) then
- Expect (Tok_Dot, "`.`");
-
- if Token /= Tok_Dot then
- The_Project := Empty_Node;
-
- else
- Scan (In_Tree); -- past the dot
- Expect (Tok_Identifier, "identifier");
-
- if Token /= Tok_Identifier then
- The_Project := Empty_Node;
-
- -- If it is not the same package name, issue error
-
- elsif
- Token_Name /= Name_Of (Current_Package, In_Tree)
- then
- The_Project := Empty_Node;
- Error_Msg
- (Flags, "not the same package as " &
- Get_Name_String
- (Name_Of (Current_Package, In_Tree)),
- Token_Ptr);
- Scan (In_Tree); -- past the package name
-
- else
- if Present (The_Project) then
- The_Package :=
- First_Package_Of (The_Project, In_Tree);
-
- -- Look for the package node
-
- while Present (The_Package)
- and then Name_Of (The_Package, In_Tree) /=
- Token_Name
- loop
- The_Package :=
- Next_Package_In_Project
- (The_Package, In_Tree);
- end loop;
-
- -- If the package cannot be found in the
- -- project, issue an error.
-
- if No (The_Package) then
- The_Project := Empty_Node;
- Error_Msg_Name_2 := Project_Name;
- Error_Msg_Name_1 := Token_Name;
- Error_Msg
- (Flags,
- "package % not declared in project %",
- Token_Ptr);
- end if;
- end if;
-
- Scan (In_Tree); -- past the package name
- end if;
- end if;
- end if;
- end if;
- end if;
-
- if Present (The_Project) or else In_Tree.Incomplete_With then
-
- -- Looking for '<same attribute name>
-
- Expect (Tok_Apostrophe, "`''`");
-
- if Token /= Tok_Apostrophe then
- The_Project := Empty_Node;
-
- else
- Scan (In_Tree); -- past the apostrophe
- Expect (Tok_Identifier, "identifier");
-
- if Token /= Tok_Identifier then
- The_Project := Empty_Node;
-
- else
- -- If it is not the same attribute name, issue error
-
- if Token_Name /= Attribute_Name then
- The_Project := Empty_Node;
- Error_Msg_Name_1 := Attribute_Name;
- Error_Msg
- (Flags, "invalid name, should be %", Token_Ptr);
- end if;
-
- Scan (In_Tree); -- past the attribute name
- end if;
- end if;
- end if;
-
- if No (The_Project) then
-
- -- If there were any problem, set the attribute id to null,
- -- so that the node will not be recorded.
-
- Current_Attribute := Empty_Attribute;
-
- else
- -- Set the appropriate field in the node.
- -- Note that the index and the expression are nil. This
- -- characterizes full associative array attribute
- -- declarations.
-
- Set_Associative_Project_Of (Attribute, In_Tree, The_Project);
- Set_Associative_Package_Of (Attribute, In_Tree, The_Package);
- end if;
- end;
-
- -- Other attribute declarations (not full associative array)
-
- else
- declare
- Expression_Location : constant Source_Ptr := Token_Ptr;
- -- The location of the first token of the expression
-
- Expression : Project_Node_Id := Empty_Node;
- -- The expression, value for the attribute declaration
-
- begin
- -- Get the expression value and set it in the attribute node
-
- Parse_Expression
- (In_Tree => In_Tree,
- Expression => Expression,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Optional_Index => Optional_Index);
- Set_Expression_Of (Attribute, In_Tree, To => Expression);
-
- -- If the expression is legal, but not of the right kind
- -- for the attribute, issue an error.
-
- if Current_Attribute /= Empty_Attribute
- and then Present (Expression)
- and then Variable_Kind_Of (Current_Attribute) /=
- Expression_Kind_Of (Expression, In_Tree)
- then
- if Variable_Kind_Of (Current_Attribute) = Undefined then
- Set_Variable_Kind_Of
- (Current_Attribute,
- To => Expression_Kind_Of (Expression, In_Tree));
-
- else
- Error_Msg
- (Flags, "wrong expression kind for attribute """ &
- Get_Name_String
- (Attribute_Name_Of (Current_Attribute)) &
- """",
- Expression_Location);
- end if;
- end if;
- end;
- end if;
- end if;
-
- -- If the attribute was not recognized, return an empty node.
- -- It may be that it is not in a package to check, and the node will
- -- not be added to the tree.
-
- if Current_Attribute = Empty_Attribute then
- Attribute := Empty_Node;
- end if;
-
- Set_End_Of_Line (Attribute);
- Set_Previous_Line_Node (Attribute);
- end Parse_Attribute_Declaration;
-
- -----------------------------
- -- Parse_Case_Construction --
- -----------------------------
-
- procedure Parse_Case_Construction
- (In_Tree : Project_Node_Tree_Ref;
- Case_Construction : out Project_Node_Id;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags)
- is
- Current_Item : Project_Node_Id := Empty_Node;
- Next_Item : Project_Node_Id := Empty_Node;
- First_Case_Item : Boolean := True;
-
- Variable_Location : Source_Ptr := No_Location;
-
- String_Type : Project_Node_Id := Empty_Node;
-
- Case_Variable : Project_Node_Id := Empty_Node;
-
- First_Declarative_Item : Project_Node_Id := Empty_Node;
-
- First_Choice : Project_Node_Id := Empty_Node;
-
- When_Others : Boolean := False;
- -- Set to True when there is a "when others =>" clause
-
- begin
- Case_Construction :=
- Default_Project_Node
- (Of_Kind => N_Case_Construction, In_Tree => In_Tree);
- Set_Location_Of (Case_Construction, In_Tree, To => Token_Ptr);
-
- -- Scan past "case"
-
- Scan (In_Tree);
-
- -- Get the switch variable
-
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- Variable_Location := Token_Ptr;
- Parse_Variable_Reference
- (In_Tree => In_Tree,
- Variable => Case_Variable,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package);
- Set_Case_Variable_Reference_Of
- (Case_Construction, In_Tree, To => Case_Variable);
-
- else
- if Token /= Tok_Is then
- Scan (In_Tree);
- end if;
- end if;
-
- if Present (Case_Variable) then
- String_Type := String_Type_Of (Case_Variable, In_Tree);
-
- if Expression_Kind_Of (Case_Variable, In_Tree) /= Single then
- Error_Msg (Flags,
- "variable """ &
- Get_Name_String (Name_Of (Case_Variable, In_Tree)) &
- """ is not a single string",
- Variable_Location);
- end if;
- end if;
-
- Expect (Tok_Is, "IS");
-
- if Token = Tok_Is then
- Set_End_Of_Line (Case_Construction);
- Set_Previous_Line_Node (Case_Construction);
- Set_Next_End_Node (Case_Construction);
-
- -- Scan past "is"
-
- Scan (In_Tree);
- end if;
-
- Start_New_Case_Construction (In_Tree, String_Type);
-
- When_Loop :
-
- while Token = Tok_When loop
-
- if First_Case_Item then
- Current_Item :=
- Default_Project_Node
- (Of_Kind => N_Case_Item, In_Tree => In_Tree);
- Set_First_Case_Item_Of
- (Case_Construction, In_Tree, To => Current_Item);
- First_Case_Item := False;
-
- else
- Next_Item :=
- Default_Project_Node
- (Of_Kind => N_Case_Item, In_Tree => In_Tree);
- Set_Next_Case_Item (Current_Item, In_Tree, To => Next_Item);
- Current_Item := Next_Item;
- end if;
-
- Set_Location_Of (Current_Item, In_Tree, To => Token_Ptr);
-
- -- Scan past "when"
-
- Scan (In_Tree);
-
- if Token = Tok_Others then
- When_Others := True;
-
- -- Scan past "others"
-
- Scan (In_Tree);
-
- Expect (Tok_Arrow, "`=>`");
- Set_End_Of_Line (Current_Item);
- Set_Previous_Line_Node (Current_Item);
-
- -- Empty_Node in Field1 of a Case_Item indicates
- -- the "when others =>" branch.
-
- Set_First_Choice_Of (Current_Item, In_Tree, To => Empty_Node);
-
- Parse_Declarative_Items
- (In_Tree => In_Tree,
- Declarations => First_Declarative_Item,
- In_Zone => In_Case_Construction,
- First_Attribute => First_Attribute,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check,
- Is_Config_File => Is_Config_File,
- Flags => Flags);
-
- -- "when others =>" must be the last branch, so save the
- -- Case_Item and exit
-
- Set_First_Declarative_Item_Of
- (Current_Item, In_Tree, To => First_Declarative_Item);
- exit When_Loop;
-
- else
- Parse_Choice_List
- (In_Tree => In_Tree,
- First_Choice => First_Choice,
- Flags => Flags,
- String_Type => Present (String_Type));
- Set_First_Choice_Of (Current_Item, In_Tree, To => First_Choice);
-
- Expect (Tok_Arrow, "`=>`");
- Set_End_Of_Line (Current_Item);
- Set_Previous_Line_Node (Current_Item);
-
- Parse_Declarative_Items
- (In_Tree => In_Tree,
- Declarations => First_Declarative_Item,
- In_Zone => In_Case_Construction,
- First_Attribute => First_Attribute,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check,
- Is_Config_File => Is_Config_File,
- Flags => Flags);
-
- Set_First_Declarative_Item_Of
- (Current_Item, In_Tree, To => First_Declarative_Item);
-
- end if;
- end loop When_Loop;
-
- End_Case_Construction
- (Check_All_Labels => not When_Others and not Quiet_Output,
- Case_Location => Location_Of (Case_Construction, In_Tree),
- Flags => Flags,
- String_Type => Present (String_Type));
-
- Expect (Tok_End, "`END CASE`");
- Remove_Next_End_Node;
-
- if Token = Tok_End then
-
- -- Scan past "end"
-
- Scan (In_Tree);
-
- Expect (Tok_Case, "CASE");
-
- end if;
-
- -- Scan past "case"
-
- Scan (In_Tree);
-
- Expect (Tok_Semicolon, "`;`");
- Set_Previous_End_Node (Case_Construction);
-
- end Parse_Case_Construction;
-
- -----------------------------
- -- Parse_Declarative_Items --
- -----------------------------
-
- procedure Parse_Declarative_Items
- (In_Tree : Project_Node_Tree_Ref;
- Declarations : out Project_Node_Id;
- In_Zone : Zone;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags)
- is
- Current_Declarative_Item : Project_Node_Id := Empty_Node;
- Next_Declarative_Item : Project_Node_Id := Empty_Node;
- Current_Declaration : Project_Node_Id := Empty_Node;
- Item_Location : Source_Ptr := No_Location;
-
- begin
- Declarations := Empty_Node;
-
- loop
- -- We are always positioned at the token that precedes the first
- -- token of the declarative element. Scan past it.
-
- Scan (In_Tree);
-
- Item_Location := Token_Ptr;
-
- case Token is
- when Tok_Identifier =>
-
- if In_Zone = In_Case_Construction then
-
- -- Check if the variable has already been declared
-
- declare
- The_Variable : Project_Node_Id := Empty_Node;
-
- begin
- if Present (Current_Package) then
- The_Variable :=
- First_Variable_Of (Current_Package, In_Tree);
- elsif Present (Current_Project) then
- The_Variable :=
- First_Variable_Of (Current_Project, In_Tree);
- end if;
-
- while Present (The_Variable)
- and then Name_Of (The_Variable, In_Tree) /=
- Token_Name
- loop
- The_Variable := Next_Variable (The_Variable, In_Tree);
- end loop;
-
- -- It is an error to declare a variable in a case
- -- construction for the first time.
-
- if No (The_Variable) then
- Error_Msg
- (Flags, "a variable cannot be declared for the "
- & "first time here", Token_Ptr);
- end if;
- end;
- end if;
-
- Parse_Variable_Declaration
- (In_Tree,
- Current_Declaration,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Flags => Flags);
-
- Set_End_Of_Line (Current_Declaration);
- Set_Previous_Line_Node (Current_Declaration);
-
- when Tok_For =>
- Parse_Attribute_Declaration
- (In_Tree => In_Tree,
- Attribute => Current_Declaration,
- First_Attribute => First_Attribute,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check,
- Flags => Flags);
-
- Set_End_Of_Line (Current_Declaration);
- Set_Previous_Line_Node (Current_Declaration);
-
- when Tok_Null =>
- Scan (In_Tree); -- past "null"
-
- when Tok_Package =>
-
- -- Package declaration
-
- if In_Zone /= In_Project then
- Error_Msg
- (Flags, "a package cannot be declared here", Token_Ptr);
- end if;
-
- Parse_Package_Declaration
- (In_Tree => In_Tree,
- Package_Declaration => Current_Declaration,
- Current_Project => Current_Project,
- Packages_To_Check => Packages_To_Check,
- Is_Config_File => Is_Config_File,
- Flags => Flags);
-
- Set_Previous_End_Node (Current_Declaration);
-
- when Tok_Type =>
-
- -- Type String Declaration
-
- if In_Zone /= In_Project then
- Error_Msg (Flags,
- "a string type cannot be declared here",
- Token_Ptr);
- end if;
-
- Parse_String_Type_Declaration
- (In_Tree => In_Tree,
- String_Type => Current_Declaration,
- Current_Project => Current_Project,
- Flags => Flags);
-
- Set_End_Of_Line (Current_Declaration);
- Set_Previous_Line_Node (Current_Declaration);
-
- when Tok_Case =>
-
- -- Case construction
-
- Parse_Case_Construction
- (In_Tree => In_Tree,
- Case_Construction => Current_Declaration,
- First_Attribute => First_Attribute,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Packages_To_Check => Packages_To_Check,
- Is_Config_File => Is_Config_File,
- Flags => Flags);
-
- Set_Previous_End_Node (Current_Declaration);
-
- when others =>
- exit;
-
- -- We are leaving Parse_Declarative_Items positioned
- -- at the first token after the list of declarative items.
- -- It could be "end" (for a project, a package declaration or
- -- a case construction) or "when" (for a case construction)
-
- end case;
-
- Expect (Tok_Semicolon, "`;` after declarative items");
-
- -- Insert an N_Declarative_Item in the tree, but only if
- -- Current_Declaration is not an empty node.
-
- if Present (Current_Declaration) then
- if No (Current_Declarative_Item) then
- Current_Declarative_Item :=
- Default_Project_Node
- (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
- Declarations := Current_Declarative_Item;
-
- else
- Next_Declarative_Item :=
- Default_Project_Node
- (Of_Kind => N_Declarative_Item, In_Tree => In_Tree);
- Set_Next_Declarative_Item
- (Current_Declarative_Item, In_Tree,
- To => Next_Declarative_Item);
- Current_Declarative_Item := Next_Declarative_Item;
- end if;
-
- Set_Current_Item_Node
- (Current_Declarative_Item, In_Tree,
- To => Current_Declaration);
- Set_Location_Of
- (Current_Declarative_Item, In_Tree, To => Item_Location);
- end if;
- end loop;
- end Parse_Declarative_Items;
-
- -------------------------------
- -- Parse_Package_Declaration --
- -------------------------------
-
- procedure Parse_Package_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- Package_Declaration : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags)
- is
- First_Attribute : Attribute_Node_Id := Empty_Attribute;
- Current_Package : Package_Node_Id := Empty_Package;
- First_Declarative_Item : Project_Node_Id := Empty_Node;
- Package_Location : constant Source_Ptr := Token_Ptr;
- Renaming : Boolean := False;
- Extending : Boolean := False;
-
- begin
- Package_Declaration :=
- Default_Project_Node
- (Of_Kind => N_Package_Declaration, In_Tree => In_Tree);
- Set_Location_Of (Package_Declaration, In_Tree, To => Package_Location);
-
- -- Scan past "package"
-
- Scan (In_Tree);
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- Set_Name_Of (Package_Declaration, In_Tree, To => Token_Name);
-
- Current_Package := Package_Node_Id_Of (Token_Name);
-
- if Current_Package = Empty_Package then
- if not Quiet_Output then
- declare
- List : constant Strings.String_List := Package_Name_List;
- Index : Natural;
- Name : constant String := Get_Name_String (Token_Name);
-
- begin
- -- Check for possible misspelling of a known package name
-
- Index := 0;
- loop
- if Index >= List'Last then
- Index := 0;
- exit;
- end if;
-
- Index := Index + 1;
- exit when
- GNAT.Spelling_Checker.Is_Bad_Spelling_Of
- (Name, List (Index).all);
- end loop;
-
- -- Issue warning(s) in verbose mode or when a possible
- -- misspelling has been found.
-
- if Verbose_Mode or else Index /= 0 then
- Error_Msg (Flags,
- "?""" &
- Get_Name_String
- (Name_Of (Package_Declaration, In_Tree)) &
- """ is not a known package name",
- Token_Ptr);
- end if;
-
- if Index /= 0 then
- Error_Msg -- CODEFIX
- (Flags,
- "\?possible misspelling of """ &
- List (Index).all & """", Token_Ptr);
- end if;
- end;
- end if;
-
- -- Set the package declaration to "ignored" so that it is not
- -- processed by Prj.Proc.Process.
-
- Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
-
- -- Add the unknown package in the list of packages
-
- Add_Unknown_Package (Token_Name, Current_Package);
-
- elsif Current_Package = Unknown_Package then
-
- -- Set the package declaration to "ignored" so that it is not
- -- processed by Prj.Proc.Process.
-
- Set_Expression_Kind_Of (Package_Declaration, In_Tree, Ignored);
-
- else
- First_Attribute := First_Attribute_Of (Current_Package);
- end if;
-
- Set_Package_Id_Of
- (Package_Declaration, In_Tree, To => Current_Package);
-
- declare
- Current : Project_Node_Id :=
- First_Package_Of (Current_Project, In_Tree);
-
- begin
- while Present (Current)
- and then Name_Of (Current, In_Tree) /= Token_Name
- loop
- Current := Next_Package_In_Project (Current, In_Tree);
- end loop;
-
- if Present (Current) then
- Error_Msg
- (Flags,
- "package """ &
- Get_Name_String (Name_Of (Package_Declaration, In_Tree)) &
- """ is declared twice in the same project",
- Token_Ptr);
-
- else
- -- Add the package to the project list
-
- Set_Next_Package_In_Project
- (Package_Declaration, In_Tree,
- To => First_Package_Of (Current_Project, In_Tree));
- Set_First_Package_Of
- (Current_Project, In_Tree, To => Package_Declaration);
- end if;
- end;
-
- -- Scan past the package name
-
- Scan (In_Tree);
- end if;
-
- Check_Package_Allowed
- (In_Tree, Current_Project, Package_Declaration, Flags);
-
- if Token = Tok_Renames then
- Renaming := True;
- elsif Token = Tok_Extends then
- Extending := True;
- end if;
-
- if Renaming or else Extending then
- if Is_Config_File then
- Error_Msg
- (Flags,
- "no package rename or extension in configuration projects",
- Token_Ptr);
- end if;
-
- -- Scan past "renames" or "extends"
-
- Scan (In_Tree);
-
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- declare
- Project_Name : constant Name_Id := Token_Name;
-
- Clause : Project_Node_Id :=
- First_With_Clause_Of (Current_Project, In_Tree);
- The_Project : Project_Node_Id := Empty_Node;
- Extended : constant Project_Node_Id :=
- Extended_Project_Of
- (Project_Declaration_Of
- (Current_Project, In_Tree),
- In_Tree);
- begin
- while Present (Clause) loop
- -- Only non limited imported projects may be used in a
- -- renames declaration.
-
- The_Project :=
- Non_Limited_Project_Node_Of (Clause, In_Tree);
- exit when Present (The_Project)
- and then Name_Of (The_Project, In_Tree) = Project_Name;
- Clause := Next_With_Clause_Of (Clause, In_Tree);
- end loop;
-
- if No (Clause) then
- -- As we have not found the project in the imports, we check
- -- if it's the name of an eventual extended project.
-
- if Present (Extended)
- and then Name_Of (Extended, In_Tree) = Project_Name
- then
- Set_Project_Of_Renamed_Package_Of
- (Package_Declaration, In_Tree, To => Extended);
- else
- Error_Msg_Name_1 := Project_Name;
- Error_Msg
- (Flags,
- "% is not an imported or extended project", Token_Ptr);
- end if;
- else
- Set_Project_Of_Renamed_Package_Of
- (Package_Declaration, In_Tree, To => The_Project);
- end if;
- end;
-
- Scan (In_Tree);
- Expect (Tok_Dot, "`.`");
-
- if Token = Tok_Dot then
- Scan (In_Tree);
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- if Name_Of (Package_Declaration, In_Tree) /= Token_Name then
- Error_Msg (Flags, "not the same package name", Token_Ptr);
- elsif
- Present (Project_Of_Renamed_Package_Of
- (Package_Declaration, In_Tree))
- then
- declare
- Current : Project_Node_Id :=
- First_Package_Of
- (Project_Of_Renamed_Package_Of
- (Package_Declaration, In_Tree),
- In_Tree);
-
- begin
- while Present (Current)
- and then Name_Of (Current, In_Tree) /= Token_Name
- loop
- Current :=
- Next_Package_In_Project (Current, In_Tree);
- end loop;
-
- if No (Current) then
- Error_Msg
- (Flags, """" &
- Get_Name_String (Token_Name) &
- """ is not a package declared by the project",
- Token_Ptr);
- end if;
- end;
- end if;
-
- Scan (In_Tree);
- end if;
- end if;
- end if;
- end if;
-
- if Renaming then
- Expect (Tok_Semicolon, "`;`");
- Set_End_Of_Line (Package_Declaration);
- Set_Previous_Line_Node (Package_Declaration);
-
- elsif Token = Tok_Is then
- Set_End_Of_Line (Package_Declaration);
- Set_Previous_Line_Node (Package_Declaration);
- Set_Next_End_Node (Package_Declaration);
-
- Parse_Declarative_Items
- (In_Tree => In_Tree,
- Declarations => First_Declarative_Item,
- In_Zone => In_Package,
- First_Attribute => First_Attribute,
- Current_Project => Current_Project,
- Current_Package => Package_Declaration,
- Packages_To_Check => Packages_To_Check,
- Is_Config_File => Is_Config_File,
- Flags => Flags);
-
- Set_First_Declarative_Item_Of
- (Package_Declaration, In_Tree, To => First_Declarative_Item);
-
- Expect (Tok_End, "END");
-
- if Token = Tok_End then
-
- -- Scan past "end"
-
- Scan (In_Tree);
- end if;
-
- -- We should have the name of the package after "end"
-
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier
- and then Name_Of (Package_Declaration, In_Tree) /= No_Name
- and then Token_Name /= Name_Of (Package_Declaration, In_Tree)
- then
- Error_Msg_Name_1 := Name_Of (Package_Declaration, In_Tree);
- Error_Msg (Flags, "expected %%", Token_Ptr);
- end if;
-
- if Token /= Tok_Semicolon then
-
- -- Scan past the package name
-
- Scan (In_Tree);
- end if;
-
- Expect (Tok_Semicolon, "`;`");
- Remove_Next_End_Node;
-
- else
- Error_Msg (Flags, "expected IS", Token_Ptr);
- end if;
-
- end Parse_Package_Declaration;
-
- -----------------------------------
- -- Parse_String_Type_Declaration --
- -----------------------------------
-
- procedure Parse_String_Type_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- String_Type : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Flags : Processing_Flags)
- is
- Current : Project_Node_Id := Empty_Node;
- First_String : Project_Node_Id := Empty_Node;
-
- begin
- String_Type :=
- Default_Project_Node
- (Of_Kind => N_String_Type_Declaration, In_Tree => In_Tree);
-
- Set_Location_Of (String_Type, In_Tree, To => Token_Ptr);
-
- -- Scan past "type"
-
- Scan (In_Tree);
-
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- Set_Name_Of (String_Type, In_Tree, To => Token_Name);
-
- Current := First_String_Type_Of (Current_Project, In_Tree);
- while Present (Current)
- and then
- Name_Of (Current, In_Tree) /= Token_Name
- loop
- Current := Next_String_Type (Current, In_Tree);
- end loop;
-
- if Present (Current) then
- Error_Msg (Flags,
- "duplicate string type name """ &
- Get_Name_String (Token_Name) &
- """",
- Token_Ptr);
- else
- Current := First_Variable_Of (Current_Project, In_Tree);
- while Present (Current)
- and then Name_Of (Current, In_Tree) /= Token_Name
- loop
- Current := Next_Variable (Current, In_Tree);
- end loop;
-
- if Present (Current) then
- Error_Msg (Flags,
- """" &
- Get_Name_String (Token_Name) &
- """ is already a variable name", Token_Ptr);
- else
- Set_Next_String_Type
- (String_Type, In_Tree,
- To => First_String_Type_Of (Current_Project, In_Tree));
- Set_First_String_Type_Of
- (Current_Project, In_Tree, To => String_Type);
- end if;
- end if;
-
- -- Scan past the name
-
- Scan (In_Tree);
- end if;
-
- Expect (Tok_Is, "IS");
-
- if Token = Tok_Is then
- Scan (In_Tree);
- end if;
-
- Expect (Tok_Left_Paren, "`(`");
-
- if Token = Tok_Left_Paren then
- Scan (In_Tree);
- end if;
-
- Parse_String_Type_List
- (In_Tree => In_Tree, First_String => First_String, Flags => Flags);
- Set_First_Literal_String (String_Type, In_Tree, To => First_String);
-
- Expect (Tok_Right_Paren, "`)`");
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree);
- end if;
- end Parse_String_Type_Declaration;
-
- --------------------------------
- -- Parse_Variable_Declaration --
- --------------------------------
-
- procedure Parse_Variable_Declaration
- (In_Tree : Project_Node_Tree_Ref;
- Variable : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags)
- is
- Expression_Location : Source_Ptr;
- String_Type_Name : Name_Id := No_Name;
- Project_String_Type_Name : Name_Id := No_Name;
- Type_Location : Source_Ptr := No_Location;
- Project_Location : Source_Ptr := No_Location;
- Expression : Project_Node_Id := Empty_Node;
- Variable_Name : constant Name_Id := Token_Name;
- OK : Boolean := True;
-
- begin
- Variable :=
- Default_Project_Node
- (Of_Kind => N_Variable_Declaration, In_Tree => In_Tree);
- Set_Name_Of (Variable, In_Tree, To => Variable_Name);
- Set_Location_Of (Variable, In_Tree, To => Token_Ptr);
-
- -- Scan past the variable name
-
- Scan (In_Tree);
-
- if Token = Tok_Colon then
-
- -- Typed string variable declaration
-
- Scan (In_Tree);
- Set_Kind_Of (Variable, In_Tree, N_Typed_Variable_Declaration);
- Expect (Tok_Identifier, "identifier");
-
- OK := Token = Tok_Identifier;
-
- if OK then
- String_Type_Name := Token_Name;
- Type_Location := Token_Ptr;
- Scan (In_Tree);
-
- if Token = Tok_Dot then
- Project_String_Type_Name := String_Type_Name;
- Project_Location := Type_Location;
-
- -- Scan past the dot
-
- Scan (In_Tree);
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- String_Type_Name := Token_Name;
- Type_Location := Token_Ptr;
- Scan (In_Tree);
- else
- OK := False;
- end if;
- end if;
-
- if OK then
- declare
- Proj : Project_Node_Id := Current_Project;
- Current : Project_Node_Id := Empty_Node;
-
- begin
- if Project_String_Type_Name /= No_Name then
- declare
- The_Project_Name_And_Node : constant
- Tree_Private_Part.Project_Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get
- (In_Tree.Projects_HT, Project_String_Type_Name);
-
- use Tree_Private_Part;
-
- begin
- if The_Project_Name_And_Node =
- Tree_Private_Part.No_Project_Name_And_Node
- then
- Error_Msg (Flags,
- "unknown project """ &
- Get_Name_String
- (Project_String_Type_Name) &
- """",
- Project_Location);
- Current := Empty_Node;
- else
- Current :=
- First_String_Type_Of
- (The_Project_Name_And_Node.Node, In_Tree);
- while
- Present (Current)
- and then
- Name_Of (Current, In_Tree) /= String_Type_Name
- loop
- Current := Next_String_Type (Current, In_Tree);
- end loop;
- end if;
- end;
-
- else
- -- Look for a string type with the correct name in this
- -- project or in any of its ancestors.
-
- loop
- Current :=
- First_String_Type_Of (Proj, In_Tree);
- while
- Present (Current)
- and then
- Name_Of (Current, In_Tree) /= String_Type_Name
- loop
- Current := Next_String_Type (Current, In_Tree);
- end loop;
-
- exit when Present (Current);
-
- Proj := Parent_Project_Of (Proj, In_Tree);
- exit when No (Proj);
- end loop;
- end if;
-
- if No (Current) then
- Error_Msg (Flags,
- "unknown string type """ &
- Get_Name_String (String_Type_Name) &
- """",
- Type_Location);
- OK := False;
-
- else
- Set_String_Type_Of
- (Variable, In_Tree, To => Current);
- end if;
- end;
- end if;
- end if;
- end if;
-
- Expect (Tok_Colon_Equal, "`:=`");
-
- OK := OK and then Token = Tok_Colon_Equal;
-
- if Token = Tok_Colon_Equal then
- Scan (In_Tree);
- end if;
-
- -- Get the single string or string list value
-
- Expression_Location := Token_Ptr;
-
- Parse_Expression
- (In_Tree => In_Tree,
- Expression => Expression,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Optional_Index => False);
- Set_Expression_Of (Variable, In_Tree, To => Expression);
-
- if Present (Expression) then
- -- A typed string must have a single string value, not a list
-
- if Kind_Of (Variable, In_Tree) = N_Typed_Variable_Declaration
- and then Expression_Kind_Of (Expression, In_Tree) = List
- then
- Error_Msg
- (Flags,
- "expression must be a single string", Expression_Location);
- end if;
-
- Set_Expression_Kind_Of
- (Variable, In_Tree,
- To => Expression_Kind_Of (Expression, In_Tree));
- end if;
-
- if OK then
- declare
- The_Variable : Project_Node_Id := Empty_Node;
-
- begin
- if Present (Current_Package) then
- The_Variable := First_Variable_Of (Current_Package, In_Tree);
- elsif Present (Current_Project) then
- The_Variable := First_Variable_Of (Current_Project, In_Tree);
- end if;
-
- while Present (The_Variable)
- and then Name_Of (The_Variable, In_Tree) /= Variable_Name
- loop
- The_Variable := Next_Variable (The_Variable, In_Tree);
- end loop;
-
- if No (The_Variable) then
- if Present (Current_Package) then
- Set_Next_Variable
- (Variable, In_Tree,
- To => First_Variable_Of (Current_Package, In_Tree));
- Set_First_Variable_Of
- (Current_Package, In_Tree, To => Variable);
-
- elsif Present (Current_Project) then
- Set_Next_Variable
- (Variable, In_Tree,
- To => First_Variable_Of (Current_Project, In_Tree));
- Set_First_Variable_Of
- (Current_Project, In_Tree, To => Variable);
- end if;
-
- else
- if Expression_Kind_Of (Variable, In_Tree) /= Undefined then
- if Expression_Kind_Of (The_Variable, In_Tree) =
- Undefined
- then
- Set_Expression_Kind_Of
- (The_Variable, In_Tree,
- To => Expression_Kind_Of (Variable, In_Tree));
-
- else
- if Expression_Kind_Of (The_Variable, In_Tree) /=
- Expression_Kind_Of (Variable, In_Tree)
- then
- Error_Msg (Flags,
- "wrong expression kind for variable """ &
- Get_Name_String
- (Name_Of (The_Variable, In_Tree)) &
- """",
- Expression_Location);
- end if;
- end if;
- end if;
- end if;
- end;
- end if;
- end Parse_Variable_Declaration;
-
-end Prj.Dect;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . D E C T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Parse a list of declarative items in a project file
-
-with Prj.Tree;
-
-private package Prj.Dect is
-
- procedure Parse
- (In_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Declarations : out Prj.Tree.Project_Node_Id;
- Current_Project : Prj.Tree.Project_Node_Id;
- Extends : Prj.Tree.Project_Node_Id;
- Packages_To_Check : String_List_Access;
- Is_Config_File : Boolean;
- Flags : Processing_Flags);
- -- Parse project declarative items
- --
- -- In_Tree is the project node tree
- --
- -- Declarations is the resulting project node
- --
- -- Current_Project is the project node of the project for which the
- -- declarative items are parsed.
- --
- -- Extends is the project node of the project that project Current_Project
- -- extends. If project Current-Project does not extend any project,
- -- Extends has the value Empty_Node.
- --
- -- Packages_To_Check is the list of packages that needs to be checked.
- -- For legal packages declared in project Current_Project that are not in
- -- Packages_To_Check, only the syntax of the declarations are checked, not
- -- the attribute names and kinds.
- --
- -- Is_Config_File should be set to True if the project represents a config
- -- file (.cgpr) since some specific checks apply.
-
-end Prj.Dect;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . E N V --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Fmap;
-with Makeutl; use Makeutl;
-with Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Com; use Prj.Com;
-with Sdefault;
-with Tempdir;
-
-with Ada.Text_IO; use Ada.Text_IO;
-
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-
-package body Prj.Env is
-
- Buffer_Initial : constant := 1_000;
- -- Initial arbitrary size of buffers
-
- Uninitialized_Prefix : constant String := '#' & Path_Separator;
- -- Prefix to indicate that the project path has not been initialized yet.
- -- Must be two characters long
-
- No_Project_Default_Dir : constant String := "-";
- -- Indicator in the project path to indicate that the default search
- -- directories should not be added to the path
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- package Source_Path_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Name_Id,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 50,
- Table_Increment => 100);
- -- A table to store the source dirs before creating the source path file
-
- package Object_Path_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Path_Name_Type,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 50,
- Table_Increment => 100);
- -- A table to store the object dirs, before creating the object path file
-
- procedure Add_To_Buffer
- (S : String;
- Buffer : in out String_Access;
- Buffer_Last : in out Natural);
- -- Add a string to Buffer, extending Buffer if needed
-
- procedure Add_To_Path
- (Source_Dirs : String_List_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Buffer : in out String_Access;
- Buffer_Last : in out Natural);
- -- Add to Ada_Path_Buffer all the source directories in string list
- -- Source_Dirs, if any.
-
- procedure Add_To_Path
- (Dir : String;
- Buffer : in out String_Access;
- Buffer_Last : in out Natural);
- -- If Dir is not already in the global variable Ada_Path_Buffer, add it.
- -- If Buffer_Last /= 0, prepend a Path_Separator character to Path.
-
- procedure Add_To_Source_Path
- (Source_Dirs : String_List_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Source_Paths : in out Source_Path_Table.Instance);
- -- Add to Ada_Path_B all the source directories in string list
- -- Source_Dirs, if any. Increment Ada_Path_Length.
-
- procedure Add_To_Object_Path
- (Object_Dir : Path_Name_Type;
- Object_Paths : in out Object_Path_Table.Instance);
- -- Add Object_Dir to object path table. Make sure it is not duplicate
- -- and it is the last one in the current table.
-
- ----------------------
- -- Ada_Include_Path --
- ----------------------
-
- function Ada_Include_Path
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Recursive : Boolean := False) return String
- is
- Buffer : String_Access;
- Buffer_Last : Natural := 0;
-
- procedure Add
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean);
- -- Add source dirs of Project to the path
-
- ---------
- -- Add --
- ---------
-
- procedure Add
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean)
- is
- begin
- Add_To_Path
- (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
- end Add;
-
- procedure For_All_Projects is
- new For_Every_Project_Imported (Boolean, Add);
-
- Dummy : Boolean := False;
-
- -- Start of processing for Ada_Include_Path
-
- begin
- if Recursive then
-
- -- If it is the first time we call this function for this project,
- -- compute the source path.
-
- if Project.Ada_Include_Path = null then
- Buffer := new String (1 .. Buffer_Initial);
- For_All_Projects
- (Project, In_Tree, Dummy, Include_Aggregated => True);
- Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
- Free (Buffer);
- end if;
-
- return Project.Ada_Include_Path.all;
-
- else
- Buffer := new String (1 .. Buffer_Initial);
- Add_To_Path
- (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last);
-
- declare
- Result : constant String := Buffer (1 .. Buffer_Last);
- begin
- Free (Buffer);
- return Result;
- end;
- end if;
- end Ada_Include_Path;
-
- ----------------------
- -- Ada_Objects_Path --
- ----------------------
-
- function Ada_Objects_Path
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Including_Libraries : Boolean := True) return String_Access
- is
- Buffer : String_Access;
- Buffer_Last : Natural := 0;
-
- procedure Add
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean);
- -- Add all the object directories of a project to the path
-
- ---------
- -- Add --
- ---------
-
- procedure Add
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean)
- is
- pragma Unreferenced (In_Tree);
-
- Path : constant Path_Name_Type :=
- Get_Object_Directory
- (Project,
- Including_Libraries => Including_Libraries,
- Only_If_Ada => False);
- begin
- if Path /= No_Path then
- Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
- end if;
- end Add;
-
- procedure For_All_Projects is
- new For_Every_Project_Imported (Boolean, Add);
-
- Dummy : Boolean := False;
-
- Result : String_Access;
-
- -- Start of processing for Ada_Objects_Path
-
- begin
- -- If it is the first time we call this function for
- -- this project, compute the objects path
-
- if Including_Libraries and then Project.Ada_Objects_Path /= null then
- return Project.Ada_Objects_Path;
-
- elsif not Including_Libraries
- and then Project.Ada_Objects_Path_No_Libs /= null
- then
- return Project.Ada_Objects_Path_No_Libs;
-
- else
- Buffer := new String (1 .. Buffer_Initial);
- For_All_Projects (Project, In_Tree, Dummy);
- Result := new String'(Buffer (1 .. Buffer_Last));
- Free (Buffer);
-
- if Including_Libraries then
- Project.Ada_Objects_Path := Result;
- else
- Project.Ada_Objects_Path_No_Libs := Result;
- end if;
-
- return Result;
- end if;
- end Ada_Objects_Path;
-
- -------------------
- -- Add_To_Buffer --
- -------------------
-
- procedure Add_To_Buffer
- (S : String;
- Buffer : in out String_Access;
- Buffer_Last : in out Natural)
- is
- Last : constant Natural := Buffer_Last + S'Length;
-
- begin
- while Last > Buffer'Last loop
- declare
- New_Buffer : constant String_Access :=
- new String (1 .. 2 * Buffer'Last);
- begin
- New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
- Free (Buffer);
- Buffer := New_Buffer;
- end;
- end loop;
-
- Buffer (Buffer_Last + 1 .. Last) := S;
- Buffer_Last := Last;
- end Add_To_Buffer;
-
- ------------------------
- -- Add_To_Object_Path --
- ------------------------
-
- procedure Add_To_Object_Path
- (Object_Dir : Path_Name_Type;
- Object_Paths : in out Object_Path_Table.Instance)
- is
- begin
- -- Check if the directory is already in the table
-
- for Index in
- Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
- loop
- -- If it is, remove it, and add it as the last one
-
- if Object_Paths.Table (Index) = Object_Dir then
- for Index2 in
- Index + 1 .. Object_Path_Table.Last (Object_Paths)
- loop
- Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
- end loop;
-
- Object_Paths.Table
- (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
- return;
- end if;
- end loop;
-
- -- The directory is not already in the table, add it
-
- Object_Path_Table.Append (Object_Paths, Object_Dir);
- end Add_To_Object_Path;
-
- -----------------
- -- Add_To_Path --
- -----------------
-
- procedure Add_To_Path
- (Source_Dirs : String_List_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Buffer : in out String_Access;
- Buffer_Last : in out Natural)
- is
- Current : String_List_Id;
- Source_Dir : String_Element;
- begin
- Current := Source_Dirs;
- while Current /= Nil_String loop
- Source_Dir := Shared.String_Elements.Table (Current);
- Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
- Buffer, Buffer_Last);
- Current := Source_Dir.Next;
- end loop;
- end Add_To_Path;
-
- procedure Add_To_Path
- (Dir : String;
- Buffer : in out String_Access;
- Buffer_Last : in out Natural)
- is
- Len : Natural;
- New_Buffer : String_Access;
- Min_Len : Natural;
-
- function Is_Present (Path : String; Dir : String) return Boolean;
- -- Return True if Dir is part of Path
-
- ----------------
- -- Is_Present --
- ----------------
-
- function Is_Present (Path : String; Dir : String) return Boolean is
- Last : constant Integer := Path'Last - Dir'Length + 1;
-
- begin
- for J in Path'First .. Last loop
-
- -- Note: the order of the conditions below is important, since
- -- it ensures a minimal number of string comparisons.
-
- if (J = Path'First or else Path (J - 1) = Path_Separator)
- and then
- (J + Dir'Length > Path'Last
- or else Path (J + Dir'Length) = Path_Separator)
- and then Dir = Path (J .. J + Dir'Length - 1)
- then
- return True;
- end if;
- end loop;
-
- return False;
- end Is_Present;
-
- -- Start of processing for Add_To_Path
-
- begin
- if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
-
- -- Dir is already in the path, nothing to do
-
- return;
- end if;
-
- Min_Len := Buffer_Last + Dir'Length;
-
- if Buffer_Last > 0 then
-
- -- Add 1 for the Path_Separator character
-
- Min_Len := Min_Len + 1;
- end if;
-
- -- If Ada_Path_Buffer is too small, increase it
-
- Len := Buffer'Last;
-
- if Len < Min_Len then
- loop
- Len := Len * 2;
- exit when Len >= Min_Len;
- end loop;
-
- New_Buffer := new String (1 .. Len);
- New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
- Free (Buffer);
- Buffer := New_Buffer;
- end if;
-
- if Buffer_Last > 0 then
- Buffer_Last := Buffer_Last + 1;
- Buffer (Buffer_Last) := Path_Separator;
- end if;
-
- Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
- Buffer_Last := Buffer_Last + Dir'Length;
- end Add_To_Path;
-
- ------------------------
- -- Add_To_Source_Path --
- ------------------------
-
- procedure Add_To_Source_Path
- (Source_Dirs : String_List_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Source_Paths : in out Source_Path_Table.Instance)
- is
- Current : String_List_Id;
- Source_Dir : String_Element;
- Add_It : Boolean;
-
- begin
- -- Add each source directory
-
- Current := Source_Dirs;
- while Current /= Nil_String loop
- Source_Dir := Shared.String_Elements.Table (Current);
- Add_It := True;
-
- -- Check if the source directory is already in the table
-
- for Index in
- Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
- loop
- -- If it is already, no need to add it
-
- if Source_Paths.Table (Index) = Source_Dir.Value then
- Add_It := False;
- exit;
- end if;
- end loop;
-
- if Add_It then
- Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
- end if;
-
- -- Next source directory
-
- Current := Source_Dir.Next;
- end loop;
- end Add_To_Source_Path;
-
- --------------------------------
- -- Create_Config_Pragmas_File --
- --------------------------------
-
- procedure Create_Config_Pragmas_File
- (For_Project : Project_Id;
- In_Tree : Project_Tree_Ref)
- is
- type Naming_Id is new Nat;
- package Naming_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Lang_Naming_Data,
- Table_Index_Type => Naming_Id,
- Table_Low_Bound => 1,
- Table_Initial => 5,
- Table_Increment => 100);
-
- Default_Naming : constant Naming_Id := Naming_Table.First;
- Namings : Naming_Table.Instance;
- -- Table storing the naming data for gnatmake/gprmake
-
- Buffer : String_Access := new String (1 .. Buffer_Initial);
- Buffer_Last : Natural := 0;
-
- File_Name : Path_Name_Type := No_Path;
- File : File_Descriptor := Invalid_FD;
-
- Current_Naming : Naming_Id;
-
- procedure Check
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- State : in out Integer);
- -- Recursive procedure that put in the config pragmas file any non
- -- standard naming schemes, if it is not already in the file, then call
- -- itself for any imported project.
-
- procedure Put (Source : Source_Id);
- -- Put an SFN pragma in the temporary file
-
- procedure Put (S : String);
- procedure Put_Line (S : String);
- -- Output procedures, analogous to normal Text_IO procs of same name.
- -- The text is put in Buffer, then it will be written into a temporary
- -- file with procedure Write_Temp_File below.
-
- procedure Write_Temp_File;
- -- Create a temporary file and put the content of the buffer in it
-
- -----------
- -- Check --
- -----------
-
- procedure Check
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- State : in out Integer)
- is
- pragma Unreferenced (State);
-
- Lang : constant Language_Ptr :=
- Get_Language_From_Name (Project, "ada");
- Naming : Lang_Naming_Data;
- Iter : Source_Iterator;
- Source : Source_Id;
-
- begin
- if Current_Verbosity = High then
- Debug_Output ("Checking project file:", Project.Name);
- end if;
-
- if Lang = null then
- if Current_Verbosity = High then
- Debug_Output ("Languages does not contain Ada, nothing to do");
- end if;
-
- return;
- end if;
-
- -- Visit all the files and process those that need an SFN pragma
-
- Iter := For_Each_Source (In_Tree, Project);
- while Element (Iter) /= No_Source loop
- Source := Element (Iter);
-
- if not Source.Locally_Removed
- and then Source.Unit /= null
- and then
- (Source.Index >= 1 or else Source.Naming_Exception /= No)
- then
- Put (Source);
- end if;
-
- Next (Iter);
- end loop;
-
- Naming := Lang.Config.Naming_Data;
-
- -- Is the naming scheme of this project one that we know?
-
- Current_Naming := Default_Naming;
- while Current_Naming <= Naming_Table.Last (Namings)
- and then Namings.Table (Current_Naming).Dot_Replacement =
- Naming.Dot_Replacement
- and then Namings.Table (Current_Naming).Casing =
- Naming.Casing
- and then Namings.Table (Current_Naming).Separate_Suffix =
- Naming.Separate_Suffix
- loop
- Current_Naming := Current_Naming + 1;
- end loop;
-
- -- If we don't know it, add it
-
- if Current_Naming > Naming_Table.Last (Namings) then
- Naming_Table.Increment_Last (Namings);
- Namings.Table (Naming_Table.Last (Namings)) := Naming;
-
- -- Put the SFN pragmas for the naming scheme
-
- -- Spec
-
- Put_Line
- ("pragma Source_File_Name_Project");
- Put_Line
- (" (Spec_File_Name => ""*" &
- Get_Name_String (Naming.Spec_Suffix) & """,");
- Put_Line
- (" Casing => " &
- Image (Naming.Casing) & ",");
- Put_Line
- (" Dot_Replacement => """ &
- Get_Name_String (Naming.Dot_Replacement) & """);");
-
- -- and body
-
- Put_Line
- ("pragma Source_File_Name_Project");
- Put_Line
- (" (Body_File_Name => ""*" &
- Get_Name_String (Naming.Body_Suffix) & """,");
- Put_Line
- (" Casing => " &
- Image (Naming.Casing) & ",");
- Put_Line
- (" Dot_Replacement => """ &
- Get_Name_String (Naming.Dot_Replacement) &
- """);");
-
- -- and maybe separate
-
- if Naming.Body_Suffix /= Naming.Separate_Suffix then
- Put_Line ("pragma Source_File_Name_Project");
- Put_Line
- (" (Subunit_File_Name => ""*" &
- Get_Name_String (Naming.Separate_Suffix) & """,");
- Put_Line
- (" Casing => " &
- Image (Naming.Casing) & ",");
- Put_Line
- (" Dot_Replacement => """ &
- Get_Name_String (Naming.Dot_Replacement) &
- """);");
- end if;
- end if;
- end Check;
-
- ---------
- -- Put --
- ---------
-
- procedure Put (Source : Source_Id) is
- begin
- -- Put the pragma SFN for the unit kind (spec or body)
-
- Put ("pragma Source_File_Name_Project (");
- Put (Namet.Get_Name_String (Source.Unit.Name));
-
- if Source.Kind = Spec then
- Put (", Spec_File_Name => """);
- else
- Put (", Body_File_Name => """);
- end if;
-
- Put (Namet.Get_Name_String (Source.File));
- Put ("""");
-
- if Source.Index /= 0 then
- Put (", Index =>");
- Put (Source.Index'Img);
- end if;
-
- Put_Line (");");
- end Put;
-
- procedure Put (S : String) is
- begin
- Add_To_Buffer (S, Buffer, Buffer_Last);
-
- if Current_Verbosity = High then
- Write_Str (S);
- end if;
- end Put;
-
- --------------
- -- Put_Line --
- --------------
-
- procedure Put_Line (S : String) is
- begin
- -- Add an ASCII.LF to the string. As this config file is supposed to
- -- be used only by the compiler, we don't care about the characters
- -- for the end of line. In fact we could have put a space, but
- -- it is more convenient to be able to read gnat.adc during
- -- development, for which the ASCII.LF is fine.
-
- Put (S);
- Put (S => (1 => ASCII.LF));
- end Put_Line;
-
- ---------------------
- -- Write_Temp_File --
- ---------------------
-
- procedure Write_Temp_File is
- Status : Boolean := False;
- Last : Natural;
-
- begin
- Tempdir.Create_Temp_File (File, File_Name);
-
- if File /= Invalid_FD then
- Last := Write (File, Buffer (1)'Address, Buffer_Last);
-
- if Last = Buffer_Last then
- Close (File, Status);
- end if;
- end if;
-
- if not Status then
- Prj.Com.Fail ("unable to create temporary file");
- end if;
- end Write_Temp_File;
-
- procedure Check_Imported_Projects is
- new For_Every_Project_Imported (Integer, Check);
-
- Dummy : Integer := 0;
-
- -- Start of processing for Create_Config_Pragmas_File
-
- begin
- if not For_Project.Config_Checked then
- Naming_Table.Init (Namings);
-
- -- Check the naming schemes
-
- Check_Imported_Projects
- (For_Project, In_Tree, Dummy, Imported_First => False);
-
- -- If there are no non standard naming scheme, issue the GNAT
- -- standard naming scheme. This will tell the compiler that
- -- a project file is used and will forbid any pragma SFN.
-
- if Buffer_Last = 0 then
-
- Put_Line ("pragma Source_File_Name_Project");
- Put_Line (" (Spec_File_Name => ""*.ads"",");
- Put_Line (" Dot_Replacement => ""-"",");
- Put_Line (" Casing => lowercase);");
-
- Put_Line ("pragma Source_File_Name_Project");
- Put_Line (" (Body_File_Name => ""*.adb"",");
- Put_Line (" Dot_Replacement => ""-"",");
- Put_Line (" Casing => lowercase);");
- end if;
-
- -- Close the temporary file
-
- Write_Temp_File;
-
- if Opt.Verbose_Mode then
- Write_Str ("Created configuration file """);
- Write_Str (Get_Name_String (File_Name));
- Write_Line ("""");
- end if;
-
- For_Project.Config_File_Name := File_Name;
- For_Project.Config_File_Temp := True;
- For_Project.Config_Checked := True;
- end if;
-
- Free (Buffer);
- end Create_Config_Pragmas_File;
-
- --------------------
- -- Create_Mapping --
- --------------------
-
- procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
- Data : Source_Id;
- Iter : Source_Iterator;
-
- begin
- Fmap.Reset_Tables;
-
- Iter := For_Each_Source (In_Tree);
- loop
- Data := Element (Iter);
- exit when Data = No_Source;
-
- if Data.Unit /= No_Unit_Index then
- if Data.Locally_Removed and then not Data.Suppressed then
- Fmap.Add_Forbidden_File_Name (Data.File);
- else
- Fmap.Add_To_File_Map
- (Unit_Name => Unit_Name_Type (Data.Unit.Name),
- File_Name => Data.File,
- Path_Name => File_Name_Type (Data.Path.Display_Name));
- end if;
- end if;
-
- Next (Iter);
- end loop;
- end Create_Mapping;
-
- -------------------------
- -- Create_Mapping_File --
- -------------------------
-
- procedure Create_Mapping_File
- (Project : Project_Id;
- Language : Name_Id;
- In_Tree : Project_Tree_Ref;
- Name : out Path_Name_Type)
- is
- File : File_Descriptor := Invalid_FD;
- Buffer : String_Access := new String (1 .. Buffer_Initial);
- Buffer_Last : Natural := 0;
-
- procedure Put_Name_Buffer;
- -- Put the line contained in the Name_Buffer in the global buffer
-
- procedure Process
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- State : in out Integer);
- -- Generate the mapping file for Project (not recursively)
-
- ---------------------
- -- Put_Name_Buffer --
- ---------------------
-
- procedure Put_Name_Buffer is
- begin
- if Current_Verbosity = High then
- Debug_Output (Name_Buffer (1 .. Name_Len));
- end if;
-
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ASCII.LF;
- Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
- end Put_Name_Buffer;
-
- -------------
- -- Process --
- -------------
-
- procedure Process
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- State : in out Integer)
- is
- pragma Unreferenced (State);
-
- Source : Source_Id;
- Suffix : File_Name_Type;
- Iter : Source_Iterator;
-
- begin
- Debug_Output ("Add mapping for project", Project.Name);
- Iter := For_Each_Source (In_Tree, Project, Language => Language);
-
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- if not Source.Suppressed
- and then Source.Replaced_By = No_Source
- and then Source.Path.Name /= No_Path
- and then (Source.Language.Config.Kind = File_Based
- or else Source.Unit /= No_Unit_Index)
- then
- if Source.Unit /= No_Unit_Index then
-
- -- Put the encoded unit name in the name buffer
-
- declare
- Uname : constant String :=
- Get_Name_String (Source.Unit.Name);
-
- begin
- Name_Len := 0;
- for J in Uname'Range loop
- if Uname (J) in Upper_Half_Character then
- Store_Encoded_Character (Get_Char_Code (Uname (J)));
- else
- Add_Char_To_Name_Buffer (Uname (J));
- end if;
- end loop;
- end;
-
- if Source.Language.Config.Kind = Unit_Based then
-
- -- ??? Mapping_Spec_Suffix could be set in the case of
- -- gnatmake as well
-
- Add_Char_To_Name_Buffer ('%');
-
- if Source.Kind = Spec then
- Add_Char_To_Name_Buffer ('s');
- else
- Add_Char_To_Name_Buffer ('b');
- end if;
-
- else
- case Source.Kind is
- when Spec =>
- Suffix :=
- Source.Language.Config.Mapping_Spec_Suffix;
-
- when Impl
- | Sep
- =>
- Suffix :=
- Source.Language.Config.Mapping_Body_Suffix;
- end case;
-
- if Suffix /= No_File then
- Add_Str_To_Name_Buffer (Get_Name_String (Suffix));
- end if;
- end if;
-
- Put_Name_Buffer;
- end if;
-
- Get_Name_String (Source.Display_File);
- Put_Name_Buffer;
-
- if Source.Locally_Removed then
- Name_Len := 1;
- Name_Buffer (1) := '/';
- else
- Get_Name_String (Source.Path.Display_Name);
- end if;
-
- Put_Name_Buffer;
- end if;
-
- Next (Iter);
- end loop;
- end Process;
-
- procedure For_Every_Imported_Project is new
- For_Every_Project_Imported (State => Integer, Action => Process);
-
- -- Local variables
-
- Dummy : Integer := 0;
-
- -- Start of processing for Create_Mapping_File
-
- begin
- if Current_Verbosity = High then
- Debug_Output ("Create mapping file for", Debug_Name (In_Tree));
- end if;
-
- Create_Temp_File (In_Tree.Shared, File, Name, "mapping");
-
- if Current_Verbosity = High then
- Debug_Increase_Indent ("Create mapping file ", Name_Id (Name));
- end if;
-
- For_Every_Imported_Project
- (Project, In_Tree, Dummy, Include_Aggregated => False);
-
- declare
- Last : Natural;
- Status : Boolean := False;
-
- begin
- if File /= Invalid_FD then
- Last := Write (File, Buffer (1)'Address, Buffer_Last);
-
- if Last = Buffer_Last then
- GNAT.OS_Lib.Close (File, Status);
- end if;
- end if;
-
- if not Status then
- Prj.Com.Fail ("could not write mapping file");
- end if;
- end;
-
- Free (Buffer);
-
- Debug_Decrease_Indent ("Done create mapping file");
- end Create_Mapping_File;
-
- ----------------------
- -- Create_Temp_File --
- ----------------------
-
- procedure Create_Temp_File
- (Shared : Shared_Project_Tree_Data_Access;
- Path_FD : out File_Descriptor;
- Path_Name : out Path_Name_Type;
- File_Use : String)
- is
- begin
- Tempdir.Create_Temp_File (Path_FD, Path_Name);
-
- if Path_Name /= No_Path then
- if Current_Verbosity = High then
- Write_Line ("Create temp file (" & File_Use & ") "
- & Get_Name_String (Path_Name));
- end if;
-
- Record_Temp_File (Shared, Path_Name);
-
- else
- Prj.Com.Fail
- ("unable to create temporary " & File_Use & " file");
- end if;
- end Create_Temp_File;
-
- --------------------------
- -- Create_New_Path_File --
- --------------------------
-
- procedure Create_New_Path_File
- (Shared : Shared_Project_Tree_Data_Access;
- Path_FD : out File_Descriptor;
- Path_Name : out Path_Name_Type)
- is
- begin
- Create_Temp_File (Shared, Path_FD, Path_Name, "path file");
- end Create_New_Path_File;
-
- ------------------------------------
- -- File_Name_Of_Library_Unit_Body --
- ------------------------------------
-
- function File_Name_Of_Library_Unit_Body
- (Name : String;
- Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Main_Project_Only : Boolean := True;
- Full_Path : Boolean := False) return String
- is
-
- Lang : constant Language_Ptr :=
- Get_Language_From_Name (Project, "ada");
- The_Project : Project_Id := Project;
- Original_Name : String := Name;
-
- Unit : Unit_Index;
- The_Original_Name : Name_Id;
- The_Spec_Name : Name_Id;
- The_Body_Name : Name_Id;
-
- begin
- -- ??? Same block in Project_Of
- Canonical_Case_File_Name (Original_Name);
- Name_Len := Original_Name'Length;
- Name_Buffer (1 .. Name_Len) := Original_Name;
- The_Original_Name := Name_Find;
-
- if Lang /= null then
- declare
- Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
- Extended_Spec_Name : String :=
- Name & Namet.Get_Name_String
- (Naming.Spec_Suffix);
- Extended_Body_Name : String :=
- Name & Namet.Get_Name_String
- (Naming.Body_Suffix);
-
- begin
- Canonical_Case_File_Name (Extended_Spec_Name);
- Name_Len := Extended_Spec_Name'Length;
- Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
- The_Spec_Name := Name_Find;
-
- Canonical_Case_File_Name (Extended_Body_Name);
- Name_Len := Extended_Body_Name'Length;
- Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
- The_Body_Name := Name_Find;
- end;
-
- else
- Name_Len := Name'Length;
- Name_Buffer (1 .. Name_Len) := Name;
- Canonical_Case_File_Name (Name_Buffer);
- The_Spec_Name := Name_Find;
- The_Body_Name := The_Spec_Name;
- end if;
-
- if Current_Verbosity = High then
- Write_Str ("Looking for file name of """);
- Write_Str (Name);
- Write_Char ('"');
- Write_Eol;
- Write_Str (" Extended Spec Name = """);
- Write_Str (Get_Name_String (The_Spec_Name));
- Write_Char ('"');
- Write_Eol;
- Write_Str (" Extended Body Name = """);
- Write_Str (Get_Name_String (The_Body_Name));
- Write_Char ('"');
- Write_Eol;
- end if;
-
- -- For extending project, search in the extended project if the source
- -- is not found. For non extending projects, this loop will be run only
- -- once.
-
- loop
- -- Loop through units
-
- Unit := Units_Htable.Get_First (In_Tree.Units_HT);
- while Unit /= null loop
-
- -- Check for body
-
- if not Main_Project_Only
- or else
- (Unit.File_Names (Impl) /= null
- and then Unit.File_Names (Impl).Project = The_Project)
- then
- declare
- Current_Name : File_Name_Type;
-
- begin
- -- Case of a body present
-
- if Unit.File_Names (Impl) /= null then
- Current_Name := Unit.File_Names (Impl).File;
-
- if Current_Verbosity = High then
- Write_Str (" Comparing with """);
- Write_Str (Get_Name_String (Current_Name));
- Write_Char ('"');
- Write_Eol;
- end if;
-
- -- If it has the name of the original name, return the
- -- original name.
-
- if Unit.Name = The_Original_Name
- or else
- Current_Name = File_Name_Type (The_Original_Name)
- then
- if Current_Verbosity = High then
- Write_Line (" OK");
- end if;
-
- if Full_Path then
- return Get_Name_String
- (Unit.File_Names (Impl).Path.Name);
-
- else
- return Get_Name_String (Current_Name);
- end if;
-
- -- If it has the name of the extended body name,
- -- return the extended body name
-
- elsif Current_Name = File_Name_Type (The_Body_Name) then
- if Current_Verbosity = High then
- Write_Line (" OK");
- end if;
-
- if Full_Path then
- return Get_Name_String
- (Unit.File_Names (Impl).Path.Name);
-
- else
- return Get_Name_String (The_Body_Name);
- end if;
-
- else
- if Current_Verbosity = High then
- Write_Line (" not good");
- end if;
- end if;
- end if;
- end;
- end if;
-
- -- Check for spec
-
- if not Main_Project_Only
- or else (Unit.File_Names (Spec) /= null
- and then Unit.File_Names (Spec).Project = The_Project)
- then
- declare
- Current_Name : File_Name_Type;
-
- begin
- -- Case of spec present
-
- if Unit.File_Names (Spec) /= null then
- Current_Name := Unit.File_Names (Spec).File;
- if Current_Verbosity = High then
- Write_Str (" Comparing with """);
- Write_Str (Get_Name_String (Current_Name));
- Write_Char ('"');
- Write_Eol;
- end if;
-
- -- If name same as original name, return original name
-
- if Unit.Name = The_Original_Name
- or else
- Current_Name = File_Name_Type (The_Original_Name)
- then
- if Current_Verbosity = High then
- Write_Line (" OK");
- end if;
-
- if Full_Path then
- return Get_Name_String
- (Unit.File_Names (Spec).Path.Name);
- else
- return Get_Name_String (Current_Name);
- end if;
-
- -- If it has the same name as the extended spec name,
- -- return the extended spec name.
-
- elsif Current_Name = File_Name_Type (The_Spec_Name) then
- if Current_Verbosity = High then
- Write_Line (" OK");
- end if;
-
- if Full_Path then
- return Get_Name_String
- (Unit.File_Names (Spec).Path.Name);
- else
- return Get_Name_String (The_Spec_Name);
- end if;
-
- else
- if Current_Verbosity = High then
- Write_Line (" not good");
- end if;
- end if;
- end if;
- end;
- end if;
-
- Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
- end loop;
-
- -- If we are not in an extending project, give up
-
- exit when not Main_Project_Only
- or else The_Project.Extends = No_Project;
-
- -- Otherwise, look in the project we are extending
-
- The_Project := The_Project.Extends;
- end loop;
-
- -- We don't know this file name, return an empty string
-
- return "";
- end File_Name_Of_Library_Unit_Body;
-
- -------------------------
- -- For_All_Object_Dirs --
- -------------------------
-
- procedure For_All_Object_Dirs
- (Project : Project_Id;
- Tree : Project_Tree_Ref)
- is
- procedure For_Project
- (Prj : Project_Id;
- Tree : Project_Tree_Ref;
- Dummy : in out Integer);
- -- Get all object directories of Prj
-
- -----------------
- -- For_Project --
- -----------------
-
- procedure For_Project
- (Prj : Project_Id;
- Tree : Project_Tree_Ref;
- Dummy : in out Integer)
- is
- pragma Unreferenced (Tree);
-
- begin
- -- ??? Set_Ada_Paths has a different behavior for library project
- -- files, should we have the same ?
-
- if Prj.Object_Directory /= No_Path_Information then
- Get_Name_String (Prj.Object_Directory.Display_Name);
- Action (Name_Buffer (1 .. Name_Len));
- end if;
- end For_Project;
-
- procedure Get_Object_Dirs is
- new For_Every_Project_Imported (Integer, For_Project);
- Dummy : Integer := 1;
-
- -- Start of processing for For_All_Object_Dirs
-
- begin
- Get_Object_Dirs (Project, Tree, Dummy);
- end For_All_Object_Dirs;
-
- -------------------------
- -- For_All_Source_Dirs --
- -------------------------
-
- procedure For_All_Source_Dirs
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref)
- is
- procedure For_Project
- (Prj : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Integer);
- -- Get all object directories of Prj
-
- -----------------
- -- For_Project --
- -----------------
-
- procedure For_Project
- (Prj : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Integer)
- is
- Current : String_List_Id := Prj.Source_Dirs;
- The_String : String_Element;
-
- begin
- -- If there are Ada sources, call action with the name of every
- -- source directory.
-
- if Has_Ada_Sources (Prj) then
- while Current /= Nil_String loop
- The_String := In_Tree.Shared.String_Elements.Table (Current);
- Action (Get_Name_String (The_String.Display_Value));
- Current := The_String.Next;
- end loop;
- end if;
- end For_Project;
-
- procedure Get_Source_Dirs is
- new For_Every_Project_Imported (Integer, For_Project);
- Dummy : Integer := 1;
-
- -- Start of processing for For_All_Source_Dirs
-
- begin
- Get_Source_Dirs (Project, In_Tree, Dummy);
- end For_All_Source_Dirs;
-
- -------------------
- -- Get_Reference --
- -------------------
-
- procedure Get_Reference
- (Source_File_Name : String;
- In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Path : out Path_Name_Type)
- is
- begin
- -- Body below could use some comments ???
-
- if Current_Verbosity > Default then
- Write_Str ("Getting Reference_Of (""");
- Write_Str (Source_File_Name);
- Write_Str (""") ... ");
- end if;
-
- declare
- Original_Name : String := Source_File_Name;
- Unit : Unit_Index;
-
- begin
- Canonical_Case_File_Name (Original_Name);
- Unit := Units_Htable.Get_First (In_Tree.Units_HT);
-
- while Unit /= null loop
- if Unit.File_Names (Spec) /= null
- and then not Unit.File_Names (Spec).Locally_Removed
- and then Unit.File_Names (Spec).File /= No_File
- and then
- (Namet.Get_Name_String
- (Unit.File_Names (Spec).File) = Original_Name
- or else (Unit.File_Names (Spec).Path /= No_Path_Information
- and then
- Namet.Get_Name_String
- (Unit.File_Names (Spec).Path.Name) =
- Original_Name))
- then
- Project :=
- Ultimate_Extending_Project_Of
- (Unit.File_Names (Spec).Project);
- Path := Unit.File_Names (Spec).Path.Display_Name;
-
- if Current_Verbosity > Default then
- Write_Str ("Done: Spec.");
- Write_Eol;
- end if;
-
- return;
-
- elsif Unit.File_Names (Impl) /= null
- and then Unit.File_Names (Impl).File /= No_File
- and then not Unit.File_Names (Impl).Locally_Removed
- and then
- (Namet.Get_Name_String
- (Unit.File_Names (Impl).File) = Original_Name
- or else (Unit.File_Names (Impl).Path /= No_Path_Information
- and then Namet.Get_Name_String
- (Unit.File_Names (Impl).Path.Name) =
- Original_Name))
- then
- Project :=
- Ultimate_Extending_Project_Of
- (Unit.File_Names (Impl).Project);
- Path := Unit.File_Names (Impl).Path.Display_Name;
-
- if Current_Verbosity > Default then
- Write_Str ("Done: Body.");
- Write_Eol;
- end if;
-
- return;
- end if;
-
- Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
- end loop;
- end;
-
- Project := No_Project;
- Path := No_Path;
-
- if Current_Verbosity > Default then
- Write_Str ("Cannot be found.");
- Write_Eol;
- end if;
- end Get_Reference;
-
- ----------------------
- -- Get_Runtime_Path --
- ----------------------
-
- function Get_Runtime_Path
- (Self : Project_Search_Path;
- Name : String) return String_Access
- is
- function Find_Rts_In_Path is
- new Prj.Env.Find_Name_In_Path (Check_Filename => Is_Directory);
- begin
- return Find_Rts_In_Path (Self, Name);
- end Get_Runtime_Path;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (In_Tree : Project_Tree_Ref) is
- begin
- In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
- In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
- end Initialize;
-
- -------------------
- -- Print_Sources --
- -------------------
-
- -- Could use some comments in this body ???
-
- procedure Print_Sources (In_Tree : Project_Tree_Ref) is
- Unit : Unit_Index;
-
- begin
- Write_Line ("List of Sources:");
-
- Unit := Units_Htable.Get_First (In_Tree.Units_HT);
- while Unit /= No_Unit_Index loop
- Write_Str (" ");
- Write_Line (Namet.Get_Name_String (Unit.Name));
-
- if Unit.File_Names (Spec).File /= No_File then
- if Unit.File_Names (Spec).Project = No_Project then
- Write_Line (" No project");
-
- else
- Write_Str (" Project: ");
- Get_Name_String
- (Unit.File_Names (Spec).Project.Path.Name);
- Write_Line (Name_Buffer (1 .. Name_Len));
- end if;
-
- Write_Str (" spec: ");
- Write_Line
- (Namet.Get_Name_String
- (Unit.File_Names (Spec).File));
- end if;
-
- if Unit.File_Names (Impl).File /= No_File then
- if Unit.File_Names (Impl).Project = No_Project then
- Write_Line (" No project");
-
- else
- Write_Str (" Project: ");
- Get_Name_String
- (Unit.File_Names (Impl).Project.Path.Name);
- Write_Line (Name_Buffer (1 .. Name_Len));
- end if;
-
- Write_Str (" body: ");
- Write_Line
- (Namet.Get_Name_String (Unit.File_Names (Impl).File));
- end if;
-
- Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
- end loop;
-
- Write_Line ("end of List of Sources.");
- end Print_Sources;
-
- ----------------
- -- Project_Of --
- ----------------
-
- function Project_Of
- (Name : String;
- Main_Project : Project_Id;
- In_Tree : Project_Tree_Ref) return Project_Id
- is
- Result : Project_Id := No_Project;
-
- Original_Name : String := Name;
-
- Lang : constant Language_Ptr :=
- Get_Language_From_Name (Main_Project, "ada");
-
- Unit : Unit_Index;
-
- Current_Name : File_Name_Type;
- The_Original_Name : File_Name_Type;
- The_Spec_Name : File_Name_Type;
- The_Body_Name : File_Name_Type;
-
- begin
- -- ??? Same block in File_Name_Of_Library_Unit_Body
- Canonical_Case_File_Name (Original_Name);
- Name_Len := Original_Name'Length;
- Name_Buffer (1 .. Name_Len) := Original_Name;
- The_Original_Name := Name_Find;
-
- if Lang /= null then
- declare
- Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
- Extended_Spec_Name : String :=
- Name & Namet.Get_Name_String
- (Naming.Spec_Suffix);
- Extended_Body_Name : String :=
- Name & Namet.Get_Name_String
- (Naming.Body_Suffix);
-
- begin
- Canonical_Case_File_Name (Extended_Spec_Name);
- Name_Len := Extended_Spec_Name'Length;
- Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
- The_Spec_Name := Name_Find;
-
- Canonical_Case_File_Name (Extended_Body_Name);
- Name_Len := Extended_Body_Name'Length;
- Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
- The_Body_Name := Name_Find;
- end;
-
- else
- The_Spec_Name := The_Original_Name;
- The_Body_Name := The_Original_Name;
- end if;
-
- Unit := Units_Htable.Get_First (In_Tree.Units_HT);
- while Unit /= null loop
-
- -- Case of a body present
-
- if Unit.File_Names (Impl) /= null then
- Current_Name := Unit.File_Names (Impl).File;
-
- -- If it has the name of the original name or the body name,
- -- we have found the project.
-
- if Unit.Name = Name_Id (The_Original_Name)
- or else Current_Name = The_Original_Name
- or else Current_Name = The_Body_Name
- then
- Result := Unit.File_Names (Impl).Project;
- exit;
- end if;
- end if;
-
- -- Check for spec
-
- if Unit.File_Names (Spec) /= null then
- Current_Name := Unit.File_Names (Spec).File;
-
- -- If name same as the original name, or the spec name, we have
- -- found the project.
-
- if Unit.Name = Name_Id (The_Original_Name)
- or else Current_Name = The_Original_Name
- or else Current_Name = The_Spec_Name
- then
- Result := Unit.File_Names (Spec).Project;
- exit;
- end if;
- end if;
-
- Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
- end loop;
-
- return Ultimate_Extending_Project_Of (Result);
- end Project_Of;
-
- -------------------
- -- Set_Ada_Paths --
- -------------------
-
- procedure Set_Ada_Paths
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Including_Libraries : Boolean;
- Include_Path : Boolean := True;
- Objects_Path : Boolean := True)
-
- is
- Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
-
- Source_Paths : Source_Path_Table.Instance;
- Object_Paths : Object_Path_Table.Instance;
- -- List of source or object dirs. Only computed the first time this
- -- procedure is called (since Source_FD is then reused)
-
- Source_FD : File_Descriptor := Invalid_FD;
- Object_FD : File_Descriptor := Invalid_FD;
- -- The temporary files to store the paths. These are only created the
- -- first time this procedure is called, and reused from then on.
-
- Process_Source_Dirs : Boolean := False;
- Process_Object_Dirs : Boolean := False;
-
- Status : Boolean;
- -- For calls to Close
-
- Last : Natural;
- Buffer : String_Access := new String (1 .. Buffer_Initial);
- Buffer_Last : Natural := 0;
-
- procedure Recursive_Add
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean);
- -- Recursive procedure to add the source/object paths of extended/
- -- imported projects.
-
- -------------------
- -- Recursive_Add --
- -------------------
-
- procedure Recursive_Add
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Dummy : in out Boolean)
- is
- pragma Unreferenced (In_Tree);
-
- Path : Path_Name_Type;
-
- begin
- if Process_Source_Dirs then
-
- -- Add to path all source directories of this project if there are
- -- Ada sources.
-
- if Has_Ada_Sources (Project) then
- Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths);
- end if;
- end if;
-
- if Process_Object_Dirs then
- Path := Get_Object_Directory
- (Project,
- Including_Libraries => Including_Libraries,
- Only_If_Ada => True);
-
- if Path /= No_Path then
- Add_To_Object_Path (Path, Object_Paths);
- end if;
- end if;
- end Recursive_Add;
-
- procedure For_All_Projects is
- new For_Every_Project_Imported (Boolean, Recursive_Add);
-
- Dummy : Boolean := False;
-
- -- Start of processing for Set_Ada_Paths
-
- begin
- -- If it is the first time we call this procedure for this project,
- -- compute the source path and/or the object path.
-
- if Include_Path and then Project.Include_Path_File = No_Path then
- Source_Path_Table.Init (Source_Paths);
- Process_Source_Dirs := True;
- Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File);
- end if;
-
- -- For the object path, we make a distinction depending on
- -- Including_Libraries.
-
- if Objects_Path and Including_Libraries then
- if Project.Objects_Path_File_With_Libs = No_Path then
- Object_Path_Table.Init (Object_Paths);
- Process_Object_Dirs := True;
- Create_New_Path_File
- (Shared, Object_FD, Project.Objects_Path_File_With_Libs);
- end if;
-
- elsif Objects_Path then
- if Project.Objects_Path_File_Without_Libs = No_Path then
- Object_Path_Table.Init (Object_Paths);
- Process_Object_Dirs := True;
- Create_New_Path_File
- (Shared, Object_FD, Project.Objects_Path_File_Without_Libs);
- end if;
- end if;
-
- -- If there is something to do, set Seen to False for all projects,
- -- then call the recursive procedure Add for Project.
-
- if Process_Source_Dirs or Process_Object_Dirs then
- For_All_Projects (Project, In_Tree, Dummy);
- end if;
-
- -- Write and close any file that has been created. Source_FD is not set
- -- when this subprogram is called a second time or more, since we reuse
- -- the previous version of the file.
-
- if Source_FD /= Invalid_FD then
- Buffer_Last := 0;
-
- for Index in
- Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths)
- loop
- Get_Name_String (Source_Paths.Table (Index));
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ASCII.LF;
- Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
- end loop;
-
- Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
-
- if Last = Buffer_Last then
- Close (Source_FD, Status);
-
- else
- Status := False;
- end if;
-
- if not Status then
- Prj.Com.Fail ("could not write temporary file");
- end if;
- end if;
-
- if Object_FD /= Invalid_FD then
- Buffer_Last := 0;
-
- for Index in
- Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths)
- loop
- Get_Name_String (Object_Paths.Table (Index));
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := ASCII.LF;
- Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
- end loop;
-
- Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
-
- if Last = Buffer_Last then
- Close (Object_FD, Status);
- else
- Status := False;
- end if;
-
- if not Status then
- Prj.Com.Fail ("could not write temporary file");
- end if;
- end if;
-
- -- Set the env vars, if they need to be changed, and set the
- -- corresponding flags.
-
- if Include_Path
- and then
- Shared.Private_Part.Current_Source_Path_File /=
- Project.Include_Path_File
- then
- Shared.Private_Part.Current_Source_Path_File :=
- Project.Include_Path_File;
- Set_Path_File_Var
- (Project_Include_Path_File,
- Get_Name_String (Shared.Private_Part.Current_Source_Path_File));
- end if;
-
- if Objects_Path then
- if Including_Libraries then
- if Shared.Private_Part.Current_Object_Path_File /=
- Project.Objects_Path_File_With_Libs
- then
- Shared.Private_Part.Current_Object_Path_File :=
- Project.Objects_Path_File_With_Libs;
- Set_Path_File_Var
- (Project_Objects_Path_File,
- Get_Name_String
- (Shared.Private_Part.Current_Object_Path_File));
- end if;
-
- else
- if Shared.Private_Part.Current_Object_Path_File /=
- Project.Objects_Path_File_Without_Libs
- then
- Shared.Private_Part.Current_Object_Path_File :=
- Project.Objects_Path_File_Without_Libs;
- Set_Path_File_Var
- (Project_Objects_Path_File,
- Get_Name_String
- (Shared.Private_Part.Current_Object_Path_File));
- end if;
- end if;
- end if;
-
- Free (Buffer);
- end Set_Ada_Paths;
-
- ---------------------
- -- Add_Directories --
- ---------------------
-
- procedure Add_Directories
- (Self : in out Project_Search_Path;
- Path : String;
- Prepend : Boolean := False)
- is
- Tmp : String_Access;
- begin
- if Self.Path = null then
- Self.Path := new String'(Uninitialized_Prefix & Path);
- else
- Tmp := Self.Path;
- if Prepend then
- Self.Path := new String'(Path & Path_Separator & Tmp.all);
- else
- Self.Path := new String'(Tmp.all & Path_Separator & Path);
- end if;
- Free (Tmp);
- end if;
-
- if Current_Verbosity = High then
- Debug_Output ("Adding directories to Project_Path: """
- & Path & '"');
- end if;
- end Add_Directories;
-
- --------------------
- -- Is_Initialized --
- --------------------
-
- function Is_Initialized (Self : Project_Search_Path) return Boolean is
- begin
- return Self.Path /= null
- and then (Self.Path'Length = 0
- or else Self.Path (Self.Path'First) /= '#');
- end Is_Initialized;
-
- ----------------------
- -- Initialize_Empty --
- ----------------------
-
- procedure Initialize_Empty (Self : in out Project_Search_Path) is
- begin
- Free (Self.Path);
- Self.Path := new String'("");
- end Initialize_Empty;
-
- -------------------------------------
- -- Initialize_Default_Project_Path --
- -------------------------------------
-
- procedure Initialize_Default_Project_Path
- (Self : in out Project_Search_Path;
- Target_Name : String;
- Runtime_Name : String := "")
- is
- Add_Default_Dir : Boolean := Target_Name /= "-";
- First : Positive;
- Last : Positive;
-
- Ada_Project_Path : constant String := "ADA_PROJECT_PATH";
- Gpr_Project_Path : constant String := "GPR_PROJECT_PATH";
- Gpr_Project_Path_File : constant String := "GPR_PROJECT_PATH_FILE";
- -- Names of alternate env. variable that contain path name(s) of
- -- directories where project files may reside. They are taken into
- -- account in this order: GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH,
- -- ADA_PROJECT_PATH.
-
- Gpr_Prj_Path_File : String_Access;
- Gpr_Prj_Path : String_Access;
- Ada_Prj_Path : String_Access;
- -- The path name(s) of directories where project files may reside.
- -- May be empty.
-
- Prefix : String_Ptr;
- Runtime : String_Ptr;
-
- procedure Add_Target;
- -- Add :<prefix>/<target> to the project path
-
- ----------------
- -- Add_Target --
- ----------------
-
- procedure Add_Target is
- begin
- Add_Str_To_Name_Buffer
- (Path_Separator & Prefix.all & Target_Name);
-
- -- Note: Target_Name has a trailing / when it comes from Sdefault
-
- if Name_Buffer (Name_Len) /= '/' then
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
- end Add_Target;
-
- -- Start of processing for Initialize_Default_Project_Path
-
- begin
- if Is_Initialized (Self) then
- return;
- end if;
-
- -- The current directory is always first in the search path. Since the
- -- Project_Path currently starts with '#:' as a sign that it isn't
- -- initialized, we simply replace '#' with '.'
-
- if Self.Path = null then
- Self.Path := new String'('.' & Path_Separator);
- else
- Self.Path (Self.Path'First) := '.';
- end if;
-
- -- Then the reset of the project path (if any) currently contains the
- -- directories added through Add_Search_Project_Directory
-
- -- If environment variables are defined and not empty, add their content
-
- Gpr_Prj_Path_File := Getenv (Gpr_Project_Path_File);
- Gpr_Prj_Path := Getenv (Gpr_Project_Path);
- Ada_Prj_Path := Getenv (Ada_Project_Path);
-
- if Gpr_Prj_Path_File.all /= "" then
- declare
- File : Ada.Text_IO.File_Type;
- Line : String (1 .. 10_000);
- Last : Natural;
-
- Tmp : String_Access;
-
- begin
- Open (File, In_File, Gpr_Prj_Path_File.all);
-
- while not End_Of_File (File) loop
- Get_Line (File, Line, Last);
-
- if Last /= 0
- and then (Last = 1 or else Line (1 .. 2) /= "--")
- then
- Tmp := Self.Path;
- Self.Path :=
- new String'
- (Tmp.all & Path_Separator & Line (1 .. Last));
- Free (Tmp);
- end if;
-
- if Current_Verbosity = High then
- Debug_Output ("Adding directory to Project_Path: """
- & Line (1 .. Last) & '"');
- end if;
- end loop;
-
- Close (File);
-
- exception
- when others =>
- Write_Str ("warning: could not read project path file """);
- Write_Str (Gpr_Prj_Path_File.all);
- Write_Line ("""");
- end;
-
- end if;
-
- if Gpr_Prj_Path.all /= "" then
- Add_Directories (Self, Gpr_Prj_Path.all);
- end if;
-
- Free (Gpr_Prj_Path);
-
- if Ada_Prj_Path.all /= "" then
- Add_Directories (Self, Ada_Prj_Path.all);
- end if;
-
- Free (Ada_Prj_Path);
-
- -- Copy to Name_Buffer, since we will need to manipulate the path
-
- Name_Len := Self.Path'Length;
- Name_Buffer (1 .. Name_Len) := Self.Path.all;
-
- -- Scan the directory path to see if "-" is one of the directories.
- -- Remove each occurrence of "-" and set Add_Default_Dir to False.
- -- Also resolve relative paths and symbolic links.
-
- First := 3;
- loop
- while First <= Name_Len
- and then (Name_Buffer (First) = Path_Separator)
- loop
- First := First + 1;
- end loop;
-
- exit when First > Name_Len;
-
- Last := First;
-
- while Last < Name_Len
- and then Name_Buffer (Last + 1) /= Path_Separator
- loop
- Last := Last + 1;
- end loop;
-
- -- If the directory is "-", set Add_Default_Dir to False and
- -- remove from path.
-
- if Name_Buffer (First .. Last) = No_Project_Default_Dir then
- Add_Default_Dir := False;
-
- for J in Last + 1 .. Name_Len loop
- Name_Buffer (J - No_Project_Default_Dir'Length - 1) :=
- Name_Buffer (J);
- end loop;
-
- Name_Len := Name_Len - No_Project_Default_Dir'Length - 1;
-
- -- After removing the '-', go back one character to get the next
- -- directory correctly.
-
- Last := Last - 1;
-
- else
- declare
- New_Dir : constant String :=
- Normalize_Pathname
- (Name_Buffer (First .. Last),
- Resolve_Links => Opt.Follow_Links_For_Dirs);
- New_Len : Positive;
- New_Last : Positive;
-
- begin
- -- If the absolute path was resolved and is different from
- -- the original, replace original with the resolved path.
-
- if New_Dir /= Name_Buffer (First .. Last)
- and then New_Dir'Length /= 0
- then
- New_Len := Name_Len + New_Dir'Length - (Last - First + 1);
- New_Last := First + New_Dir'Length - 1;
- Name_Buffer (New_Last + 1 .. New_Len) :=
- Name_Buffer (Last + 1 .. Name_Len);
- Name_Buffer (First .. New_Last) := New_Dir;
- Name_Len := New_Len;
- Last := New_Last;
- end if;
- end;
- end if;
-
- First := Last + 1;
- end loop;
-
- Free (Self.Path);
-
- -- Set the initial value of Current_Project_Path
-
- if Add_Default_Dir then
- if Sdefault.Search_Dir_Prefix = null then
-
- -- gprbuild case
-
- Prefix := new String'(Executable_Prefix_Path);
-
- else
- Prefix := new String'(Sdefault.Search_Dir_Prefix.all
- & ".." & Dir_Separator
- & ".." & Dir_Separator
- & ".." & Dir_Separator
- & ".." & Dir_Separator);
- end if;
-
- if Prefix.all /= "" then
- if Target_Name /= "" then
-
- if Runtime_Name /= "" then
- if Base_Name (Runtime_Name) = Runtime_Name then
-
- -- $prefix/$target/$runtime/lib/gnat
- Add_Target;
- Add_Str_To_Name_Buffer
- (Runtime_Name & Directory_Separator &
- "lib" & Directory_Separator & "gnat");
-
- -- $prefix/$target/$runtime/share/gpr
- Add_Target;
- Add_Str_To_Name_Buffer
- (Runtime_Name & Directory_Separator &
- "share" & Directory_Separator & "gpr");
-
- else
- Runtime :=
- new String'(Normalize_Pathname (Runtime_Name));
-
- -- $runtime_dir/lib/gnat
- Add_Str_To_Name_Buffer
- (Path_Separator & Runtime.all & Directory_Separator &
- "lib" & Directory_Separator & "gnat");
-
- -- $runtime_dir/share/gpr
- Add_Str_To_Name_Buffer
- (Path_Separator & Runtime.all & Directory_Separator &
- "share" & Directory_Separator & "gpr");
- end if;
- end if;
-
- -- $prefix/$target/lib/gnat
-
- Add_Target;
- Add_Str_To_Name_Buffer
- ("lib" & Directory_Separator & "gnat");
-
- -- $prefix/$target/share/gpr
-
- Add_Target;
- Add_Str_To_Name_Buffer
- ("share" & Directory_Separator & "gpr");
- end if;
-
- -- $prefix/share/gpr
-
- Add_Str_To_Name_Buffer
- (Path_Separator & Prefix.all & "share"
- & Directory_Separator & "gpr");
-
- -- $prefix/lib/gnat
-
- Add_Str_To_Name_Buffer
- (Path_Separator & Prefix.all & "lib"
- & Directory_Separator & "gnat");
- end if;
-
- Free (Prefix);
- end if;
-
- Self.Path := new String'(Name_Buffer (1 .. Name_Len));
- end Initialize_Default_Project_Path;
-
- --------------
- -- Get_Path --
- --------------
-
- procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is
- begin
- pragma Assert (Is_Initialized (Self));
- Path := Self.Path;
- end Get_Path;
-
- --------------
- -- Set_Path --
- --------------
-
- procedure Set_Path (Self : in out Project_Search_Path; Path : String) is
- begin
- Free (Self.Path);
- Self.Path := new String'(Path);
- Projects_Paths.Reset (Self.Cache);
- end Set_Path;
-
- -----------------------
- -- Find_Name_In_Path --
- -----------------------
-
- function Find_Name_In_Path
- (Self : Project_Search_Path;
- Path : String) return String_Access
- is
- First : Natural;
- Last : Natural;
-
- begin
- if Current_Verbosity = High then
- Debug_Output ("Trying " & Path);
- end if;
-
- if Is_Absolute_Path (Path) then
- if Check_Filename (Path) then
- return new String'(Path);
- else
- return null;
- end if;
-
- else
- -- Because we don't want to resolve symbolic links, we cannot use
- -- Locate_Regular_File. So, we try each possible path successively.
-
- First := Self.Path'First;
- while First <= Self.Path'Last loop
- while First <= Self.Path'Last
- and then Self.Path (First) = Path_Separator
- loop
- First := First + 1;
- end loop;
-
- exit when First > Self.Path'Last;
-
- Last := First;
- while Last < Self.Path'Last
- and then Self.Path (Last + 1) /= Path_Separator
- loop
- Last := Last + 1;
- end loop;
-
- Name_Len := 0;
-
- if not Is_Absolute_Path (Self.Path (First .. Last)) then
- Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
-
- Add_Str_To_Name_Buffer (Self.Path (First .. Last));
- Add_Char_To_Name_Buffer (Directory_Separator);
- Add_Str_To_Name_Buffer (Path);
-
- if Current_Verbosity = High then
- Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len));
- end if;
-
- if Check_Filename (Name_Buffer (1 .. Name_Len)) then
- return new String'(Name_Buffer (1 .. Name_Len));
- end if;
-
- First := Last + 1;
- end loop;
- end if;
-
- return null;
- end Find_Name_In_Path;
-
- ------------------
- -- Find_Project --
- ------------------
-
- procedure Find_Project
- (Self : in out Project_Search_Path;
- Project_File_Name : String;
- Directory : String;
- Path : out Namet.Path_Name_Type)
- is
- Result : String_Access;
- Has_Dot : Boolean := False;
- Key : Name_Id;
-
- File : constant String := Project_File_Name;
- -- Have to do a copy, in case the parameter is Name_Buffer, which we
- -- modify below.
-
- Cached_Path : Namet.Path_Name_Type;
- -- This should be commented rather than making us guess from the name???
-
- function Try_Path_Name is new
- Find_Name_In_Path (Check_Filename => Is_Regular_File);
- -- Find a file in the project search path
-
- -- Start of processing for Find_Project
-
- begin
- pragma Assert (Is_Initialized (Self));
-
- if Current_Verbosity = High then
- Debug_Increase_Indent
- ("Searching for project """ & File & """ in """
- & Directory & '"');
- end if;
-
- -- Check the project cache
-
- Name_Len := File'Length;
- Name_Buffer (1 .. Name_Len) := File;
- Key := Name_Find;
- Cached_Path := Projects_Paths.Get (Self.Cache, Key);
-
- -- Check if File contains an extension (a dot before a
- -- directory separator). If it is the case we do not try project file
- -- with an added extension as it is not possible to have multiple dots
- -- on a project file name.
-
- Check_Dot : for K in reverse File'Range loop
- if File (K) = '.' then
- Has_Dot := True;
- exit Check_Dot;
- end if;
-
- exit Check_Dot when Is_Directory_Separator (File (K));
- end loop Check_Dot;
-
- if not Is_Absolute_Path (File) then
-
- -- If we have found project in the cache, check if in the directory
-
- if Cached_Path /= No_Path then
- declare
- Cached : constant String := Get_Name_String (Cached_Path);
- begin
- if (not Has_Dot
- and then Cached =
- GNAT.OS_Lib.Normalize_Pathname
- (File & Project_File_Extension,
- Directory => Directory,
- Resolve_Links => Opt.Follow_Links_For_Files,
- Case_Sensitive => True))
- or else
- Cached =
- GNAT.OS_Lib.Normalize_Pathname
- (File,
- Directory => Directory,
- Resolve_Links => Opt.Follow_Links_For_Files,
- Case_Sensitive => True)
- then
- Path := Cached_Path;
- Debug_Decrease_Indent;
- return;
- end if;
- end;
- end if;
-
- -- First we try <directory>/<file_name>.<extension>
-
- if not Has_Dot then
- Result :=
- Try_Path_Name
- (Self,
- Directory & Directory_Separator
- & File & Project_File_Extension);
- end if;
-
- -- Then we try <directory>/<file_name>
-
- if Result = null then
- Result :=
- Try_Path_Name (Self, Directory & Directory_Separator & File);
- end if;
- end if;
-
- -- If we found the path in the cache, this is the one
-
- if Result = null and then Cached_Path /= No_Path then
- Path := Cached_Path;
- Debug_Decrease_Indent;
- return;
- end if;
-
- -- Then we try <file_name>.<extension>
-
- if Result = null and then not Has_Dot then
- Result := Try_Path_Name (Self, File & Project_File_Extension);
- end if;
-
- -- Then we try <file_name>
-
- if Result = null then
- Result := Try_Path_Name (Self, File);
- end if;
-
- -- If we cannot find the project file, we return an empty string
-
- if Result = null then
- Path := Namet.No_Path;
- return;
-
- else
- declare
- Final_Result : constant String :=
- GNAT.OS_Lib.Normalize_Pathname
- (Result.all,
- Directory => Directory,
- Resolve_Links => Opt.Follow_Links_For_Files,
- Case_Sensitive => True);
- begin
- Free (Result);
- Name_Len := Final_Result'Length;
- Name_Buffer (1 .. Name_Len) := Final_Result;
- Path := Name_Find;
- Projects_Paths.Set (Self.Cache, Key, Path);
- end;
- end if;
-
- Debug_Decrease_Indent;
- end Find_Project;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Self : in out Project_Search_Path) is
- begin
- Free (Self.Path);
- Projects_Paths.Reset (Self.Cache);
- end Free;
-
- ----------
- -- Copy --
- ----------
-
- procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is
- begin
- Free (To);
-
- if From.Path /= null then
- To.Path := new String'(From.Path.all);
- end if;
-
- -- No need to copy the Cache, it will be recomputed as needed
- end Copy;
-
-end Prj.Env;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . E N V --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package implements services for Project-aware tools, mostly related
--- to the environment (configuration pragma files, path files, mapping files).
-
-with GNAT.Dynamic_HTables;
-with GNAT.OS_Lib;
-
-package Prj.Env is
-
- procedure Initialize (In_Tree : Project_Tree_Ref);
- -- Initialize global components relative to environment variables
-
- procedure Print_Sources (In_Tree : Project_Tree_Ref);
- -- Output the list of sources after Project files have been scanned
-
- procedure Create_Mapping (In_Tree : Project_Tree_Ref);
- -- Create in memory mapping from the sources of all the projects (in body
- -- of package Fmap), so that Osint.Find_File will find the correct path
- -- corresponding to a source.
-
- procedure Create_Temp_File
- (Shared : Shared_Project_Tree_Data_Access;
- Path_FD : out File_Descriptor;
- Path_Name : out Path_Name_Type;
- File_Use : String);
- -- Create temporary file, fail with an error if it could not be created
-
- procedure Create_Mapping_File
- (Project : Project_Id;
- Language : Name_Id;
- In_Tree : Project_Tree_Ref;
- Name : out Path_Name_Type);
- -- Create a temporary mapping file for project Project. For each source or
- -- template of Language in the Project, put the mapping of its file name
- -- and path name in this file. See fmap for a description of the format
- -- of the mapping file.
- --
- -- Implementation note: we pass a language name, not a language_index here,
- -- since the latter would have to match exactly the index of that language
- -- for the specified project, and that is not information available in
- -- buildgpr.adb.
-
- procedure Create_Config_Pragmas_File
- (For_Project : Project_Id;
- In_Tree : Project_Tree_Ref);
- -- If we need SFN pragmas, either for non standard naming schemes or for
- -- individual units.
-
- procedure Create_New_Path_File
- (Shared : Shared_Project_Tree_Data_Access;
- Path_FD : out File_Descriptor;
- Path_Name : out Path_Name_Type);
- -- Create a new temporary path file, placing file name in Path_Name
-
- function Ada_Include_Path
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Recursive : Boolean := False) return String;
- -- Get the source search path of a Project file. If Recursive it True, get
- -- all the source directories of the imported and modified project files
- -- (recursively). If Recursive is False, just get the path for the source
- -- directories of Project. Note: the resulting String may be empty if there
- -- is no source directory in the project file.
-
- function Ada_Objects_Path
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Including_Libraries : Boolean := True) return String_Access;
- -- Get the ADA_OBJECTS_PATH of a Project file. For the first call with the
- -- exact same parameters, compute it and cache it. When Including_Libraries
- -- is True, the object directory of a library project is replaced with the
- -- library ALI directory of this project (usually the library directory of
- -- the project, except when attribute Library_ALI_Dir is declared) except
- -- when the library ALI directory does not contain any ALI file.
-
- procedure Set_Ada_Paths
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Including_Libraries : Boolean;
- Include_Path : Boolean := True;
- Objects_Path : Boolean := True);
- -- Set the environment variables for additional project path files, after
- -- creating the path files if necessary.
-
- function File_Name_Of_Library_Unit_Body
- (Name : String;
- Project : Project_Id;
- In_Tree : Project_Tree_Ref;
- Main_Project_Only : Boolean := True;
- Full_Path : Boolean := False) return String;
- -- Returns the file name of a library unit, in canonical case. Name may or
- -- may not have an extension (corresponding to the naming scheme of the
- -- project). If there is no body with this name, but there is a spec, the
- -- name of the spec is returned.
- --
- -- If Full_Path is False (the default), the simple file name is returned.
- -- If Full_Path is True, the absolute path name is returned.
- --
- -- If neither a body nor a spec can be found, an empty string is returned.
- -- If Main_Project_Only is True, the unit must be an immediate source of
- -- Project. If it is False, it may be a source of one of its imported
- -- projects.
-
- function Project_Of
- (Name : String;
- Main_Project : Project_Id;
- In_Tree : Project_Tree_Ref) return Project_Id;
- -- Get the project of a source. The source file name may be truncated
- -- (".adb" or ".ads" may be missing). If the source is in a project being
- -- extended, return the ultimate extending project. If it is not a source
- -- of any project, return No_Project.
-
- procedure Get_Reference
- (Source_File_Name : String;
- In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Path : out Path_Name_Type);
- -- Returns the project of a source and its path in displayable form
-
- generic
- with procedure Action (Path : String);
- procedure For_All_Source_Dirs
- (Project : Project_Id;
- In_Tree : Project_Tree_Ref);
- -- Iterate through all the source directories of a project, including those
- -- of imported or modified projects. Only returns those directories that
- -- potentially contain Ada sources (ie ignore projects that have no Ada
- -- sources
-
- generic
- with procedure Action (Path : String);
- procedure For_All_Object_Dirs
- (Project : Project_Id;
- Tree : Project_Tree_Ref);
- -- Iterate through all the object directories of a project, including those
- -- of imported or modified projects.
-
- ------------------
- -- Project Path --
- ------------------
-
- type Project_Search_Path is private;
- -- An abstraction of the project path. This object provides subprograms
- -- to search for projects on the path (and caches the results to improve
- -- efficiency).
-
- No_Project_Search_Path : constant Project_Search_Path;
-
- procedure Initialize_Default_Project_Path
- (Self : in out Project_Search_Path;
- Target_Name : String;
- Runtime_Name : String := "");
- -- Initialize Self. It will then contain the default project path on
- -- the given target and runtime (including directories specified by the
- -- environment variables GPR_PROJECT_PATH_FILE, GPR_PROJECT_PATH and
- -- ADA_PROJECT_PATH). If one of the directory or Target_Name is "-", then
- -- the path contains only those directories specified by the environment
- -- variables (except "-"). This does nothing if Self has already been
- -- initialized.
-
- procedure Copy (From : Project_Search_Path; To : out Project_Search_Path);
- -- Copy From into To
-
- 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.
-
- function Is_Initialized (Self : Project_Search_Path) return Boolean;
- -- Whether Self has been initialized
-
- procedure Free (Self : in out Project_Search_Path);
- -- Free the memory used by Self
-
- procedure Add_Directories
- (Self : in out Project_Search_Path;
- Path : String;
- Prepend : Boolean := False);
- -- Add one or more directories to the path. Directories added with this
- -- procedure are added in order after the current directory and before the
- -- path given by the environment variable GPR_PROJECT_PATH. A value of "-"
- -- will remove the default project directory from the project path.
- --
- -- 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);
- -- 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);
- -- Override the value of the project path. This also removes the implicit
- -- default search directories.
-
- generic
- with function Check_Filename (Name : String) return Boolean;
- function Find_Name_In_Path
- (Self : Project_Search_Path;
- Path : String) return String_Access;
- -- Find a name in the project search path of Self. Check_Filename is
- -- the predicate to valid the search. If Path is an absolute filename,
- -- simply calls the predicate with Path. Otherwise, calls the predicate
- -- for each component of the path. Stops as soon as the predicate
- -- returns True and returns the name, or returns null in case of failure.
-
- procedure Find_Project
- (Self : in out Project_Search_Path;
- Project_File_Name : String;
- Directory : String;
- Path : out Namet.Path_Name_Type);
- -- 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.
- --
- -- Project_File_Name can optionally contain directories, and the extension
- -- (.gpr) for the file name is optional.
- --
- -- Returns No_Name if no such project was found
-
- function Get_Runtime_Path
- (Self : Project_Search_Path;
- Name : String) return String_Access;
- -- Compute the full path for the project-based runtime name.
- -- Name is simply searched on the project path.
-
-private
- package Projects_Paths is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => Path_Name_Type,
- No_Element => No_Path,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
-
- type Project_Search_Path is record
- Path : GNAT.OS_Lib.String_Access;
- -- As a special case, if the first character is '#:" or this variable
- -- is unset, this means that the PATH has not been fully initialized
- -- yet (although subprograms above will properly take care of that).
-
- Cache : Projects_Paths.Instance;
- end record;
-
- No_Project_Search_Path : constant Project_Search_Path :=
- (Path => null,
- Cache => Projects_Paths.Nil);
-
-end Prj.Env;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . E R R --
--- --
--- B o d y --
--- --
--- Copyright (C) 2002-2014, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Err_Vars;
-with Output; use Output;
-with Stringt; use Stringt;
-
-package body Prj.Err is
-
- ---------------
- -- Post_Scan --
- ---------------
-
- procedure Post_Scan is
- Debug_Tokens : constant Boolean := False;
-
- begin
- -- Change operator symbol to literal strings, since that's the way
- -- we treat all strings in a project file.
-
- if Token = Tok_Operator_Symbol
- or else Token = Tok_String_Literal
- then
- Token := Tok_String_Literal;
- String_To_Name_Buffer (String_Literal_Id);
- Token_Name := Name_Find;
- end if;
-
- if Debug_Tokens then
- Write_Line (Token_Type'Image (Token));
-
- if Token = Tok_Identifier
- or else Token = Tok_String_Literal
- then
- Write_Line (" " & Get_Name_String (Token_Name));
- end if;
- end if;
- end Post_Scan;
-
- ---------------
- -- Error_Msg --
- ---------------
-
- procedure Error_Msg
- (Flags : Processing_Flags;
- Msg : String;
- Location : Source_Ptr := No_Location;
- Project : Project_Id := null)
- is
- Real_Location : Source_Ptr := Location;
-
- begin
- -- Don't post message if incompleted with's (avoid junk cascaded errors)
-
- if Flags.Incomplete_Withs then
- return;
- end if;
-
- -- Display the error message in the traces so that it appears in the
- -- correct location in the traces (otherwise error messages are only
- -- displayed at the end and it is difficult to see when they were
- -- triggered)
-
- if Current_Verbosity = High then
- Debug_Output ("ERROR: " & Msg);
- end if;
-
- -- If location of error is unknown, use the location of the project
-
- if Real_Location = No_Location
- and then Project /= null
- then
- Real_Location := Project.Location;
- end if;
-
- if Real_Location = No_Location then
-
- -- If still null, we are parsing a project that was created in-memory
- -- so we shouldn't report errors for projects that the user has no
- -- access to in any case.
-
- if Current_Verbosity = High then
- Debug_Output ("Error in in-memory project, ignored");
- end if;
-
- return;
- end if;
-
- -- Report the error through Errutil, so that duplicate errors are
- -- properly removed, messages are sorted, and correctly interpreted,...
-
- Errutil.Error_Msg (Msg, Real_Location);
-
- -- Let the application know there was an error
-
- if Flags.Report_Error /= null then
- Flags.Report_Error
- (Project,
- Is_Warning =>
- Msg (Msg'First) = '?'
- or else (Msg (Msg'First) = '<'
- and then Err_Vars.Error_Msg_Warn)
- or else (Msg (Msg'First) = '\'
- and then Msg (Msg'First + 1) = '<'
- and then Err_Vars.Error_Msg_Warn));
- end if;
- end Error_Msg;
-
-end Prj.Err;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . E R R --
--- --
--- S p e c --
--- --
--- Copyright (C) 2002-2010, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package contains the routines to output error messages and the scanner
--- for the project files. It replaces Errout and Scn. It is not dependent on
--- the GNAT tree packages (Atree, Sinfo, ...). It uses exactly the same global
--- variables as Errout, located in package Err_Vars. Like Errout, it also uses
--- the common variables and routines in package Erroutc.
---
--- Parameters are set through Err_Vars.Error_Msg_File_* or
--- Err_Vars.Error_Msg_Name_*, and replaced automatically in the messages
--- ("{{" for files, "%%" for names).
---
--- However, in this package you can configure the error messages to be sent
--- to your own callback by setting Report_Error in the flags. This ensures
--- that applications can control where error messages are displayed.
-
-with Scng;
-with Errutil;
-
-package Prj.Err is
-
- ---------------------------------------------------------
- -- Error Message Text and Message Insertion Characters --
- ---------------------------------------------------------
-
- -- See errutil.ads
-
- -----------------------------------------------------
- -- Format of Messages and Manual Quotation Control --
- -----------------------------------------------------
-
- -- See errutil.ads
-
- ------------------------------
- -- Error Output Subprograms --
- ------------------------------
-
- procedure Initialize renames Errutil.Initialize;
- -- Initializes for output of error messages. Must be called for each
- -- file before using any of the other routines in the package.
-
- procedure Finalize (Source_Type : String := "project")
- renames Errutil.Finalize;
- -- Finalize processing of error messages for one file and output message
- -- indicating the number of detected errors.
-
- procedure Error_Msg
- (Flags : Processing_Flags;
- Msg : String;
- Location : Source_Ptr := No_Location;
- Project : Project_Id := null);
- -- Output an error message, either through Flags.Error_Report or through
- -- Errutil. The location defaults to the project's location ("project"
- -- in the source code). If Msg starts with "?", this is a warning, and
- -- Warning: is added at the beginning. If Msg starts with "<", see comment
- -- for Err_Vars.Error_Msg_Warn.
-
- -------------
- -- Scanner --
- -------------
-
- procedure Post_Scan;
- -- Convert an Ada operator symbol into a standard string
-
- package Scanner is new Scng
- (Post_Scan => Post_Scan,
- Error_Msg => Errutil.Error_Msg,
- Error_Msg_S => Errutil.Error_Msg_S,
- Error_Msg_SC => Errutil.Error_Msg_SC,
- Error_Msg_SP => Errutil.Error_Msg_SP,
- Style => Errutil.Style);
- -- Instantiation of the generic scanner
-
-end Prj.Err;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . E X T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Osint; use Osint;
-
-with Ada.Unchecked_Deallocation;
-
-package body Prj.Ext is
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Self : out External_References;
- Copy_From : External_References := No_External_Refs)
- is
- N : Name_To_Name_Ptr;
- N2 : Name_To_Name_Ptr;
- begin
- if Self.Refs = null then
- Self.Refs := new Name_To_Name_HTable.Instance;
-
- if Copy_From.Refs /= null then
- N := Name_To_Name_HTable.Get_First (Copy_From.Refs.all);
- while N /= null loop
- N2 := new Name_To_Name'
- (Key => N.Key,
- Value => N.Value,
- Source => N.Source,
- Next => null);
- Name_To_Name_HTable.Set (Self.Refs.all, N2);
- N := Name_To_Name_HTable.Get_Next (Copy_From.Refs.all);
- end loop;
- end if;
- end if;
- end Initialize;
-
- ---------
- -- Add --
- ---------
-
- procedure Add
- (Self : External_References;
- External_Name : String;
- Value : String;
- Source : External_Source := External_Source'First;
- Silent : Boolean := False)
- is
- Key : Name_Id;
- N : Name_To_Name_Ptr;
-
- begin
- -- For external attribute, set the environment variable
-
- if Source = From_External_Attribute and then External_Name /= "" then
- declare
- Env_Var : String_Access := Getenv (External_Name);
-
- begin
- if Env_Var = null or else Env_Var.all = "" then
- Setenv (Name => External_Name, Value => Value);
-
- if not Silent then
- Debug_Output
- ("Environment variable """ & External_Name
- & """ = """ & Value & '"');
- end if;
-
- elsif not Silent then
- Debug_Output
- ("Not overriding existing environment variable """
- & External_Name & """, value is """ & Env_Var.all & '"');
- end if;
-
- Free (Env_Var);
- end;
- end if;
-
- Name_Len := External_Name'Length;
- Name_Buffer (1 .. Name_Len) := External_Name;
- Canonical_Case_Env_Var_Name (Name_Buffer (1 .. Name_Len));
- Key := Name_Find;
-
- -- Check whether the value is already defined, to properly respect the
- -- overriding order.
-
- if Source /= External_Source'First then
- N := Name_To_Name_HTable.Get (Self.Refs.all, Key);
-
- if N /= null then
- if External_Source'Pos (N.Source) <
- External_Source'Pos (Source)
- then
- if not Silent then
- Debug_Output
- ("Not overriding existing external reference '"
- & External_Name & "', value was defined in "
- & N.Source'Img);
- end if;
-
- return;
- end if;
- end if;
- end if;
-
- Name_Len := Value'Length;
- Name_Buffer (1 .. Name_Len) := Value;
- N := new Name_To_Name'
- (Key => Key,
- Source => Source,
- Value => Name_Find,
- Next => null);
-
- if not Silent then
- Debug_Output ("Add external (" & External_Name & ") is", N.Value);
- end if;
-
- Name_To_Name_HTable.Set (Self.Refs.all, N);
- end Add;
-
- -----------
- -- Check --
- -----------
-
- function Check
- (Self : External_References;
- Declaration : String) return Boolean
- is
- begin
- for Equal_Pos in Declaration'Range loop
- if Declaration (Equal_Pos) = '=' then
- exit when Equal_Pos = Declaration'First;
- Add
- (Self => Self,
- External_Name =>
- Declaration (Declaration'First .. Equal_Pos - 1),
- Value =>
- Declaration (Equal_Pos + 1 .. Declaration'Last),
- Source => From_Command_Line);
- return True;
- end if;
- end loop;
-
- return False;
- end Check;
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset (Self : External_References) is
- begin
- if Self.Refs /= null then
- Debug_Output ("Reset external references");
- Name_To_Name_HTable.Reset (Self.Refs.all);
- end if;
- end Reset;
-
- --------------
- -- Value_Of --
- --------------
-
- function Value_Of
- (Self : External_References;
- External_Name : Name_Id;
- With_Default : Name_Id := No_Name)
- return Name_Id
- is
- Value : Name_To_Name_Ptr;
- Val : Name_Id;
- Name : String := Get_Name_String (External_Name);
-
- begin
- Canonical_Case_Env_Var_Name (Name);
-
- if Self.Refs /= null then
- Name_Len := Name'Length;
- Name_Buffer (1 .. Name_Len) := Name;
- Value := Name_To_Name_HTable.Get (Self.Refs.all, Name_Find);
-
- if Value /= null then
- Debug_Output ("Value_Of (" & Name & ") is in cache", Value.Value);
- return Value.Value;
- end if;
- end if;
-
- -- Find if it is an environment, if it is, put value in the hash table
-
- declare
- Env_Value : String_Access := Getenv (Name);
-
- begin
- if Env_Value /= null and then Env_Value'Length > 0 then
- Name_Len := Env_Value'Length;
- Name_Buffer (1 .. Name_Len) := Env_Value.all;
- Val := Name_Find;
-
- if Current_Verbosity = High then
- Debug_Output ("Value_Of (" & Name & ") is", Val);
- end if;
-
- if Self.Refs /= null then
- Value := new Name_To_Name'
- (Key => External_Name,
- Value => Val,
- Source => From_Environment,
- Next => null);
- Name_To_Name_HTable.Set (Self.Refs.all, Value);
- end if;
-
- Free (Env_Value);
- return Val;
-
- else
- if Current_Verbosity = High then
- Debug_Output
- ("Value_Of (" & Name & ") is default", With_Default);
- end if;
-
- Free (Env_Value);
- return With_Default;
- end if;
- end;
- end Value_Of;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Self : in out External_References) is
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Name_To_Name_HTable.Instance, Instance_Access);
- begin
- if Self.Refs /= null then
- Reset (Self);
- Unchecked_Free (Self.Refs);
- end if;
- end Free;
-
- --------------
- -- Set_Next --
- --------------
-
- procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr) is
- begin
- E.Next := Next;
- end Set_Next;
-
- ----------
- -- Next --
- ----------
-
- function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr is
- begin
- return E.Next;
- end Next;
-
- -------------
- -- Get_Key --
- -------------
-
- function Get_Key (E : Name_To_Name_Ptr) return Name_Id is
- begin
- return E.Key;
- end Get_Key;
-
-end Prj.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . E X T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Subprograms to set, get and cache external references, to be used as
--- External functions in project files.
-
-with GNAT.Dynamic_HTables;
-
-package Prj.Ext is
-
- -------------------------
- -- External References --
- -------------------------
-
- -- External references influence the way a project tree is processed (in
- -- particular they provide the values for the typed string variables that
- -- are then used in case constructions).
-
- -- External references are project-tree specific, so that when multiple
- -- trees are loaded in parallel we can have different scenarios (or even
- -- load the same tree twice and see different views of it).
-
- type External_References is private;
- No_External_Refs : constant External_References;
-
- procedure Initialize
- (Self : out External_References;
- Copy_From : External_References := No_External_Refs);
- -- Initialize Self, and copy all values from Copy_From if needed.
- -- This has no effect if Self was already initialized.
-
- procedure Free (Self : in out External_References);
- -- Free memory used by Self
-
- type External_Source is
- (From_Command_Line,
- From_Environment,
- From_External_Attribute);
- -- Indicates where was the value of an external reference defined. They are
- -- prioritized in that order, so that a user can always use the command
- -- line to override a value coming from his environment, or an environment
- -- variable to override a value defined in an aggregate project through the
- -- "for External()..." attribute.
-
- procedure Add
- (Self : External_References;
- External_Name : String;
- Value : String;
- Source : External_Source := External_Source'First;
- Silent : Boolean := False);
- -- Add an external reference (or modify an existing one). No overriding is
- -- done if the Source's priority is less than the one used to previously
- -- set the value of the variable. The default for Source is such that
- -- overriding always occurs. When Silent is True, nothing is output even
- -- with non default verbosity.
-
- function Value_Of
- (Self : External_References;
- External_Name : Name_Id;
- With_Default : Name_Id := No_Name)
- return Name_Id;
- -- Get the value of an external reference, and cache it for future uses
-
- function Check
- (Self : External_References;
- Declaration : String) return Boolean;
- -- Check that an external declaration <external>=<value> is correct.
- -- If it is correct, the external reference is Added.
-
- procedure Reset (Self : External_References);
- -- Clear the internal data structure that stores the external references
- -- and free any allocated memory.
-
-private
- -- Use a Static_HTable, rather than a Simple_HTable
-
- -- The issue is that we need to be able to copy the contents of the table
- -- (in Initialize), but this isn't doable for Simple_HTable for which
- -- iterators do not return the key.
-
- type Name_To_Name;
- type Name_To_Name_Ptr is access all Name_To_Name;
- type Name_To_Name is record
- Key : Name_Id;
- Value : Name_Id;
- Source : External_Source;
- Next : Name_To_Name_Ptr;
- end record;
-
- procedure Set_Next (E : Name_To_Name_Ptr; Next : Name_To_Name_Ptr);
- function Next (E : Name_To_Name_Ptr) return Name_To_Name_Ptr;
- function Get_Key (E : Name_To_Name_Ptr) return Name_Id;
-
- package Name_To_Name_HTable is new GNAT.Dynamic_HTables.Static_HTable
- (Header_Num => Header_Num,
- Element => Name_To_Name,
- Elmt_Ptr => Name_To_Name_Ptr,
- Null_Ptr => null,
- Set_Next => Set_Next,
- Next => Next,
- Key => Name_Id,
- Get_Key => Get_Key,
- Hash => Hash,
- Equal => "=");
- -- General type for htables associating name_id to name_id. This is in
- -- particular used to store the values of external references.
-
- type Instance_Access is access all Name_To_Name_HTable.Instance;
-
- type External_References is record
- Refs : Instance_Access;
- -- External references are stored in this hash table (and manipulated
- -- through subprogrames in prj-ext.ads). External references are
- -- project-tree specific so that one can load the same tree twice but
- -- have two views of it, for instance.
- end record;
-
- No_External_Refs : constant External_References := (Refs => null);
-
-end Prj.Ext;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . M A K R --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Csets;
-with Makeutl; use Makeutl;
-with Opt;
-with Output;
-with Osint; use Osint;
-with Prj; use Prj;
-with Prj.Com;
-with Prj.Env;
-with Prj.Part;
-with Prj.PP;
-with Prj.Tree; use Prj.Tree;
-with Prj.Util; use Prj.Util;
-with Sdefault;
-with Snames; use Snames;
-with Stringt;
-with Table; use Table;
-with Tempdir;
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-
-with System.Case_Util; use System.Case_Util;
-with System.CRTL;
-with System.HTable;
-
-package body Prj.Makr is
-
- -- Packages of project files where unknown attributes are errors
-
- -- All the following need comments ??? All global variables and
- -- subprograms must be fully commented.
-
- Very_Verbose : Boolean := False;
- -- Set in call to Initialize to indicate very verbose output
-
- Project_File : Boolean := False;
- -- True when gnatname is creating/modifying a project file. False when
- -- gnatname is creating a configuration pragmas file.
-
- Tree : constant Project_Node_Tree_Ref := new Project_Node_Tree_Data;
- -- The project tree where the project file is parsed
-
- Args : Argument_List_Access;
- -- The list of arguments for calls to the compiler to get the unit names
- -- and kinds (spec or body) in the Ada sources.
-
- Path_Name : String_Access;
-
- Path_Last : Natural;
-
- Directory_Last : Natural := 0;
-
- Output_Name : String_Access;
- Output_Name_Last : Natural;
- Output_Name_Id : Name_Id;
-
- Project_Naming_File_Name : String_Access;
- -- String (1 .. Output_Name'Length + Naming_File_Suffix'Length);
-
- Project_Naming_Last : Natural;
- Project_Naming_Id : Name_Id := No_Name;
-
- Source_List_Path : String_Access;
- -- (1 .. Output_Name'Length + Source_List_File_Suffix'Length);
- Source_List_Last : Natural;
-
- Source_List_FD : File_Descriptor;
-
- Project_Node : Project_Node_Id := Empty_Node;
- Project_Declaration : Project_Node_Id := Empty_Node;
- Source_Dirs_List : Project_Node_Id := Empty_Node;
-
- Project_Naming_Node : Project_Node_Id := Empty_Node;
- Project_Naming_Decl : Project_Node_Id := Empty_Node;
- Naming_Package : Project_Node_Id := Empty_Node;
- Naming_Package_Comments : Project_Node_Id := Empty_Node;
-
- Source_Files_Comments : Project_Node_Id := Empty_Node;
- Source_Dirs_Comments : Project_Node_Id := Empty_Node;
- Source_List_File_Comments : Project_Node_Id := Empty_Node;
-
- Naming_String : aliased String := "naming";
-
- Gnatname_Packages : aliased String_List := (1 => Naming_String'Access);
-
- Packages_To_Check_By_Gnatname : constant String_List_Access :=
- Gnatname_Packages'Access;
-
- function Dup (Fd : File_Descriptor) return File_Descriptor;
-
- procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
-
- Gcc : constant String := "gcc";
- Gcc_Path : String_Access := null;
-
- Non_Empty_Node : constant Project_Node_Id := 1;
- -- Used for the With_Clause of the naming project
-
- -- Turn off warnings for now around this redefinition of True and False,
- -- but it really seems a bit horrible to do this redefinition ???
-
- pragma Warnings (Off);
- type Matched_Type is (True, False, Excluded);
- pragma Warnings (On);
-
- Naming_File_Suffix : constant String := "_naming";
- Source_List_File_Suffix : constant String := "_source_list.txt";
-
- Output_FD : File_Descriptor;
- -- To save the project file and its naming project file
-
- procedure Write_Eol;
- -- Output an empty line
-
- procedure Write_A_Char (C : Character);
- -- Write one character to Output_FD
-
- procedure Write_A_String (S : String);
- -- Write a String to Output_FD
-
- package Processed_Directories is new Table.Table
- (Table_Component_Type => String_Access,
- Table_Index_Type => Natural,
- Table_Low_Bound => 0,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Makr.Processed_Directories");
- -- The list of already processed directories for each section, to avoid
- -- processing several times the same directory in the same section.
-
- package Source_Directories is new Table.Table
- (Table_Component_Type => String_Access,
- Table_Index_Type => Natural,
- Table_Low_Bound => 0,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Makr.Source_Directories");
- -- The complete list of directories to be put in attribute Source_Dirs in
- -- the project file.
-
- type Source is record
- File_Name : Name_Id;
- Unit_Name : Name_Id;
- Index : Int := 0;
- Spec : Boolean;
- end record;
-
- package Sources is new Table.Table
- (Table_Component_Type => Source,
- Table_Index_Type => Natural,
- Table_Low_Bound => 0,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Makr.Sources");
- -- The list of Ada sources found, with their unit name and kind, to be put
- -- in the source attribute and package Naming of the project file, or in
- -- the pragmas Source_File_Name in the configuration pragmas file.
-
- package Source_Files is new System.HTable.Simple_HTable
- (Header_Num => Prj.Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => Name_Id,
- Hash => Prj.Hash,
- Equal => "=");
- -- Hash table to keep track of source file names, to avoid putting several
- -- times the same file name in case of multi-unit files.
-
- ---------
- -- Dup --
- ---------
-
- function Dup (Fd : File_Descriptor) return File_Descriptor is
- begin
- return File_Descriptor (System.CRTL.dup (Integer (Fd)));
- end Dup;
-
- ----------
- -- Dup2 --
- ----------
-
- procedure Dup2 (Old_Fd, New_Fd : File_Descriptor) is
- Fd : Integer;
- pragma Warnings (Off, Fd);
- begin
- Fd := System.CRTL.dup2 (Integer (Old_Fd), Integer (New_Fd));
- end Dup2;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize is
- Discard : Boolean;
- pragma Warnings (Off, Discard);
-
- Current_Source_Dir : Project_Node_Id := Empty_Node;
-
- begin
- if Project_File then
- -- If there were no already existing project file, or if the parsing
- -- was unsuccessful, create an empty project node with the correct
- -- name and its project declaration node.
-
- if No (Project_Node) then
- Project_Node :=
- Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
- Set_Name_Of (Project_Node, Tree, To => Output_Name_Id);
- Set_Project_Declaration_Of
- (Project_Node, Tree,
- To => Default_Project_Node
- (Of_Kind => N_Project_Declaration, In_Tree => Tree));
-
- end if;
-
- end if;
-
- -- Delete the file if it already exists
-
- Delete_File
- (Path_Name (Directory_Last + 1 .. Path_Last),
- Success => Discard);
-
- -- Create a new one
-
- if Opt.Verbose_Mode then
- Output.Write_Str ("Creating new file """);
- Output.Write_Str (Path_Name (Directory_Last + 1 .. Path_Last));
- Output.Write_Line ("""");
- end if;
-
- Output_FD := Create_New_File
- (Path_Name (Directory_Last + 1 .. Path_Last),
- Fmode => Text);
-
- -- Fails if project file cannot be created
-
- if Output_FD = Invalid_FD then
- Prj.Com.Fail
- ("cannot create new """ & Path_Name (1 .. Path_Last) & """");
- end if;
-
- if Project_File then
-
- -- Delete the source list file, if it already exists
-
- declare
- Discard : Boolean;
- pragma Warnings (Off, Discard);
- begin
- Delete_File
- (Source_List_Path (1 .. Source_List_Last),
- Success => Discard);
- end;
-
- -- And create a new source list file, fail if file cannot be created
-
- Source_List_FD := Create_New_File
- (Name => Source_List_Path (1 .. Source_List_Last),
- Fmode => Text);
-
- if Source_List_FD = Invalid_FD then
- Prj.Com.Fail
- ("cannot create file """
- & Source_List_Path (1 .. Source_List_Last)
- & """");
- end if;
-
- if Opt.Verbose_Mode then
- Output.Write_Str ("Naming project file name is """);
- Output.Write_Str
- (Project_Naming_File_Name (1 .. Project_Naming_Last));
- Output.Write_Line ("""");
- end if;
-
- -- Create the naming project node
-
- Project_Naming_Node :=
- Default_Project_Node (Of_Kind => N_Project, In_Tree => Tree);
- Set_Name_Of (Project_Naming_Node, Tree, To => Project_Naming_Id);
- Project_Naming_Decl :=
- Default_Project_Node
- (Of_Kind => N_Project_Declaration, In_Tree => Tree);
- Set_Project_Declaration_Of
- (Project_Naming_Node, Tree, Project_Naming_Decl);
- Naming_Package :=
- Default_Project_Node
- (Of_Kind => N_Package_Declaration, In_Tree => Tree);
- Set_Name_Of (Naming_Package, Tree, To => Name_Naming);
-
- -- Add an attribute declaration for Source_Files as an empty list (to
- -- indicate there are no sources in the naming project) and a package
- -- Naming (that will be filled later).
-
- declare
- Decl_Item : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Declarative_Item, In_Tree => Tree);
-
- Attribute : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Attribute_Declaration,
- In_Tree => Tree,
- And_Expr_Kind => List);
-
- Expression : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Expression,
- In_Tree => Tree,
- And_Expr_Kind => List);
-
- Term : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Term,
- In_Tree => Tree,
- And_Expr_Kind => List);
-
- Empty_List : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String_List,
- In_Tree => Tree);
-
- begin
- Set_First_Declarative_Item_Of
- (Project_Naming_Decl, Tree, To => Decl_Item);
- Set_Next_Declarative_Item (Decl_Item, Tree, Naming_Package);
- Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
- Set_Name_Of (Attribute, Tree, To => Name_Source_Files);
- Set_Expression_Of (Attribute, Tree, To => Expression);
- Set_First_Term (Expression, Tree, To => Term);
- Set_Current_Term (Term, Tree, To => Empty_List);
- end;
-
- -- Add a with clause on the naming project in the main project, if
- -- there is not already one.
-
- declare
- With_Clause : Project_Node_Id :=
- First_With_Clause_Of (Project_Node, Tree);
-
- begin
- while Present (With_Clause) loop
- exit when
- Prj.Tree.Name_Of (With_Clause, Tree) = Project_Naming_Id;
- With_Clause := Next_With_Clause_Of (With_Clause, Tree);
- end loop;
-
- if No (With_Clause) then
- With_Clause := Default_Project_Node
- (Of_Kind => N_With_Clause, In_Tree => Tree);
- Set_Next_With_Clause_Of
- (With_Clause, Tree,
- To => First_With_Clause_Of (Project_Node, Tree));
- Set_First_With_Clause_Of
- (Project_Node, Tree, To => With_Clause);
- Set_Name_Of (With_Clause, Tree, To => Project_Naming_Id);
-
- -- We set the project node to something different than
- -- Empty_Node, so that Prj.PP does not generate a limited
- -- with clause.
-
- Set_Project_Node_Of (With_Clause, Tree, Non_Empty_Node);
-
- Name_Len := Project_Naming_Last;
- Name_Buffer (1 .. Name_Len) :=
- Project_Naming_File_Name (1 .. Project_Naming_Last);
- Set_String_Value_Of (With_Clause, Tree, To => Name_Find);
- end if;
- end;
-
- Project_Declaration := Project_Declaration_Of (Project_Node, Tree);
-
- -- Add a package Naming in the main project, that is a renaming of
- -- package Naming in the naming project.
-
- declare
- Decl_Item : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Declarative_Item,
- In_Tree => Tree);
-
- Naming : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Package_Declaration,
- In_Tree => Tree);
-
- begin
- Set_Next_Declarative_Item
- (Decl_Item, Tree,
- To => First_Declarative_Item_Of (Project_Declaration, Tree));
- Set_First_Declarative_Item_Of
- (Project_Declaration, Tree, To => Decl_Item);
- Set_Current_Item_Node (Decl_Item, Tree, To => Naming);
- Set_Name_Of (Naming, Tree, To => Name_Naming);
- Set_Project_Of_Renamed_Package_Of
- (Naming, Tree, To => Project_Naming_Node);
-
- -- Attach the comments, if any, that were saved for package
- -- Naming.
-
- Tree.Project_Nodes.Table (Naming).Comments :=
- Naming_Package_Comments;
- end;
-
- -- Add an attribute declaration for Source_Dirs, initialized as an
- -- empty list.
-
- declare
- Decl_Item : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Declarative_Item,
- In_Tree => Tree);
-
- Attribute : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Attribute_Declaration,
- In_Tree => Tree,
- And_Expr_Kind => List);
-
- Expression : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Expression,
- In_Tree => Tree,
- And_Expr_Kind => List);
-
- Term : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Term, In_Tree => Tree,
- And_Expr_Kind => List);
-
- begin
- Set_Next_Declarative_Item
- (Decl_Item, Tree,
- To => First_Declarative_Item_Of (Project_Declaration, Tree));
- Set_First_Declarative_Item_Of
- (Project_Declaration, Tree, To => Decl_Item);
- Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
- Set_Name_Of (Attribute, Tree, To => Name_Source_Dirs);
- Set_Expression_Of (Attribute, Tree, To => Expression);
- Set_First_Term (Expression, Tree, To => Term);
- Source_Dirs_List :=
- Default_Project_Node
- (Of_Kind => N_Literal_String_List,
- In_Tree => Tree,
- And_Expr_Kind => List);
- Set_Current_Term (Term, Tree, To => Source_Dirs_List);
-
- -- Attach the comments, if any, that were saved for attribute
- -- Source_Dirs.
-
- Tree.Project_Nodes.Table (Attribute).Comments :=
- Source_Dirs_Comments;
- end;
-
- -- Put the source directories in attribute Source_Dirs
-
- for Source_Dir_Index in 1 .. Source_Directories.Last loop
- declare
- Expression : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Expression,
- In_Tree => Tree,
- And_Expr_Kind => Single);
-
- Term : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Term,
- In_Tree => Tree,
- And_Expr_Kind => Single);
-
- Value : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- In_Tree => Tree,
- And_Expr_Kind => Single);
-
- begin
- if No (Current_Source_Dir) then
- Set_First_Expression_In_List
- (Source_Dirs_List, Tree, To => Expression);
- else
- Set_Next_Expression_In_List
- (Current_Source_Dir, Tree, To => Expression);
- end if;
-
- Current_Source_Dir := Expression;
- Set_First_Term (Expression, Tree, To => Term);
- Set_Current_Term (Term, Tree, To => Value);
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (Source_Directories.Table (Source_Dir_Index).all);
- Set_String_Value_Of (Value, Tree, To => Name_Find);
- end;
- end loop;
-
- -- Add an attribute declaration for Source_Files or Source_List_File
- -- with the source list file name that will be created.
-
- declare
- Decl_Item : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Declarative_Item,
- In_Tree => Tree);
-
- Attribute : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Attribute_Declaration,
- In_Tree => Tree,
- And_Expr_Kind => Single);
-
- Expression : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Expression,
- In_Tree => Tree,
- And_Expr_Kind => Single);
-
- Term : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Term,
- In_Tree => Tree,
- And_Expr_Kind => Single);
-
- Value : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- In_Tree => Tree,
- And_Expr_Kind => Single);
-
- begin
- Set_Next_Declarative_Item
- (Decl_Item, Tree,
- To => First_Declarative_Item_Of (Project_Declaration, Tree));
- Set_First_Declarative_Item_Of
- (Project_Declaration, Tree, To => Decl_Item);
- Set_Current_Item_Node (Decl_Item, Tree, To => Attribute);
-
- Set_Name_Of (Attribute, Tree, To => Name_Source_List_File);
- Set_Expression_Of (Attribute, Tree, To => Expression);
- Set_First_Term (Expression, Tree, To => Term);
- Set_Current_Term (Term, Tree, To => Value);
- Name_Len := Source_List_Last;
- Name_Buffer (1 .. Name_Len) :=
- Source_List_Path (1 .. Source_List_Last);
- Set_String_Value_Of (Value, Tree, To => Name_Find);
-
- -- If there was no comments for attribute Source_List_File, put
- -- those for Source_Files, if they exist.
-
- if Present (Source_List_File_Comments) then
- Tree.Project_Nodes.Table (Attribute).Comments :=
- Source_List_File_Comments;
- else
- Tree.Project_Nodes.Table (Attribute).Comments :=
- Source_Files_Comments;
- end if;
- end;
-
- -- Put the sources in the source list files and in the naming
- -- project.
-
- for Source_Index in 1 .. Sources.Last loop
-
- -- Add the corresponding attribute in the
- -- Naming package of the naming project.
-
- declare
- Current_Source : constant Source :=
- Sources.Table (Source_Index);
-
- Decl_Item : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind =>
- N_Declarative_Item,
- In_Tree => Tree);
-
- Attribute : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind =>
- N_Attribute_Declaration,
- In_Tree => Tree);
-
- Expression : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Expression,
- And_Expr_Kind => Single,
- In_Tree => Tree);
-
- Term : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Term,
- And_Expr_Kind => Single,
- In_Tree => Tree);
-
- Value : constant Project_Node_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- And_Expr_Kind => Single,
- In_Tree => Tree);
-
- begin
- -- Add source file name to the source list file if it is not
- -- already there.
-
- if not Source_Files.Get (Current_Source.File_Name) then
- Source_Files.Set (Current_Source.File_Name, True);
- Get_Name_String (Current_Source.File_Name);
- Add_Char_To_Name_Buffer (ASCII.LF);
-
- if Write (Source_List_FD,
- Name_Buffer (1)'Address,
- Name_Len) /= Name_Len
- then
- Prj.Com.Fail ("disk full");
- end if;
- end if;
-
- -- For an Ada source, add entry in package Naming
-
- if Current_Source.Unit_Name /= No_Name then
- Set_Next_Declarative_Item
- (Decl_Item,
- To => First_Declarative_Item_Of
- (Naming_Package, Tree),
- In_Tree => Tree);
- Set_First_Declarative_Item_Of
- (Naming_Package,
- To => Decl_Item,
- In_Tree => Tree);
- Set_Current_Item_Node
- (Decl_Item,
- To => Attribute,
- In_Tree => Tree);
-
- -- Is it a spec or a body?
-
- if Current_Source.Spec then
- Set_Name_Of
- (Attribute, Tree,
- To => Name_Spec);
- else
- Set_Name_Of
- (Attribute, Tree,
- To => Name_Body);
- end if;
-
- -- Get the name of the unit
-
- Get_Name_String (Current_Source.Unit_Name);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Set_Associative_Array_Index_Of
- (Attribute, Tree, To => Name_Find);
-
- Set_Expression_Of
- (Attribute, Tree, To => Expression);
- Set_First_Term
- (Expression, Tree, To => Term);
- Set_Current_Term
- (Term, Tree, To => Value);
-
- -- And set the name of the file
-
- Set_String_Value_Of
- (Value, Tree, To => Current_Source.File_Name);
- Set_Source_Index_Of
- (Value, Tree, To => Current_Source.Index);
- end if;
- end;
- end loop;
-
- -- Close the source list file
-
- Close (Source_List_FD);
-
- -- Output the project file
-
- Prj.PP.Pretty_Print
- (Project_Node, Tree,
- W_Char => Write_A_Char'Access,
- W_Eol => Write_Eol'Access,
- W_Str => Write_A_String'Access,
- Backward_Compatibility => False,
- Max_Line_Length => 79);
- Close (Output_FD);
-
- -- Delete the naming project file if it already exists
-
- Delete_File
- (Project_Naming_File_Name (1 .. Project_Naming_Last),
- Success => Discard);
-
- -- Create a new one
-
- if Opt.Verbose_Mode then
- Output.Write_Str ("Creating new naming project file """);
- Output.Write_Str (Project_Naming_File_Name
- (1 .. Project_Naming_Last));
- Output.Write_Line ("""");
- end if;
-
- Output_FD := Create_New_File
- (Project_Naming_File_Name (1 .. Project_Naming_Last),
- Fmode => Text);
-
- -- Fails if naming project file cannot be created
-
- if Output_FD = Invalid_FD then
- Prj.Com.Fail
- ("cannot create new """
- & Project_Naming_File_Name (1 .. Project_Naming_Last)
- & """");
- end if;
-
- -- Output the naming project file
-
- Prj.PP.Pretty_Print
- (Project_Naming_Node, Tree,
- W_Char => Write_A_Char'Access,
- W_Eol => Write_Eol'Access,
- W_Str => Write_A_String'Access,
- Backward_Compatibility => False);
- Close (Output_FD);
-
- else
- -- For each Ada source, write a pragma Source_File_Name to the
- -- configuration pragmas file.
-
- for Index in 1 .. Sources.Last loop
- if Sources.Table (Index).Unit_Name /= No_Name then
- Write_A_String ("pragma Source_File_Name");
- Write_Eol;
- Write_A_String (" (");
- Write_A_String
- (Get_Name_String (Sources.Table (Index).Unit_Name));
- Write_A_String (",");
- Write_Eol;
-
- if Sources.Table (Index).Spec then
- Write_A_String (" Spec_File_Name => """);
-
- else
- Write_A_String (" Body_File_Name => """);
- end if;
-
- Write_A_String
- (Get_Name_String (Sources.Table (Index).File_Name));
-
- Write_A_String ("""");
-
- if Sources.Table (Index).Index /= 0 then
- Write_A_String (", Index =>");
- Write_A_String (Sources.Table (Index).Index'Img);
- end if;
-
- Write_A_String (");");
- Write_Eol;
- end if;
- end loop;
-
- Close (Output_FD);
- end if;
- end Finalize;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (File_Path : String;
- Project_File : Boolean;
- Preproc_Switches : Argument_List;
- Very_Verbose : Boolean;
- Flags : Processing_Flags)
- is
- begin
- Makr.Very_Verbose := Initialize.Very_Verbose;
- Makr.Project_File := Initialize.Project_File;
-
- -- Do some needed initializations
-
- Csets.Initialize;
- Snames.Initialize;
- Stringt.Initialize;
-
- Prj.Initialize (No_Project_Tree);
-
- Prj.Tree.Initialize (Root_Environment, Flags);
- Prj.Env.Initialize_Default_Project_Path
- (Root_Environment.Project_Path,
- Target_Name => Sdefault.Target_Name.all);
-
- Prj.Tree.Initialize (Tree);
-
- Sources.Set_Last (0);
- Source_Directories.Set_Last (0);
-
- -- Initialize the compiler switches
-
- Args := new Argument_List (1 .. Preproc_Switches'Length + 6);
- Args (1) := new String'("-c");
- Args (2) := new String'("-gnats");
- Args (3) := new String'("-gnatu");
- Args (4 .. 3 + Preproc_Switches'Length) := Preproc_Switches;
- Args (4 + Preproc_Switches'Length) := new String'("-x");
- Args (5 + Preproc_Switches'Length) := new String'("ada");
-
- -- Get the path and file names
-
- Path_Name := new
- String (1 .. File_Path'Length + Project_File_Extension'Length);
- Path_Last := File_Path'Length;
-
- if File_Names_Case_Sensitive then
- Path_Name (1 .. Path_Last) := File_Path;
- else
- Path_Name (1 .. Path_Last) := To_Lower (File_Path);
- end if;
-
- Path_Name (Path_Last + 1 .. Path_Name'Last) :=
- Project_File_Extension;
-
- -- Get the end of directory information, if any
-
- for Index in reverse 1 .. Path_Last loop
- if Path_Name (Index) = Directory_Separator then
- Directory_Last := Index;
- exit;
- end if;
- end loop;
-
- if Project_File then
- if Path_Last < Project_File_Extension'Length + 1
- or else Path_Name
- (Path_Last - Project_File_Extension'Length + 1 .. Path_Last)
- /= Project_File_Extension
- then
- Path_Last := Path_Name'Last;
- end if;
-
- Output_Name := new String'(To_Lower (Path_Name (1 .. Path_Last)));
- Output_Name_Last := Output_Name'Last - 4;
-
- -- If there is already a project file with the specified name, parse
- -- it to get the components that are not automatically generated.
-
- if Is_Regular_File (Output_Name (1 .. Path_Last)) then
- if Opt.Verbose_Mode then
- Output.Write_Str ("Parsing already existing project file """);
- Output.Write_Str (Output_Name.all);
- Output.Write_Line ("""");
- end if;
-
- Part.Parse
- (In_Tree => Tree,
- Project => Project_Node,
- Project_File_Name => Output_Name.all,
- Errout_Handling => Part.Finalize_If_Error,
- Store_Comments => True,
- Is_Config_File => False,
- Env => Root_Environment,
- Current_Directory => Get_Current_Dir,
- Packages_To_Check => Packages_To_Check_By_Gnatname);
-
- -- Fail if parsing was not successful
-
- if No (Project_Node) then
- Prj.Com.Fail ("parsing of existing project file failed");
-
- elsif Project_Qualifier_Of (Project_Node, Tree) = Aggregate then
- Prj.Com.Fail ("aggregate projects are not supported");
-
- elsif Project_Qualifier_Of (Project_Node, Tree) =
- Aggregate_Library
- then
- Prj.Com.Fail ("aggregate library projects are not supported");
-
- else
- -- If parsing was successful, remove the components that are
- -- automatically generated, if any, so that they will be
- -- unconditionally added later.
-
- -- Remove the with clause for the naming project file
-
- declare
- With_Clause : Project_Node_Id :=
- First_With_Clause_Of (Project_Node, Tree);
- Previous : Project_Node_Id := Empty_Node;
-
- begin
- while Present (With_Clause) loop
- if Prj.Tree.Name_Of (With_Clause, Tree) =
- Project_Naming_Id
- then
- if No (Previous) then
- Set_First_With_Clause_Of
- (Project_Node, Tree,
- To => Next_With_Clause_Of (With_Clause, Tree));
- else
- Set_Next_With_Clause_Of
- (Previous, Tree,
- To => Next_With_Clause_Of (With_Clause, Tree));
- end if;
-
- exit;
- end if;
-
- Previous := With_Clause;
- With_Clause := Next_With_Clause_Of (With_Clause, Tree);
- end loop;
- end;
-
- -- Remove attribute declarations of Source_Files,
- -- Source_List_File, Source_Dirs, and the declaration of
- -- package Naming, if they exist, but preserve the comments
- -- attached to these nodes.
-
- declare
- Declaration : Project_Node_Id :=
- First_Declarative_Item_Of
- (Project_Declaration_Of
- (Project_Node, Tree),
- Tree);
- Previous : Project_Node_Id := Empty_Node;
- Current_Node : Project_Node_Id := Empty_Node;
-
- Name : Name_Id;
- Kind_Of_Node : Project_Node_Kind;
- Comments : Project_Node_Id;
-
- begin
- while Present (Declaration) loop
- Current_Node := Current_Item_Node (Declaration, Tree);
-
- Kind_Of_Node := Kind_Of (Current_Node, Tree);
-
- if Kind_Of_Node = N_Attribute_Declaration or else
- Kind_Of_Node = N_Package_Declaration
- then
- Name := Prj.Tree.Name_Of (Current_Node, Tree);
-
- if Nam_In (Name, Name_Source_Files,
- Name_Source_List_File,
- Name_Source_Dirs,
- Name_Naming)
- then
- Comments :=
- Tree.Project_Nodes.Table (Current_Node).Comments;
-
- if Name = Name_Source_Files then
- Source_Files_Comments := Comments;
-
- elsif Name = Name_Source_List_File then
- Source_List_File_Comments := Comments;
-
- elsif Name = Name_Source_Dirs then
- Source_Dirs_Comments := Comments;
-
- elsif Name = Name_Naming then
- Naming_Package_Comments := Comments;
- end if;
-
- if No (Previous) then
- Set_First_Declarative_Item_Of
- (Project_Declaration_Of (Project_Node, Tree),
- Tree,
- To => Next_Declarative_Item
- (Declaration, Tree));
-
- else
- Set_Next_Declarative_Item
- (Previous, Tree,
- To => Next_Declarative_Item
- (Declaration, Tree));
- end if;
-
- else
- Previous := Declaration;
- end if;
- end if;
-
- Declaration := Next_Declarative_Item (Declaration, Tree);
- end loop;
- end;
- end if;
- end if;
-
- if Directory_Last /= 0 then
- Output_Name (1 .. Output_Name_Last - Directory_Last) :=
- Output_Name (Directory_Last + 1 .. Output_Name_Last);
- Output_Name_Last := Output_Name_Last - Directory_Last;
- end if;
-
- -- Get the project name id
-
- Name_Len := Output_Name_Last;
- Name_Buffer (1 .. Name_Len) := Output_Name (1 .. Name_Len);
- Output_Name_Id := Name_Find;
-
- -- Create the project naming file name
-
- Project_Naming_Last := Output_Name_Last;
- Project_Naming_File_Name :=
- new String'(Output_Name (1 .. Output_Name_Last) &
- Naming_File_Suffix &
- Project_File_Extension);
- Project_Naming_Last :=
- Project_Naming_Last + Naming_File_Suffix'Length;
-
- -- Get the project naming id
-
- Name_Len := Project_Naming_Last;
- Name_Buffer (1 .. Name_Len) :=
- Project_Naming_File_Name (1 .. Name_Len);
- Project_Naming_Id := Name_Find;
-
- Project_Naming_Last :=
- Project_Naming_Last + Project_File_Extension'Length;
-
- -- Create the source list file name
-
- Source_List_Last := Output_Name_Last;
- Source_List_Path :=
- new String'(Output_Name (1 .. Output_Name_Last) &
- Source_List_File_Suffix);
- Source_List_Last :=
- Output_Name_Last + Source_List_File_Suffix'Length;
-
- -- Add the project file extension to the project name
-
- Output_Name
- (Output_Name_Last + 1 ..
- Output_Name_Last + Project_File_Extension'Length) :=
- Project_File_Extension;
- Output_Name_Last := Output_Name_Last + Project_File_Extension'Length;
-
- -- Back up project file if it already exists
-
- if not Opt.No_Backup
- and then Is_Regular_File (Path_Name (1 .. Path_Last))
- then
- declare
- Discard : Boolean;
- Saved_Path : constant String :=
- Path_Name (1 .. Path_Last) & ".saved_";
- Nmb : Natural;
-
- begin
- Nmb := 0;
- loop
- declare
- Img : constant String := Nmb'Img;
-
- begin
- if not Is_Regular_File
- (Saved_Path & Img (2 .. Img'Last))
- then
- Copy_File
- (Name => Path_Name (1 .. Path_Last),
- Pathname => Saved_Path & Img (2 .. Img'Last),
- Mode => Overwrite,
- Success => Discard);
- exit;
- end if;
-
- Nmb := Nmb + 1;
- end;
- end loop;
- end;
- end if;
- end if;
-
- -- Change the current directory to the directory of the project file,
- -- if any directory information is specified.
-
- if Directory_Last /= 0 then
- begin
- Change_Dir (Path_Name (1 .. Directory_Last));
- exception
- when Directory_Error =>
- Prj.Com.Fail
- ("unknown directory """
- & Path_Name (1 .. Directory_Last)
- & """");
- end;
- end if;
- end Initialize;
-
- -------------
- -- Process --
- -------------
-
- procedure Process
- (Directories : Argument_List;
- Name_Patterns : Regexp_List;
- Excluded_Patterns : Regexp_List;
- Foreign_Patterns : Regexp_List)
- is
- procedure Process_Directory (Dir_Name : String; Recursively : Boolean);
- -- Look for Ada and foreign sources in a directory, according to the
- -- patterns. When Recursively is True, after looking for sources in
- -- Dir_Name, look also in its subdirectories, if any.
-
- -----------------------
- -- Process_Directory --
- -----------------------
-
- procedure Process_Directory (Dir_Name : String; Recursively : Boolean) is
- Matched : Matched_Type := False;
- Str : String (1 .. 2_000);
- Canon : String (1 .. 2_000);
- Last : Natural;
- Dir : Dir_Type;
- Do_Process : Boolean := True;
-
- Temp_File_Name : String_Access := null;
- Save_Last_Source_Index : Natural := 0;
- File_Name_Id : Name_Id := No_Name;
-
- Current_Source : Source;
-
- begin
- -- Avoid processing the same directory more than once
-
- for Index in 1 .. Processed_Directories.Last loop
- if Processed_Directories.Table (Index).all = Dir_Name then
- Do_Process := False;
- exit;
- end if;
- end loop;
-
- if Do_Process then
- if Opt.Verbose_Mode then
- Output.Write_Str ("Processing directory """);
- Output.Write_Str (Dir_Name);
- Output.Write_Line ("""");
- end if;
-
- Processed_Directories. Increment_Last;
- Processed_Directories.Table (Processed_Directories.Last) :=
- new String'(Dir_Name);
-
- -- Get the source file names from the directory. Fails if the
- -- directory does not exist.
-
- begin
- Open (Dir, Dir_Name);
- exception
- when Directory_Error =>
- Prj.Com.Fail ("cannot open directory """ & Dir_Name & """");
- end;
-
- -- Process each regular file in the directory
-
- File_Loop : loop
- Read (Dir, Str, Last);
- exit File_Loop when Last = 0;
-
- -- Copy the file name and put it in canonical case to match
- -- against the patterns that have themselves already been put
- -- in canonical case.
-
- Canon (1 .. Last) := Str (1 .. Last);
- Canonical_Case_File_Name (Canon (1 .. Last));
-
- if Is_Regular_File
- (Dir_Name & Directory_Separator & Str (1 .. Last))
- then
- Matched := True;
-
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) := Str (1 .. Last);
- File_Name_Id := Name_Find;
-
- -- First, check if the file name matches at least one of
- -- the excluded expressions;
-
- for Index in Excluded_Patterns'Range loop
- if
- Match (Canon (1 .. Last), Excluded_Patterns (Index))
- then
- Matched := Excluded;
- exit;
- end if;
- end loop;
-
- -- If it does not match any of the excluded expressions,
- -- check if the file name matches at least one of the
- -- regular expressions.
-
- if Matched = True then
- Matched := False;
-
- for Index in Name_Patterns'Range loop
- if
- Match
- (Canon (1 .. Last), Name_Patterns (Index))
- then
- Matched := True;
- exit;
- end if;
- end loop;
- end if;
-
- if Very_Verbose
- or else (Matched = True and then Opt.Verbose_Mode)
- then
- Output.Write_Str (" Checking """);
- Output.Write_Str (Str (1 .. Last));
- Output.Write_Line (""": ");
- end if;
-
- -- If the file name matches one of the regular expressions,
- -- parse it to get its unit name.
-
- if Matched = True then
- declare
- FD : File_Descriptor;
- Success : Boolean;
- Saved_Output : File_Descriptor;
- Saved_Error : File_Descriptor;
- Tmp_File : Path_Name_Type;
-
- begin
- -- If we don't have the path of the compiler yet,
- -- get it now. The compiler name may have a prefix,
- -- so we get the potentially prefixed name.
-
- if Gcc_Path = null then
- declare
- Prefix_Gcc : String_Access :=
- Program_Name (Gcc, "gnatname");
- begin
- Gcc_Path :=
- Locate_Exec_On_Path (Prefix_Gcc.all);
- Free (Prefix_Gcc);
- end;
-
- if Gcc_Path = null then
- Prj.Com.Fail ("could not locate " & Gcc);
- end if;
- end if;
-
- -- Create the temporary file
-
- Tempdir.Create_Temp_File (FD, Tmp_File);
-
- if FD = Invalid_FD then
- Prj.Com.Fail
- ("could not create temporary file");
-
- else
- Temp_File_Name :=
- new String'(Get_Name_String (Tmp_File));
- end if;
-
- Args (Args'Last) :=
- new String'
- (Dir_Name & Directory_Separator & Str (1 .. Last));
-
- -- Save the standard output and error
-
- Saved_Output := Dup (Standout);
- Saved_Error := Dup (Standerr);
-
- -- Set standard output and error to the temporary file
-
- Dup2 (FD, Standout);
- Dup2 (FD, Standerr);
-
- -- And spawn the compiler
-
- Spawn (Gcc_Path.all, Args.all, Success);
-
- -- Restore the standard output and error
-
- Dup2 (Saved_Output, Standout);
- Dup2 (Saved_Error, Standerr);
-
- -- Close the temporary file
-
- Close (FD);
-
- -- And close the saved standard output and error to
- -- avoid too many file descriptors.
-
- Close (Saved_Output);
- Close (Saved_Error);
-
- -- Now that standard output is restored, check if
- -- the compiler ran correctly.
-
- -- Read the lines of the temporary file:
- -- they should contain the kind and name of the unit.
-
- declare
- File : Text_File;
- Text_Line : String (1 .. 1_000);
- Text_Last : Natural;
-
- begin
- Open (File, Temp_File_Name.all);
-
- if not Is_Valid (File) then
- Prj.Com.Fail
- ("could not read temporary file " &
- Temp_File_Name.all);
- end if;
-
- Save_Last_Source_Index := Sources.Last;
-
- if End_Of_File (File) then
- if Opt.Verbose_Mode then
- if not Success then
- Output.Write_Str (" (process died) ");
- end if;
- end if;
-
- else
- Line_Loop : while not End_Of_File (File) loop
- Get_Line (File, Text_Line, Text_Last);
-
- -- Find the first closing parenthesis
-
- Char_Loop : for J in 1 .. Text_Last loop
- if Text_Line (J) = ')' then
- if J >= 13 and then
- Text_Line (1 .. 4) = "Unit"
- then
- -- Add entry to Sources table
-
- Name_Len := J - 12;
- Name_Buffer (1 .. Name_Len) :=
- Text_Line (6 .. J - 7);
- Current_Source :=
- (Unit_Name => Name_Find,
- File_Name => File_Name_Id,
- Index => 0,
- Spec => Text_Line (J - 5 .. J) =
- "(spec)");
-
- Sources.Append (Current_Source);
- end if;
-
- exit Char_Loop;
- end if;
- end loop Char_Loop;
- end loop Line_Loop;
- end if;
-
- if Save_Last_Source_Index = Sources.Last then
- if Opt.Verbose_Mode then
- Output.Write_Line (" not a unit");
- end if;
-
- else
- if Sources.Last >
- Save_Last_Source_Index + 1
- then
- for Index in Save_Last_Source_Index + 1 ..
- Sources.Last
- loop
- Sources.Table (Index).Index :=
- Int (Index - Save_Last_Source_Index);
- end loop;
- end if;
-
- for Index in Save_Last_Source_Index + 1 ..
- Sources.Last
- loop
- Current_Source := Sources.Table (Index);
-
- if Opt.Verbose_Mode then
- if Current_Source.Spec then
- Output.Write_Str (" spec of ");
-
- else
- Output.Write_Str (" body of ");
- end if;
-
- Output.Write_Line
- (Get_Name_String
- (Current_Source.Unit_Name));
- end if;
- end loop;
- end if;
-
- Close (File);
-
- Delete_File (Temp_File_Name.all, Success);
- end;
- end;
-
- -- File name matches none of the regular expressions
-
- else
- -- If file is not excluded, see if this is foreign source
-
- if Matched /= Excluded then
- for Index in Foreign_Patterns'Range loop
- if Match (Canon (1 .. Last),
- Foreign_Patterns (Index))
- then
- Matched := True;
- exit;
- end if;
- end loop;
- end if;
-
- if Very_Verbose then
- case Matched is
- when False =>
- Output.Write_Line ("no match");
-
- when Excluded =>
- Output.Write_Line ("excluded");
-
- when True =>
- Output.Write_Line ("foreign source");
- end case;
- end if;
-
- if Matched = True then
-
- -- Add source file name without unit name
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Canon (1 .. Last));
- Sources.Append
- ((File_Name => Name_Find,
- Unit_Name => No_Name,
- Index => 0,
- Spec => False));
- end if;
- end if;
- end if;
- end loop File_Loop;
-
- Close (Dir);
- end if;
-
- -- If Recursively is True, call itself for each subdirectory.
- -- We do that, even when this directory has already been processed,
- -- because all of its subdirectories may not have been processed.
-
- if Recursively then
- Open (Dir, Dir_Name);
-
- loop
- Read (Dir, Str, Last);
- exit when Last = 0;
-
- -- Do not call itself for "." or ".."
-
- if Is_Directory
- (Dir_Name & Directory_Separator & Str (1 .. Last))
- and then Str (1 .. Last) /= "."
- and then Str (1 .. Last) /= ".."
- then
- Process_Directory
- (Dir_Name & Directory_Separator & Str (1 .. Last),
- Recursively => True);
- end if;
- end loop;
-
- Close (Dir);
- end if;
- end Process_Directory;
-
- -- Start of processing for Process
-
- begin
- Processed_Directories.Set_Last (0);
-
- -- Process each directory
-
- for Index in Directories'Range loop
-
- declare
- Dir_Name : constant String := Directories (Index).all;
- Last : Natural := Dir_Name'Last;
- Recursively : Boolean := False;
- Found : Boolean;
- Canonical : String (1 .. Dir_Name'Length) := Dir_Name;
-
- begin
- Canonical_Case_File_Name (Canonical);
-
- Found := False;
- for J in 1 .. Source_Directories.Last loop
- if Source_Directories.Table (J).all = Canonical then
- Found := True;
- exit;
- end if;
- end loop;
-
- if not Found then
- Source_Directories.Append (new String'(Canonical));
- end if;
-
- if Dir_Name'Length >= 4
- and then (Dir_Name (Last - 2 .. Last) = "/**")
- then
- Last := Last - 3;
- Recursively := True;
- end if;
-
- Process_Directory (Dir_Name (Dir_Name'First .. Last), Recursively);
- end;
-
- end loop;
- end Process;
-
- ----------------
- -- Write_Char --
- ----------------
- procedure Write_A_Char (C : Character) is
- begin
- Write_A_String ((1 => C));
- end Write_A_Char;
-
- ---------------
- -- Write_Eol --
- ---------------
-
- procedure Write_Eol is
- begin
- Write_A_String ((1 => ASCII.LF));
- end Write_Eol;
-
- --------------------
- -- Write_A_String --
- --------------------
-
- procedure Write_A_String (S : String) is
- Str : String (1 .. S'Length);
-
- begin
- if S'Length > 0 then
- Str := S;
-
- if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length then
- Prj.Com.Fail ("disk full");
- end if;
- end if;
- end Write_A_String;
-
-end Prj.Makr;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . M A K R --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Support for procedure Gnatname
-
--- For arbitrary naming schemes, create or update a project file, or create a
--- configuration pragmas file.
-
-with System.Regexp; use System.Regexp;
-
-package Prj.Makr is
-
- procedure Initialize
- (File_Path : String;
- Project_File : Boolean;
- Preproc_Switches : Argument_List;
- Very_Verbose : Boolean;
- Flags : Processing_Flags);
- -- Start the creation of a configuration pragmas file or the creation or
- -- modification of a project file, for gnatname.
- --
- -- When Project_File is False, File_Path is the name of a configuration
- -- pragmas file to create. When Project_File is True, File_Path is the name
- -- of a project file to create if it does not exist or to modify if it
- -- already exists.
- --
- -- Preproc_Switches is a list of switches to be used when invoking the
- -- compiler to get the name and kind of unit of a source file.
- --
- -- Very_Verbose controls the verbosity of the output, in conjunction with
- -- Opt.Verbose_Mode.
-
- type Regexp_List is array (Positive range <>) of Regexp;
-
- procedure Process
- (Directories : Argument_List;
- Name_Patterns : Regexp_List;
- Excluded_Patterns : Regexp_List;
- Foreign_Patterns : Regexp_List);
- -- Look for source files in the specified directories, with the specified
- -- patterns.
- --
- -- Directories is the list of source directories where to look for sources.
- --
- -- Name_Patterns is a potentially empty list of file name patterns to check
- -- for Ada Sources.
- --
- -- Excluded_Patterns is a potentially empty list of file name patterns that
- -- should not be checked for Ada or non Ada sources.
- --
- -- Foreign_Patterns is a potentially empty list of file name patterns to
- -- check for non Ada sources.
- --
- -- At least one of Name_Patterns and Foreign_Patterns is not empty
- --
- -- Note that this procedure currently assumes that it is only used by
- -- gnatname. If other processes start using it, then an additional
- -- parameter would need to be added, and call to Osint.Program_Name
- -- updated accordingly in the body.
-
- procedure Finalize;
- -- Write the configuration pragmas file or the project file indicated in a
- -- call to procedure Initialize, after one or several calls to procedure
- -- Process.
-
-end Prj.Makr;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . N M S C --
--- --
--- B o d y --
--- --
--- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Err_Vars; use Err_Vars;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Com;
-with Prj.Env; use Prj.Env;
-with Prj.Err; use Prj.Err;
-with Prj.Tree; use Prj.Tree;
-with Prj.Util; use Prj.Util;
-with Sinput.P;
-with Snames; use Snames;
-
-with Ada; use Ada;
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Directories; use Ada.Directories;
-with Ada.Strings; use Ada.Strings;
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.Dynamic_HTables;
-with GNAT.Regexp; use GNAT.Regexp;
-with GNAT.Table;
-
-package body Prj.Nmsc is
-
- No_Continuation_String : aliased String := "";
- Continuation_String : aliased String := "\";
- -- Used in Check_Library for continuation error messages at the same
- -- location.
-
- type Name_Location is record
- Name : File_Name_Type;
- -- Key is duplicated, so that it is known when using functions Get_First
- -- and Get_Next, as these functions only return an Element.
-
- Location : Source_Ptr;
- Source : Source_Id := No_Source;
- Listed : Boolean := False;
- Found : Boolean := False;
- end record;
-
- No_Name_Location : constant Name_Location :=
- (Name => No_File,
- Location => No_Location,
- Source => No_Source,
- Listed => False,
- Found => False);
-
- package Source_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => Name_Location,
- No_Element => No_Name_Location,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- File name information found in string list attribute (Source_Files or
- -- Source_List_File). Used to check that all referenced files were indeed
- -- found on the disk.
-
- type Unit_Exception is record
- Name : Name_Id;
- -- Key is duplicated, so that it is known when using functions Get_First
- -- and Get_Next, as these functions only return an Element.
-
- Spec : File_Name_Type;
- Impl : File_Name_Type;
- end record;
-
- No_Unit_Exception : constant Unit_Exception := (No_Name, No_File, No_File);
-
- package Unit_Exceptions_Htable is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => Unit_Exception,
- No_Element => No_Unit_Exception,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
- -- Record special naming schemes for Ada units (name of spec file and name
- -- of implementation file). The elements in this list come from the naming
- -- exceptions specified in the project files.
-
- type File_Found is record
- File : File_Name_Type := No_File;
- Excl_File : File_Name_Type := No_File;
- Excl_Line : Natural := 0;
- Found : Boolean := False;
- Location : Source_Ptr := No_Location;
- end record;
-
- No_File_Found : constant File_Found :=
- (No_File, No_File, 0, False, No_Location);
-
- package Excluded_Sources_Htable is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => File_Found,
- No_Element => No_File_Found,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- A hash table to store the base names of excluded files, if any
-
- package Object_File_Names_Htable is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => Source_Id,
- No_Element => No_Source,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- A hash table to store the object file names for a project, to check that
- -- two different sources have different object file names.
-
- type Project_Processing_Data is record
- Project : Project_Id;
- Source_Names : Source_Names_Htable.Instance;
- Unit_Exceptions : Unit_Exceptions_Htable.Instance;
- Excluded : Excluded_Sources_Htable.Instance;
-
- Source_List_File_Location : Source_Ptr;
- -- Location of the Source_List_File attribute, for error messages
- end record;
- -- This is similar to Tree_Processing_Data, but contains project-specific
- -- information which is only useful while processing the project, and can
- -- be discarded as soon as we have finished processing the project
-
- type Tree_Processing_Data is record
- Tree : Project_Tree_Ref;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Prj.Processing_Flags;
- In_Aggregate_Lib : Boolean;
- end record;
- -- Temporary data which is needed while parsing a project. It does not need
- -- to be kept in memory once a project has been fully loaded, but is
- -- necessary while performing consistency checks (duplicate sources,...)
- -- This data must be initialized before processing any project, and the
- -- same data is used for processing all projects in the tree.
-
- type Lib_Data is record
- Name : Name_Id;
- Proj : Project_Id;
- Tree : Project_Tree_Ref;
- end record;
-
- package Lib_Data_Table is new GNAT.Table
- (Table_Component_Type => Lib_Data,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100);
- -- A table to record library names in order to check that two library
- -- projects do not have the same library names.
-
- procedure Initialize
- (Data : out Tree_Processing_Data;
- Tree : Project_Tree_Ref;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Prj.Processing_Flags);
- -- Initialize Data
-
- procedure Free (Data : in out Tree_Processing_Data);
- -- Free the memory occupied by Data
-
- procedure Initialize
- (Data : in out Project_Processing_Data;
- Project : Project_Id);
- procedure Free (Data : in out Project_Processing_Data);
- -- Initialize or free memory for a project-specific data
-
- procedure Find_Excluded_Sources
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data);
- -- Find the list of files that should not be considered as source files
- -- for this project. Sets the list in the Project.Excluded_Sources_Htable.
-
- procedure Override_Kind (Source : Source_Id; Kind : Source_Kind);
- -- Override the reference kind for a source file. This properly updates
- -- the unit data if necessary.
-
- procedure Load_Naming_Exceptions
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data);
- -- All source files in Data.First_Source are considered as naming
- -- exceptions, and copied into the Source_Names and Unit_Exceptions tables
- -- as appropriate.
-
- type Search_Type is (Search_Files, Search_Directories);
-
- generic
- with procedure Callback
- (Path : Path_Information;
- Pattern_Index : Natural);
- procedure Expand_Subdirectory_Pattern
- (Project : Project_Id;
- Data : in out Tree_Processing_Data;
- Patterns : String_List_Id;
- Ignore : String_List_Id;
- Search_For : Search_Type;
- Resolve_Links : Boolean);
- -- Search the subdirectories of Project's directory for files or
- -- directories that match the globbing patterns found in Patterns (for
- -- instance "**/*.adb"). Typically, Patterns will be the value of the
- -- Source_Dirs or Excluded_Source_Dirs attributes.
- --
- -- Every time such a file or directory is found, the callback is called.
- -- Resolve_Links indicates whether we should resolve links while
- -- normalizing names.
- --
- -- In the callback, Pattern_Index is the index within Patterns where the
- -- expanded pattern was found (1 for the first element of Patterns and
- -- all its matching directories, then 2,...).
- --
- -- We use a generic and not an access-to-subprogram because in some cases
- -- this code is compiled with the restriction No_Implicit_Dynamic_Code.
- -- An error message is raised if a pattern does not match any file.
-
- procedure Add_Source
- (Id : out Source_Id;
- Data : in out Tree_Processing_Data;
- Project : Project_Id;
- Source_Dir_Rank : Natural;
- Lang_Id : Language_Ptr;
- Kind : Source_Kind;
- File_Name : File_Name_Type;
- Display_File : File_Name_Type;
- Naming_Exception : Naming_Exception_Type := No;
- Path : Path_Information := No_Path_Information;
- Alternate_Languages : Language_List := null;
- Unit : Name_Id := No_Name;
- Index : Int := 0;
- Locally_Removed : Boolean := False;
- Location : Source_Ptr := No_Location);
- -- Add a new source to the different lists: list of all sources in the
- -- project tree, list of source of a project and list of sources of a
- -- language. If Path is specified, the file is also added to
- -- Source_Paths_HT. Location is used for error messages
-
- function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type;
- -- Same as Osint.Canonical_Case_File_Name but applies to Name_Id.
- -- This alters Name_Buffer.
-
- function Suffix_Matches
- (Filename : String;
- Suffix : File_Name_Type) return Boolean;
- -- True if the file name ends with the given suffix. Always returns False
- -- if Suffix is No_Name.
-
- procedure Replace_Into_Name_Buffer
- (Str : String;
- Pattern : String;
- Replacement : Character);
- -- Copy Str into Name_Buffer, replacing Pattern with Replacement. Str is
- -- converted to lower-case at the same time.
-
- procedure Check_Abstract_Project
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Check abstract projects attributes
-
- procedure Check_Configuration
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Check the configuration attributes for the project
-
- procedure Check_If_Externally_Built
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Check attribute Externally_Built of project Project in project tree
- -- Data.Tree and modify its data Data if it has the value "true".
-
- procedure Check_Interfaces
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- If a list of sources is specified in attribute Interfaces, set
- -- In_Interfaces only for the sources specified in the list.
-
- procedure Check_Library_Attributes
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Check the library attributes of project Project in project tree
- -- and modify its data Data accordingly.
-
- procedure Check_Package_Naming
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Check the naming scheme part of Data, and initialize the naming scheme
- -- data in the config of the various languages.
-
- procedure Check_Programming_Languages
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Check attribute Languages for the project with data Data in project
- -- tree Data.Tree and set the components of Data for all the programming
- -- languages indicated in attribute Languages, if any.
-
- procedure Check_Stand_Alone_Library
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Check if project Project in project tree Data.Tree is a Stand-Alone
- -- Library project, and modify its data Data accordingly if it is one.
-
- procedure Check_Unit_Name (Name : String; Unit : out Name_Id);
- -- Check that a name is a valid unit name
-
- function Compute_Directory_Last (Dir : String) return Natural;
- -- Return the index of the last significant character in Dir. This is used
- -- to avoid duplicate '/' (slash) characters at the end of directory names.
-
- procedure Search_Directories
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data;
- For_All_Sources : Boolean);
- -- Search the source directories to find the sources. If For_All_Sources is
- -- True, check each regular file name against the naming schemes of the
- -- various languages. Otherwise consider only the file names in hash table
- -- Source_Names. If Allow_Duplicate_Basenames then files with identical
- -- base names are permitted within a project for source-based languages
- -- (never for unit based languages).
-
- procedure Check_File
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data;
- Source_Dir_Rank : Natural;
- Path : Path_Name_Type;
- Display_Path : Path_Name_Type;
- File_Name : File_Name_Type;
- Display_File_Name : File_Name_Type;
- Locally_Removed : Boolean;
- For_All_Sources : Boolean);
- -- Check if file File_Name is a valid source of the project. This is used
- -- in multi-language mode only. When the file matches one of the naming
- -- schemes, it is added to various htables through Add_Source and to
- -- Source_Paths_Htable.
- --
- -- File_Name is the same as Display_File_Name, but has been normalized.
- -- They do not include the directory information.
- --
- -- Path and Display_Path on the other hand are the full path to the file.
- -- Path must have been normalized (canonical casing and possibly links
- -- resolved).
- --
- -- Source_Directory is the directory in which the file was found. It is
- -- neither normalized nor has had links resolved, and must not end with a
- -- a directory separator, to avoid duplicates later on.
- --
- -- If For_All_Sources is True, then all possible file names are analyzed
- -- otherwise only those currently set in the Source_Names hash table.
-
- procedure Check_File_Naming_Schemes
- (Project : Project_Processing_Data;
- File_Name : File_Name_Type;
- Alternate_Languages : out Language_List;
- Language : out Language_Ptr;
- Display_Language_Name : out Name_Id;
- Unit : out Name_Id;
- Lang_Kind : out Language_Kind;
- Kind : out Source_Kind);
- -- Check if the file name File_Name conforms to one of the naming schemes
- -- of the project. If the file does not match one of the naming schemes,
- -- set Language to No_Language_Index. Filename is the name of the file
- -- being investigated. It has been normalized (case-folded). File_Name is
- -- the same value.
-
- procedure Get_Directories
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Get the object directory, the exec directory and the source directories
- -- of a project.
-
- procedure Get_Mains
- (Project : Project_Id;
- Data : in out Tree_Processing_Data);
- -- Get the mains of a project from attribute Main, if it exists, and put
- -- them in the project data.
-
- procedure Get_Sources_From_File
- (Path : String;
- Location : Source_Ptr;
- Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data);
- -- Get the list of sources from a text file and put them in hash table
- -- Source_Names.
-
- procedure Find_Sources
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data);
- -- Process the Source_Files and Source_List_File attributes, and store the
- -- list of source files into the Source_Names htable. When these attributes
- -- are not defined, find all files matching the naming schemes in the
- -- source directories. If Allow_Duplicate_Basenames, then files with the
- -- same base names are authorized within a project for source-based
- -- languages (never for unit based languages)
-
- procedure Compute_Unit_Name
- (File_Name : File_Name_Type;
- Naming : Lang_Naming_Data;
- Kind : out Source_Kind;
- Unit : out Name_Id;
- Project : Project_Processing_Data);
- -- Check whether the file matches the naming scheme. If it does,
- -- compute its unit name. If Unit is set to No_Name on exit, none of the
- -- other out parameters are relevant.
-
- procedure Check_Illegal_Suffix
- (Project : Project_Id;
- Suffix : File_Name_Type;
- Dot_Replacement : File_Name_Type;
- Attribute_Name : String;
- Location : Source_Ptr;
- Data : in out Tree_Processing_Data);
- -- Display an error message if the given suffix is illegal for some reason.
- -- The name of the attribute we are testing is specified in Attribute_Name,
- -- which is used in the error message. Location is the location where the
- -- suffix is defined.
-
- procedure Locate_Directory
- (Project : Project_Id;
- Name : File_Name_Type;
- Path : out Path_Information;
- Dir_Exists : out Boolean;
- Data : in out Tree_Processing_Data;
- Create : String := "";
- Location : Source_Ptr := No_Location;
- Must_Exist : Boolean := True;
- Externally_Built : Boolean := False);
- -- Locate a directory. Name is the directory name. Relative paths are
- -- resolved relative to the project's directory. If the directory does not
- -- exist and Setup_Projects is True and Create is a non null string, an
- -- attempt is made to create the directory. If the directory does not
- -- exist, it is either created if Setup_Projects is False (and then
- -- returned), or simply returned without checking for its existence (if
- -- Must_Exist is False) or No_Path_Information is returned. In all cases,
- -- Dir_Exists indicates whether the directory now exists. Create is also
- -- used for debugging traces to show which path we are computing.
-
- procedure Look_For_Sources
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data);
- -- Find all the sources of project Project in project tree Data.Tree and
- -- update its Data accordingly. This assumes that the special naming
- -- exceptions have already been processed.
-
- function Path_Name_Of
- (File_Name : File_Name_Type;
- Directory : Path_Name_Type) return String;
- -- Returns the path name of a (non project) file. Returns an empty string
- -- if file cannot be found.
-
- procedure Remove_Source
- (Tree : Project_Tree_Ref;
- Id : Source_Id;
- Replaced_By : Source_Id);
- -- Remove a file from the list of sources of a project. This might be
- -- because the file is replaced by another one in an extending project,
- -- or because a file was added as a naming exception but was not found
- -- in the end.
-
- procedure Report_No_Sources
- (Project : Project_Id;
- Lang_Name : String;
- Data : Tree_Processing_Data;
- Location : Source_Ptr;
- Continuation : Boolean := False);
- -- Report an error or a warning depending on the value of When_No_Sources
- -- when there are no sources for language Lang_Name.
-
- procedure Show_Source_Dirs
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access);
- -- List all the source directories of a project
-
- procedure Write_Attr (Name, Value : String);
- -- Debug print a value for a specific property. Does nothing when not in
- -- debug mode
-
- procedure Error_Or_Warning
- (Flags : Processing_Flags;
- Kind : Error_Warning;
- Msg : String;
- Location : Source_Ptr;
- Project : Project_Id);
- -- Emits either an error or warning message (or nothing), depending on Kind
-
- function No_Space_Img (N : Natural) return String;
- -- Image of a Natural without the initial space
-
- ----------------------
- -- Error_Or_Warning --
- ----------------------
-
- procedure Error_Or_Warning
- (Flags : Processing_Flags;
- Kind : Error_Warning;
- Msg : String;
- Location : Source_Ptr;
- Project : Project_Id) is
- begin
- case Kind is
- when Error => Error_Msg (Flags, Msg, Location, Project);
- when Warning => Error_Msg (Flags, "?" & Msg, Location, Project);
- when Silent => null;
- end case;
- end Error_Or_Warning;
-
- ------------------------------
- -- Replace_Into_Name_Buffer --
- ------------------------------
-
- procedure Replace_Into_Name_Buffer
- (Str : String;
- Pattern : String;
- Replacement : Character)
- is
- Max : constant Integer := Str'Last - Pattern'Length + 1;
- J : Positive;
-
- begin
- Name_Len := 0;
-
- J := Str'First;
- while J <= Str'Last loop
- Name_Len := Name_Len + 1;
-
- if J <= Max and then Str (J .. J + Pattern'Length - 1) = Pattern then
- Name_Buffer (Name_Len) := Replacement;
- J := J + Pattern'Length;
- else
- Name_Buffer (Name_Len) := GNAT.Case_Util.To_Lower (Str (J));
- J := J + 1;
- end if;
- end loop;
- end Replace_Into_Name_Buffer;
-
- --------------------
- -- Suffix_Matches --
- --------------------
-
- function Suffix_Matches
- (Filename : String;
- Suffix : File_Name_Type) return Boolean
- is
- Min_Prefix_Length : Natural := 0;
-
- begin
- if Suffix = No_File or else Suffix = Empty_File then
- return False;
- end if;
-
- declare
- Suf : String := Get_Name_String (Suffix);
-
- begin
- -- On non case-sensitive systems, use proper suffix casing
-
- Canonical_Case_File_Name (Suf);
-
- -- The file name must end with the suffix (which is not an extension)
- -- For instance a suffix "configure.ac" must match a file with the
- -- same name. To avoid dummy cases, though, a suffix starting with
- -- '.' requires a file that is at least one character longer ('.cpp'
- -- should not match a file with the same name).
-
- if Suf (Suf'First) = '.' then
- Min_Prefix_Length := 1;
- end if;
-
- return Filename'Length >= Suf'Length + Min_Prefix_Length
- and then
- Filename (Filename'Last - Suf'Length + 1 .. Filename'Last) = Suf;
- end;
- end Suffix_Matches;
-
- ----------------
- -- Write_Attr --
- ----------------
-
- procedure Write_Attr (Name, Value : String) is
- begin
- if Current_Verbosity = High then
- Debug_Output (Name & " = """ & Value & '"');
- end if;
- end Write_Attr;
-
- ----------------
- -- Add_Source --
- ----------------
-
- procedure Add_Source
- (Id : out Source_Id;
- Data : in out Tree_Processing_Data;
- Project : Project_Id;
- Source_Dir_Rank : Natural;
- Lang_Id : Language_Ptr;
- Kind : Source_Kind;
- File_Name : File_Name_Type;
- Display_File : File_Name_Type;
- Naming_Exception : Naming_Exception_Type := No;
- Path : Path_Information := No_Path_Information;
- Alternate_Languages : Language_List := null;
- Unit : Name_Id := No_Name;
- Index : Int := 0;
- Locally_Removed : Boolean := False;
- Location : Source_Ptr := No_Location)
- is
- Config : constant Language_Config := Lang_Id.Config;
- UData : Unit_Index;
- Add_Src : Boolean;
- Source : Source_Id;
- Prev_Unit : Unit_Index := No_Unit_Index;
- Source_To_Replace : Source_Id := No_Source;
-
- begin
- -- Check if the same file name or unit is used in the prj tree
-
- Add_Src := True;
-
- if Unit /= No_Name then
- Prev_Unit := Units_Htable.Get (Data.Tree.Units_HT, Unit);
- end if;
-
- if Prev_Unit /= No_Unit_Index
- and then (Kind = Impl or else Kind = Spec)
- and then Prev_Unit.File_Names (Kind) /= null
- then
- -- Suspicious, we need to check later whether this is authorized
-
- Add_Src := False;
- Source := Prev_Unit.File_Names (Kind);
-
- else
- Source := Source_Files_Htable.Get
- (Data.Tree.Source_Files_HT, File_Name);
-
- if Source /= No_Source and then Source.Index = Index then
- Add_Src := False;
- end if;
- end if;
-
- -- Always add the source if it is locally removed, to avoid incorrect
- -- duplicate checks.
-
- if Locally_Removed then
- Add_Src := True;
-
- -- A locally removed source may first replace a source in a project
- -- being extended.
-
- if Source /= No_Source
- and then Is_Extending (Project, Source.Project)
- and then Naming_Exception /= Inherited
- then
- Source_To_Replace := Source;
- end if;
-
- else
- -- Duplication of file/unit in same project is allowed if order of
- -- source directories is known, or if there is no compiler for the
- -- language.
-
- if Add_Src = False then
- Add_Src := True;
-
- if Project = Source.Project then
- if Prev_Unit = No_Unit_Index then
- if Data.Flags.Allow_Duplicate_Basenames then
- Add_Src := True;
-
- elsif Lang_Id.Config.Compiler_Driver = Empty_File then
- Add_Src := True;
-
- elsif Source_Dir_Rank /= Source.Source_Dir_Rank then
- Add_Src := False;
-
- else
- Error_Msg_File_1 := File_Name;
- Error_Msg
- (Data.Flags, "duplicate source file name {",
- Location, Project);
- Add_Src := False;
- end if;
-
- else
- if Source_Dir_Rank /= Source.Source_Dir_Rank then
- Add_Src := False;
-
- -- We might be seeing the same file through a different
- -- path (for instance because of symbolic links).
-
- elsif Source.Path.Name /= Path.Name then
- if not Source.Duplicate_Unit then
- Error_Msg_Name_1 := Unit;
- Error_Msg
- (Data.Flags,
- "\duplicate unit %%",
- Location,
- Project);
- Source.Duplicate_Unit := True;
- end if;
-
- Add_Src := False;
- end if;
- end if;
-
- -- Do not allow the same unit name in different projects,
- -- except if one is extending the other.
-
- -- For a file based language, the same file name replaces a
- -- file in a project being extended, but it is allowed to have
- -- the same file name in unrelated projects.
-
- elsif Is_Extending (Project, Source.Project) then
- if not Locally_Removed and then Naming_Exception /= Inherited
- then
- Source_To_Replace := Source;
- end if;
-
- elsif Prev_Unit /= No_Unit_Index
- and then Prev_Unit.File_Names (Kind) /= null
- and then not Source.Locally_Removed
- and then Source.Replaced_By = No_Source
- and then not Data.In_Aggregate_Lib
- then
- -- Path is set if this is a source we found on the disk, in
- -- which case we can provide more explicit error message. Path
- -- is unset when the source is added from one of the naming
- -- exceptions in the project.
-
- if Path /= No_Path_Information then
- Error_Msg_Name_1 := Unit;
- Error_Msg
- (Data.Flags,
- "unit %% cannot belong to several projects",
- Location, Project);
-
- Error_Msg_Name_1 := Project.Name;
- Error_Msg_Name_2 := Name_Id (Path.Display_Name);
- Error_Msg
- (Data.Flags, "\ project %%, %%", Location, Project);
-
- Error_Msg_Name_1 := Source.Project.Name;
- Error_Msg_Name_2 := Name_Id (Source.Path.Display_Name);
- Error_Msg
- (Data.Flags, "\ project %%, %%", Location, Project);
-
- else
- Error_Msg_Name_1 := Unit;
- Error_Msg_Name_2 := Source.Project.Name;
- Error_Msg
- (Data.Flags, "unit %% already belongs to project %%",
- Location, Project);
- end if;
-
- Add_Src := False;
-
- elsif not Source.Locally_Removed
- and then Source.Replaced_By /= No_Source
- and then not Data.Flags.Allow_Duplicate_Basenames
- and then Lang_Id.Config.Kind = Unit_Based
- and then Source.Language.Config.Kind = Unit_Based
- and then not Data.In_Aggregate_Lib
- then
- Error_Msg_File_1 := File_Name;
- Error_Msg_File_2 := File_Name_Type (Source.Project.Name);
- Error_Msg
- (Data.Flags,
- "{ is already a source of project {", Location, Project);
-
- -- Add the file anyway, to avoid further warnings like
- -- "language unknown".
-
- Add_Src := True;
- end if;
- end if;
- end if;
-
- if not Add_Src then
- return;
- end if;
-
- -- Add the new file
-
- Id := new Source_Data;
-
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Str ("adding source File: ");
- Write_Str (Get_Name_String (Display_File));
-
- if Index /= 0 then
- Write_Str (" at" & Index'Img);
- end if;
-
- if Lang_Id.Config.Kind = Unit_Based then
- Write_Str (" Unit: ");
-
- -- ??? in gprclean, it seems we sometimes pass an empty Unit name
- -- (see test extended_projects).
-
- if Unit /= No_Name then
- Write_Str (Get_Name_String (Unit));
- end if;
-
- Write_Str (" Kind: ");
- Write_Str (Source_Kind'Image (Kind));
- end if;
-
- Write_Eol;
- end if;
-
- Id.Project := Project;
- Id.Location := Location;
- Id.Source_Dir_Rank := Source_Dir_Rank;
- Id.Language := Lang_Id;
- Id.Kind := Kind;
- Id.Alternate_Languages := Alternate_Languages;
- Id.Locally_Removed := Locally_Removed;
- Id.Index := Index;
- Id.File := File_Name;
- Id.Display_File := Display_File;
- Id.Dep_Name := Dependency_Name
- (File_Name, Lang_Id.Config.Dependency_Kind);
- Id.Naming_Exception := Naming_Exception;
- Id.Object := Object_Name
- (File_Name, Config.Object_File_Suffix);
- Id.Switches := Switches_Name (File_Name);
-
- -- Add the source id to the Unit_Sources_HT hash table, if the unit name
- -- is not null.
-
- if Unit /= No_Name then
-
- -- Note: we might be creating a dummy unit here, when we in fact have
- -- a separate. For instance, file file-bar.adb will initially be
- -- assumed to be the IMPL of unit "file.bar". Only later on (in
- -- Check_Object_Files) will we parse those units that only have an
- -- impl and no spec to make sure whether we have a Separate in fact
- -- (that significantly reduces the number of times we need to parse
- -- the files, since we are then only interested in those with no
- -- spec). We still need those dummy units in the table, since that's
- -- the name we find in the ALI file
-
- UData := Units_Htable.Get (Data.Tree.Units_HT, Unit);
-
- if UData = No_Unit_Index then
- UData := new Unit_Data;
- UData.Name := Unit;
-
- if Naming_Exception /= Inherited then
- Units_Htable.Set (Data.Tree.Units_HT, Unit, UData);
- end if;
- end if;
-
- Id.Unit := UData;
-
- -- Note that this updates Unit information as well
-
- if Naming_Exception /= Inherited and then not Locally_Removed then
- Override_Kind (Id, Kind);
- end if;
- end if;
-
- if Path /= No_Path_Information then
- Id.Path := Path;
- Source_Paths_Htable.Set (Data.Tree.Source_Paths_HT, Path.Name, Id);
- end if;
-
- Id.Next_With_File_Name :=
- Source_Files_Htable.Get (Data.Tree.Source_Files_HT, File_Name);
- Source_Files_Htable.Set (Data.Tree.Source_Files_HT, File_Name, Id);
-
- if Index /= 0 then
- Project.Has_Multi_Unit_Sources := True;
- end if;
-
- -- Add the source to the language list
-
- Id.Next_In_Lang := Lang_Id.First_Source;
- Lang_Id.First_Source := Id;
-
- if Source_To_Replace /= No_Source then
- Remove_Source (Data.Tree, Source_To_Replace, Id);
- end if;
-
- if Data.Tree.Replaced_Source_Number > 0
- and then
- Replaced_Source_HTable.Get
- (Data.Tree.Replaced_Sources, Id.File) /= No_File
- then
- Replaced_Source_HTable.Remove (Data.Tree.Replaced_Sources, Id.File);
- Data.Tree.Replaced_Source_Number :=
- Data.Tree.Replaced_Source_Number - 1;
- end if;
- end Add_Source;
-
- ------------------------------
- -- Canonical_Case_File_Name --
- ------------------------------
-
- function Canonical_Case_File_Name (Name : Name_Id) return File_Name_Type is
- begin
- if Osint.File_Names_Case_Sensitive then
- return File_Name_Type (Name);
- else
- Get_Name_String (Name);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- return Name_Find;
- end if;
- end Canonical_Case_File_Name;
-
- ---------------------------------
- -- Process_Aggregated_Projects --
- ---------------------------------
-
- procedure Process_Aggregated_Projects
- (Tree : Project_Tree_Ref;
- Project : Project_Id;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Processing_Flags)
- is
- Data : Tree_Processing_Data :=
- (Tree => Tree,
- Node_Tree => Node_Tree,
- Flags => Flags,
- In_Aggregate_Lib => False);
-
- Project_Files : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Project_Files,
- Project.Decl.Attributes,
- Tree.Shared);
-
- Project_Path_For_Aggregate : Prj.Env.Project_Search_Path;
-
- procedure Found_Project_File (Path : Path_Information; Rank : Natural);
- -- Called for each project file aggregated by Project
-
- procedure Expand_Project_Files is
- new Expand_Subdirectory_Pattern (Callback => Found_Project_File);
- -- Search for all project files referenced by the patterns given in
- -- parameter. Calls Found_Project_File for each of them.
-
- ------------------------
- -- Found_Project_File --
- ------------------------
-
- procedure Found_Project_File (Path : Path_Information; Rank : Natural) is
- pragma Unreferenced (Rank);
-
- begin
- if Path.Name /= Project.Path.Name then
- Debug_Output ("aggregates: ", Name_Id (Path.Display_Name));
-
- -- For usual "with" statement, this phase will have been done when
- -- parsing the project itself. However, for aggregate projects, we
- -- can only do this when processing the aggregate project, since
- -- the exact list of project files or project directories can
- -- depend on scenario variables.
- --
- -- We only load the projects explicitly here, but do not process
- -- them. For the processing, Prj.Proc will take care of processing
- -- them, within the same call to Recursive_Process (thus avoiding
- -- the processing of a given project multiple times).
- --
- -- ??? We might already have loaded the project
-
- Add_Aggregated_Project (Project, Path => Path.Name);
-
- else
- Debug_Output ("pattern returned the aggregate itself, ignored");
- end if;
- end Found_Project_File;
-
- -- Start of processing for Check_Aggregate_Project
-
- begin
- pragma Assert (Project.Qualifier in Aggregate_Project);
-
- if Project_Files.Default then
- Error_Msg_Name_1 := Snames.Name_Project_Files;
- Error_Msg
- (Flags,
- "Attribute %% must be specified in aggregate project",
- Project.Location, Project);
- return;
- end if;
-
- -- The aggregated projects are only searched relative to the directory
- -- of the aggregate project, not in the default project path.
-
- Initialize_Empty (Project_Path_For_Aggregate);
-
- Free (Project.Aggregated_Projects);
-
- -- Look for aggregated projects. For similarity with source files and
- -- dirs, the aggregated project files are not searched for on the
- -- project path, and are only found through the path specified in
- -- the Project_Files attribute.
-
- Expand_Project_Files
- (Project => Project,
- Data => Data,
- Patterns => Project_Files.Values,
- Ignore => Nil_String,
- Search_For => Search_Files,
- Resolve_Links => Opt.Follow_Links_For_Files);
-
- Free (Project_Path_For_Aggregate);
- end Process_Aggregated_Projects;
-
- ----------------------------
- -- Check_Abstract_Project --
- ----------------------------
-
- procedure Check_Abstract_Project
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Source_Dirs : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_Dirs,
- Project.Decl.Attributes, Shared);
- Source_Files : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_Files,
- Project.Decl.Attributes, Shared);
- Source_List_File : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_List_File,
- Project.Decl.Attributes, Shared);
- Languages : constant Variable_Value :=
- Util.Value_Of
- (Name_Languages,
- Project.Decl.Attributes, Shared);
-
- begin
- if Project.Source_Dirs /= Nil_String then
- if Source_Dirs.Values = Nil_String
- and then Source_Files.Values = Nil_String
- and then Languages.Values = Nil_String
- and then Source_List_File.Default
- then
- Project.Source_Dirs := Nil_String;
-
- else
- Error_Msg
- (Data.Flags,
- "at least one of Source_Files, Source_Dirs or Languages "
- & "must be declared empty for an abstract project",
- Project.Location, Project);
- end if;
- end if;
- end Check_Abstract_Project;
-
- -------------------------
- -- Check_Configuration --
- -------------------------
-
- procedure Check_Configuration
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access :=
- Data.Tree.Shared;
-
- Dot_Replacement : File_Name_Type := No_File;
- Casing : Casing_Type := All_Lower_Case;
- Separate_Suffix : File_Name_Type := No_File;
-
- Lang_Index : Language_Ptr := No_Language_Index;
- -- The index of the language data being checked
-
- Prev_Index : Language_Ptr := No_Language_Index;
- -- The index of the previous language
-
- procedure Process_Project_Level_Simple_Attributes;
- -- Process the simple attributes at the project level
-
- procedure Process_Project_Level_Array_Attributes;
- -- Process the associate array attributes at the project level
-
- procedure Process_Packages;
- -- Read the packages of the project
-
- ----------------------
- -- Process_Packages --
- ----------------------
-
- procedure Process_Packages is
- Packages : Package_Id;
- Element : Package_Element;
-
- procedure Process_Binder (Arrays : Array_Id);
- -- Process the associated array attributes of package Binder
-
- procedure Process_Builder (Attributes : Variable_Id);
- -- Process the simple attributes of package Builder
-
- procedure Process_Clean (Attributes : Variable_Id);
- -- Process the simple attributes of package Clean
-
- procedure Process_Clean (Arrays : Array_Id);
- -- Process the associated array attributes of package Clean
-
- procedure Process_Compiler (Arrays : Array_Id);
- -- Process the associated array attributes of package Compiler
-
- procedure Process_Naming (Attributes : Variable_Id);
- -- Process the simple attributes of package Naming
-
- procedure Process_Naming (Arrays : Array_Id);
- -- Process the associated array attributes of package Naming
-
- procedure Process_Linker (Attributes : Variable_Id);
- -- Process the simple attributes of package Linker of a
- -- configuration project.
-
- --------------------
- -- Process_Binder --
- --------------------
-
- procedure Process_Binder (Arrays : Array_Id) is
- Current_Array_Id : Array_Id;
- Current_Array : Array_Data;
- Element_Id : Array_Element_Id;
- Element : Array_Element;
-
- begin
- -- Process the associative array attribute of package Binder
-
- Current_Array_Id := Arrays;
- while Current_Array_Id /= No_Array loop
- Current_Array := Shared.Arrays.Table (Current_Array_Id);
-
- Element_Id := Current_Array.Value;
- while Element_Id /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Element_Id);
-
- if Element.Index /= All_Other_Names then
-
- -- Get the name of the language
-
- Lang_Index :=
- Get_Language_From_Name
- (Project, Get_Name_String (Element.Index));
-
- if Lang_Index /= No_Language_Index then
- case Current_Array.Name is
- when Name_Driver =>
-
- -- Attribute Driver (<language>)
-
- Lang_Index.Config.Binder_Driver :=
- File_Name_Type (Element.Value.Value);
-
- when Name_Required_Switches =>
- Put
- (Into_List =>
- Lang_Index.Config.Binder_Required_Switches,
- From_List => Element.Value.Values,
- In_Tree => Data.Tree);
-
- when Name_Prefix =>
-
- -- Attribute Prefix (<language>)
-
- Lang_Index.Config.Binder_Prefix :=
- Element.Value.Value;
-
- when Name_Objects_Path =>
-
- -- Attribute Objects_Path (<language>)
-
- Lang_Index.Config.Objects_Path :=
- Element.Value.Value;
-
- when Name_Objects_Path_File =>
-
- -- Attribute Objects_Path (<language>)
-
- Lang_Index.Config.Objects_Path_File :=
- Element.Value.Value;
-
- when others =>
- null;
- end case;
- end if;
- end if;
-
- Element_Id := Element.Next;
- end loop;
-
- Current_Array_Id := Current_Array.Next;
- end loop;
- end Process_Binder;
-
- ---------------------
- -- Process_Builder --
- ---------------------
-
- procedure Process_Builder (Attributes : Variable_Id) is
- Attribute_Id : Variable_Id;
- Attribute : Variable;
-
- begin
- -- Process non associated array attribute from package Builder
-
- Attribute_Id := Attributes;
- while Attribute_Id /= No_Variable loop
- Attribute := Shared.Variable_Elements.Table (Attribute_Id);
-
- if not Attribute.Value.Default then
- if Attribute.Name = Name_Executable_Suffix then
-
- -- Attribute Executable_Suffix: the suffix of the
- -- executables.
-
- Project.Config.Executable_Suffix :=
- Attribute.Value.Value;
- end if;
- end if;
-
- Attribute_Id := Attribute.Next;
- end loop;
- end Process_Builder;
-
- -------------------
- -- Process_Clean --
- -------------------
-
- procedure Process_Clean (Attributes : Variable_Id) is
- Attribute_Id : Variable_Id;
- Attribute : Variable;
- List : String_List_Id;
-
- begin
- -- Process non associated array attributes from package Clean
-
- Attribute_Id := Attributes;
- while Attribute_Id /= No_Variable loop
- Attribute := Shared.Variable_Elements.Table (Attribute_Id);
-
- if not Attribute.Value.Default then
- if Attribute.Name = Name_Artifacts_In_Exec_Dir then
-
- -- Attribute Artifacts_In_Exec_Dir: the list of file
- -- names to be cleaned in the exec dir of the main
- -- project.
-
- List := Attribute.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List =>
- Project.Config.Artifacts_In_Exec_Dir,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- elsif Attribute.Name = Name_Artifacts_In_Object_Dir then
-
- -- Attribute Artifacts_In_Exec_Dir: the list of file
- -- names to be cleaned in the object dir of every
- -- project.
-
- List := Attribute.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List =>
- Project.Config.Artifacts_In_Object_Dir,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
- end if;
- end if;
-
- Attribute_Id := Attribute.Next;
- end loop;
- end Process_Clean;
-
- procedure Process_Clean (Arrays : Array_Id) is
- Current_Array_Id : Array_Id;
- Current_Array : Array_Data;
- Element_Id : Array_Element_Id;
- Element : Array_Element;
- List : String_List_Id;
-
- begin
- -- Process the associated array attributes of package Clean
-
- Current_Array_Id := Arrays;
- while Current_Array_Id /= No_Array loop
- Current_Array := Shared.Arrays.Table (Current_Array_Id);
-
- Element_Id := Current_Array.Value;
- while Element_Id /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Element_Id);
-
- -- Get the name of the language
-
- Lang_Index :=
- Get_Language_From_Name
- (Project, Get_Name_String (Element.Index));
-
- if Lang_Index /= No_Language_Index then
- case Current_Array.Name is
-
- -- Attribute Object_Artifact_Extensions (<language>)
-
- when Name_Object_Artifact_Extensions =>
- List := Element.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List =>
- Lang_Index.Config.Clean_Object_Artifacts,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- -- Attribute Source_Artifact_Extensions (<language>)
-
- when Name_Source_Artifact_Extensions =>
- List := Element.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List =>
- Lang_Index.Config.Clean_Source_Artifacts,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- when others =>
- null;
- end case;
- end if;
-
- Element_Id := Element.Next;
- end loop;
-
- Current_Array_Id := Current_Array.Next;
- end loop;
- end Process_Clean;
-
- ----------------------
- -- Process_Compiler --
- ----------------------
-
- procedure Process_Compiler (Arrays : Array_Id) is
- Current_Array_Id : Array_Id;
- Current_Array : Array_Data;
- Element_Id : Array_Element_Id;
- Element : Array_Element;
- List : String_List_Id;
-
- begin
- -- Process the associative array attribute of package Compiler
-
- Current_Array_Id := Arrays;
- while Current_Array_Id /= No_Array loop
- Current_Array := Shared.Arrays.Table (Current_Array_Id);
-
- Element_Id := Current_Array.Value;
- while Element_Id /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Element_Id);
-
- if Element.Index /= All_Other_Names then
-
- -- Get the name of the language
-
- Lang_Index := Get_Language_From_Name
- (Project, Get_Name_String (Element.Index));
-
- if Lang_Index /= No_Language_Index then
- case Current_Array.Name is
-
- -- Attribute Dependency_Kind (<language>)
-
- when Name_Dependency_Kind =>
- Get_Name_String (Element.Value.Value);
-
- begin
- Lang_Index.Config.Dependency_Kind :=
- Dependency_File_Kind'Value
- (Name_Buffer (1 .. Name_Len));
-
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "illegal value for Dependency_Kind",
- Element.Value.Location,
- Project);
- end;
-
- -- Attribute Dependency_Switches (<language>)
-
- when Name_Dependency_Switches =>
- if Lang_Index.Config.Dependency_Kind = None then
- Lang_Index.Config.Dependency_Kind := Makefile;
- end if;
-
- List := Element.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List =>
- Lang_Index.Config.Dependency_Option,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- -- Attribute Dependency_Driver (<language>)
-
- when Name_Dependency_Driver =>
- if Lang_Index.Config.Dependency_Kind = None then
- Lang_Index.Config.Dependency_Kind := Makefile;
- end if;
-
- List := Element.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List =>
- Lang_Index.Config.Compute_Dependency,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- -- Attribute Language_Kind (<language>)
-
- when Name_Language_Kind =>
- Get_Name_String (Element.Value.Value);
-
- begin
- Lang_Index.Config.Kind :=
- Language_Kind'Value
- (Name_Buffer (1 .. Name_Len));
-
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "illegal value for Language_Kind",
- Element.Value.Location,
- Project);
- end;
-
- -- Attribute Include_Switches (<language>)
-
- when Name_Include_Switches =>
- List := Element.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags, "include option cannot be null",
- Element.Value.Location, Project);
- end if;
-
- Put (Into_List => Lang_Index.Config.Include_Option,
- From_List => List,
- In_Tree => Data.Tree);
-
- -- Attribute Include_Path (<language>)
-
- when Name_Include_Path =>
- Lang_Index.Config.Include_Path :=
- Element.Value.Value;
-
- -- Attribute Include_Path_File (<language>)
-
- when Name_Include_Path_File =>
- Lang_Index.Config.Include_Path_File :=
- Element.Value.Value;
-
- -- Attribute Driver (<language>)
-
- when Name_Driver =>
- Lang_Index.Config.Compiler_Driver :=
- File_Name_Type (Element.Value.Value);
-
- when Name_Leading_Required_Switches
- | Name_Required_Switches
- =>
- Put (Into_List =>
- Lang_Index.Config.
- Compiler_Leading_Required_Switches,
- From_List => Element.Value.Values,
- In_Tree => Data.Tree);
-
- when Name_Trailing_Required_Switches =>
- Put (Into_List =>
- Lang_Index.Config.
- Compiler_Trailing_Required_Switches,
- From_List => Element.Value.Values,
- In_Tree => Data.Tree);
-
- when Name_Multi_Unit_Switches =>
- Put (Into_List =>
- Lang_Index.Config.Multi_Unit_Switches,
- From_List => Element.Value.Values,
- In_Tree => Data.Tree);
-
- when Name_Multi_Unit_Object_Separator =>
- Get_Name_String (Element.Value.Value);
-
- if Name_Len /= 1 then
- Error_Msg
- (Data.Flags,
- "multi-unit object separator must have " &
- "a single character",
- Element.Value.Location, Project);
-
- elsif Name_Buffer (1) = ' ' then
- Error_Msg
- (Data.Flags,
- "multi-unit object separator cannot be " &
- "a space",
- Element.Value.Location, Project);
-
- else
- Lang_Index.Config.Multi_Unit_Object_Separator :=
- Name_Buffer (1);
- end if;
-
- when Name_Path_Syntax =>
- begin
- Lang_Index.Config.Path_Syntax :=
- Path_Syntax_Kind'Value
- (Get_Name_String (Element.Value.Value));
-
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value for Path_Syntax",
- Element.Value.Location, Project);
- end;
-
- when Name_Source_File_Switches =>
- Put (Into_List =>
- Lang_Index.Config.Source_File_Switches,
- From_List => Element.Value.Values,
- In_Tree => Data.Tree);
-
- when Name_Object_File_Suffix =>
- if Get_Name_String (Element.Value.Value) = "" then
- Error_Msg
- (Data.Flags,
- "object file suffix cannot be empty",
- Element.Value.Location, Project);
-
- else
- Lang_Index.Config.Object_File_Suffix :=
- Element.Value.Value;
- end if;
-
- when Name_Object_File_Switches =>
- Put (Into_List =>
- Lang_Index.Config.Object_File_Switches,
- From_List => Element.Value.Values,
- In_Tree => Data.Tree);
-
- when Name_Object_Path_Switches =>
- Put (Into_List =>
- Lang_Index.Config.Object_Path_Switches,
- From_List => Element.Value.Values,
- In_Tree => Data.Tree);
-
- -- Attribute Compiler_Pic_Option (<language>)
-
- when Name_Pic_Option =>
- List := Element.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags,
- "compiler PIC option cannot be null",
- Element.Value.Location, Project);
- end if;
-
- Put (Into_List =>
- Lang_Index.Config.Compilation_PIC_Option,
- From_List => List,
- In_Tree => Data.Tree);
-
- -- Attribute Mapping_File_Switches (<language>)
-
- when Name_Mapping_File_Switches =>
- List := Element.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags,
- "mapping file switches cannot be null",
- Element.Value.Location, Project);
- end if;
-
- Put (Into_List =>
- Lang_Index.Config.Mapping_File_Switches,
- From_List => List,
- In_Tree => Data.Tree);
-
- -- Attribute Mapping_Spec_Suffix (<language>)
-
- when Name_Mapping_Spec_Suffix =>
- Lang_Index.Config.Mapping_Spec_Suffix :=
- File_Name_Type (Element.Value.Value);
-
- -- Attribute Mapping_Body_Suffix (<language>)
-
- when Name_Mapping_Body_Suffix =>
- Lang_Index.Config.Mapping_Body_Suffix :=
- File_Name_Type (Element.Value.Value);
-
- -- Attribute Config_File_Switches (<language>)
-
- when Name_Config_File_Switches =>
- List := Element.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags,
- "config file switches cannot be null",
- Element.Value.Location, Project);
- end if;
-
- Put (Into_List =>
- Lang_Index.Config.Config_File_Switches,
- From_List => List,
- In_Tree => Data.Tree);
-
- -- Attribute Objects_Path (<language>)
-
- when Name_Objects_Path =>
- Lang_Index.Config.Objects_Path :=
- Element.Value.Value;
-
- -- Attribute Objects_Path_File (<language>)
-
- when Name_Objects_Path_File =>
- Lang_Index.Config.Objects_Path_File :=
- Element.Value.Value;
-
- -- Attribute Config_Body_File_Name (<language>)
-
- when Name_Config_Body_File_Name =>
- Lang_Index.Config.Config_Body :=
- Element.Value.Value;
-
- -- Attribute Config_Body_File_Name_Index (< Language>)
-
- when Name_Config_Body_File_Name_Index =>
- Lang_Index.Config.Config_Body_Index :=
- Element.Value.Value;
-
- -- Attribute Config_Body_File_Name_Pattern(<language>)
-
- when Name_Config_Body_File_Name_Pattern =>
- Lang_Index.Config.Config_Body_Pattern :=
- Element.Value.Value;
-
- -- Attribute Config_Spec_File_Name (<language>)
-
- when Name_Config_Spec_File_Name =>
- Lang_Index.Config.Config_Spec :=
- Element.Value.Value;
-
- -- Attribute Config_Spec_File_Name_Index (<language>)
-
- when Name_Config_Spec_File_Name_Index =>
- Lang_Index.Config.Config_Spec_Index :=
- Element.Value.Value;
-
- -- Attribute Config_Spec_File_Name_Pattern(<language>)
-
- when Name_Config_Spec_File_Name_Pattern =>
- Lang_Index.Config.Config_Spec_Pattern :=
- Element.Value.Value;
-
- -- Attribute Config_File_Unique (<language>)
-
- when Name_Config_File_Unique =>
- begin
- Lang_Index.Config.Config_File_Unique :=
- Boolean'Value
- (Get_Name_String (Element.Value.Value));
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "illegal value for Config_File_Unique",
- Element.Value.Location, Project);
- end;
-
- when others =>
- null;
- end case;
- end if;
- end if;
-
- Element_Id := Element.Next;
- end loop;
-
- Current_Array_Id := Current_Array.Next;
- end loop;
- end Process_Compiler;
-
- --------------------
- -- Process_Naming --
- --------------------
-
- procedure Process_Naming (Attributes : Variable_Id) is
- Attribute_Id : Variable_Id;
- Attribute : Variable;
-
- begin
- -- Process non associated array attribute from package Naming
-
- Attribute_Id := Attributes;
- while Attribute_Id /= No_Variable loop
- Attribute := Shared.Variable_Elements.Table (Attribute_Id);
-
- if not Attribute.Value.Default then
- if Attribute.Name = Name_Separate_Suffix then
-
- -- Attribute Separate_Suffix
-
- Get_Name_String (Attribute.Value.Value);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Separate_Suffix := Name_Find;
-
- elsif Attribute.Name = Name_Casing then
-
- -- Attribute Casing
-
- begin
- Casing :=
- Value (Get_Name_String (Attribute.Value.Value));
-
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value for Casing",
- Attribute.Value.Location, Project);
- end;
-
- elsif Attribute.Name = Name_Dot_Replacement then
-
- -- Attribute Dot_Replacement
-
- Dot_Replacement := File_Name_Type (Attribute.Value.Value);
-
- end if;
- end if;
-
- Attribute_Id := Attribute.Next;
- end loop;
- end Process_Naming;
-
- procedure Process_Naming (Arrays : Array_Id) is
- Current_Array_Id : Array_Id;
- Current_Array : Array_Data;
- Element_Id : Array_Element_Id;
- Element : Array_Element;
-
- begin
- -- Process the associative array attribute of package Naming
-
- Current_Array_Id := Arrays;
- while Current_Array_Id /= No_Array loop
- Current_Array := Shared.Arrays.Table (Current_Array_Id);
-
- Element_Id := Current_Array.Value;
- while Element_Id /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Element_Id);
-
- -- Get the name of the language
-
- Lang_Index := Get_Language_From_Name
- (Project, Get_Name_String (Element.Index));
-
- if Lang_Index /= No_Language_Index
- and then Element.Value.Kind = Single
- and then Element.Value.Value /= No_Name
- then
- case Current_Array.Name is
- when Name_Spec_Suffix
- | Name_Specification_Suffix
- =>
- -- Attribute Spec_Suffix (<language>)
-
- Get_Name_String (Element.Value.Value);
- Canonical_Case_File_Name
- (Name_Buffer (1 .. Name_Len));
- Lang_Index.Config.Naming_Data.Spec_Suffix :=
- Name_Find;
-
- when Name_Body_Suffix
- | Name_Implementation_Suffix
- =>
- Get_Name_String (Element.Value.Value);
- Canonical_Case_File_Name
- (Name_Buffer (1 .. Name_Len));
-
- -- Attribute Body_Suffix (<language>)
-
- Lang_Index.Config.Naming_Data.Body_Suffix :=
- Name_Find;
- Lang_Index.Config.Naming_Data.Separate_Suffix :=
- Lang_Index.Config.Naming_Data.Body_Suffix;
-
- when others =>
- null;
- end case;
- end if;
-
- Element_Id := Element.Next;
- end loop;
-
- Current_Array_Id := Current_Array.Next;
- end loop;
- end Process_Naming;
-
- --------------------
- -- Process_Linker --
- --------------------
-
- procedure Process_Linker (Attributes : Variable_Id) is
- Attribute_Id : Variable_Id;
- Attribute : Variable;
-
- begin
- -- Process non associated array attribute from package Linker
-
- Attribute_Id := Attributes;
- while Attribute_Id /= No_Variable loop
- Attribute := Shared.Variable_Elements.Table (Attribute_Id);
-
- if not Attribute.Value.Default then
- if Attribute.Name = Name_Driver then
-
- -- Attribute Linker'Driver: the default linker to use
-
- Project.Config.Linker :=
- Path_Name_Type (Attribute.Value.Value);
-
- -- Linker'Driver is also used to link shared libraries
- -- if the obsolescent attribute Library_GCC has not been
- -- specified.
-
- if Project.Config.Shared_Lib_Driver = No_File then
- Project.Config.Shared_Lib_Driver :=
- File_Name_Type (Attribute.Value.Value);
- end if;
-
- elsif Attribute.Name = Name_Required_Switches then
-
- -- Attribute Required_Switches: the minimum trailing
- -- options to use when invoking the linker
-
- Put (Into_List =>
- Project.Config.Trailing_Linker_Required_Switches,
- From_List => Attribute.Value.Values,
- In_Tree => Data.Tree);
-
- elsif Attribute.Name = Name_Map_File_Option then
- Project.Config.Map_File_Option := Attribute.Value.Value;
-
- elsif Attribute.Name = Name_Max_Command_Line_Length then
- begin
- Project.Config.Max_Command_Line_Length :=
- Natural'Value (Get_Name_String
- (Attribute.Value.Value));
-
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "value must be positive or equal to 0",
- Attribute.Value.Location, Project);
- end;
-
- elsif Attribute.Name = Name_Response_File_Format then
- declare
- Name : Name_Id;
-
- begin
- Get_Name_String (Attribute.Value.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Name := Name_Find;
-
- if Name = Name_None then
- Project.Config.Resp_File_Format := None;
-
- elsif Name = Name_Gnu then
- Project.Config.Resp_File_Format := GNU;
-
- elsif Name = Name_Object_List then
- Project.Config.Resp_File_Format := Object_List;
-
- elsif Name = Name_Option_List then
- Project.Config.Resp_File_Format := Option_List;
-
- elsif Name_Buffer (1 .. Name_Len) = "gcc" then
- Project.Config.Resp_File_Format := GCC;
-
- elsif Name_Buffer (1 .. Name_Len) = "gcc_gnu" then
- Project.Config.Resp_File_Format := GCC_GNU;
-
- elsif
- Name_Buffer (1 .. Name_Len) = "gcc_option_list"
- then
- Project.Config.Resp_File_Format := GCC_Option_List;
-
- elsif
- Name_Buffer (1 .. Name_Len) = "gcc_object_list"
- then
- Project.Config.Resp_File_Format := GCC_Object_List;
-
- else
- Error_Msg
- (Data.Flags,
- "illegal response file format",
- Attribute.Value.Location, Project);
- end if;
- end;
-
- elsif Attribute.Name = Name_Response_File_Switches then
- Put (Into_List => Project.Config.Resp_File_Options,
- From_List => Attribute.Value.Values,
- In_Tree => Data.Tree);
- end if;
- end if;
-
- Attribute_Id := Attribute.Next;
- end loop;
- end Process_Linker;
-
- -- Start of processing for Process_Packages
-
- begin
- Packages := Project.Decl.Packages;
- while Packages /= No_Package loop
- Element := Shared.Packages.Table (Packages);
-
- case Element.Name is
- when Name_Binder =>
-
- -- Process attributes of package Binder
-
- Process_Binder (Element.Decl.Arrays);
-
- when Name_Builder =>
-
- -- Process attributes of package Builder
-
- Process_Builder (Element.Decl.Attributes);
-
- when Name_Clean =>
-
- -- Process attributes of package Clean
-
- Process_Clean (Element.Decl.Attributes);
- Process_Clean (Element.Decl.Arrays);
-
- when Name_Compiler =>
-
- -- Process attributes of package Compiler
-
- Process_Compiler (Element.Decl.Arrays);
-
- when Name_Linker =>
-
- -- Process attributes of package Linker
-
- Process_Linker (Element.Decl.Attributes);
-
- when Name_Naming =>
-
- -- Process attributes of package Naming
-
- Process_Naming (Element.Decl.Attributes);
- Process_Naming (Element.Decl.Arrays);
-
- when others =>
- null;
- end case;
-
- Packages := Element.Next;
- end loop;
- end Process_Packages;
-
- ---------------------------------------------
- -- Process_Project_Level_Simple_Attributes --
- ---------------------------------------------
-
- procedure Process_Project_Level_Simple_Attributes is
- Attribute_Id : Variable_Id;
- Attribute : Variable;
- List : String_List_Id;
-
- begin
- -- Process non associated array attribute at project level
-
- Attribute_Id := Project.Decl.Attributes;
- while Attribute_Id /= No_Variable loop
- Attribute := Shared.Variable_Elements.Table (Attribute_Id);
-
- if not Attribute.Value.Default then
- if Attribute.Name = Name_Target then
-
- -- Attribute Target: the target specified
-
- Project.Config.Target := Attribute.Value.Value;
-
- elsif Attribute.Name = Name_Library_Builder then
-
- -- Attribute Library_Builder: the application to invoke
- -- to build libraries.
-
- Project.Config.Library_Builder :=
- Path_Name_Type (Attribute.Value.Value);
-
- elsif Attribute.Name = Name_Archive_Builder then
-
- -- Attribute Archive_Builder: the archive builder
- -- (usually "ar") and its minimum options (usually "cr").
-
- List := Attribute.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags,
- "archive builder cannot be null",
- Attribute.Value.Location, Project);
- end if;
-
- Put (Into_List => Project.Config.Archive_Builder,
- From_List => List,
- In_Tree => Data.Tree);
-
- elsif Attribute.Name = Name_Archive_Builder_Append_Option then
-
- -- Attribute Archive_Builder: the archive builder
- -- (usually "ar") and its minimum options (usually "cr").
-
- List := Attribute.Value.Values;
-
- if List /= Nil_String then
- Put
- (Into_List =>
- Project.Config.Archive_Builder_Append_Option,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- elsif Attribute.Name = Name_Archive_Indexer then
-
- -- Attribute Archive_Indexer: the optional archive
- -- indexer (usually "ranlib") with its minimum options
- -- (usually none).
-
- List := Attribute.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags,
- "archive indexer cannot be null",
- Attribute.Value.Location, Project);
- end if;
-
- Put (Into_List => Project.Config.Archive_Indexer,
- From_List => List,
- In_Tree => Data.Tree);
-
- elsif Attribute.Name = Name_Library_Partial_Linker then
-
- -- Attribute Library_Partial_Linker: the optional linker
- -- driver with its minimum options, to partially link
- -- archives.
-
- List := Attribute.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags,
- "partial linker cannot be null",
- Attribute.Value.Location, Project);
- end if;
-
- Put (Into_List => Project.Config.Lib_Partial_Linker,
- From_List => List,
- In_Tree => Data.Tree);
-
- elsif Attribute.Name = Name_Library_GCC then
- Project.Config.Shared_Lib_Driver :=
- File_Name_Type (Attribute.Value.Value);
- Error_Msg
- (Data.Flags,
- "?Library_'G'C'C is an obsolescent attribute, " &
- "use Linker''Driver instead",
- Attribute.Value.Location, Project);
-
- elsif Attribute.Name = Name_Archive_Suffix then
- Project.Config.Archive_Suffix :=
- File_Name_Type (Attribute.Value.Value);
-
- elsif Attribute.Name = Name_Linker_Executable_Option then
-
- -- Attribute Linker_Executable_Option: optional options
- -- to specify an executable name. Defaults to "-o".
-
- List := Attribute.Value.Values;
-
- if List = Nil_String then
- Error_Msg
- (Data.Flags,
- "linker executable option cannot be null",
- Attribute.Value.Location, Project);
- end if;
-
- Put (Into_List => Project.Config.Linker_Executable_Option,
- From_List => List,
- In_Tree => Data.Tree);
-
- elsif Attribute.Name = Name_Linker_Lib_Dir_Option then
-
- -- Attribute Linker_Lib_Dir_Option: optional options
- -- to specify a library search directory. Defaults to
- -- "-L".
-
- Get_Name_String (Attribute.Value.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Data.Flags,
- "linker library directory option cannot be empty",
- Attribute.Value.Location, Project);
- end if;
-
- Project.Config.Linker_Lib_Dir_Option :=
- Attribute.Value.Value;
-
- elsif Attribute.Name = Name_Linker_Lib_Name_Option then
-
- -- Attribute Linker_Lib_Name_Option: optional options
- -- to specify the name of a library to be linked in.
- -- Defaults to "-l".
-
- Get_Name_String (Attribute.Value.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Data.Flags,
- "linker library name option cannot be empty",
- Attribute.Value.Location, Project);
- end if;
-
- Project.Config.Linker_Lib_Name_Option :=
- Attribute.Value.Value;
-
- elsif Attribute.Name = Name_Run_Path_Option then
-
- -- Attribute Run_Path_Option: optional options to
- -- specify a path for libraries.
-
- List := Attribute.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List => Project.Config.Run_Path_Option,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- elsif Attribute.Name = Name_Run_Path_Origin then
- Get_Name_String (Attribute.Value.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Data.Flags,
- "run path origin cannot be empty",
- Attribute.Value.Location, Project);
- end if;
-
- Project.Config.Run_Path_Origin := Attribute.Value.Value;
-
- elsif Attribute.Name = Name_Library_Install_Name_Option then
- Project.Config.Library_Install_Name_Option :=
- Attribute.Value.Value;
-
- elsif Attribute.Name = Name_Separate_Run_Path_Options then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Project.Config.Separate_Run_Path_Options :=
- Boolean'Value (Get_Name_String (Attribute.Value.Value));
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """ &
- Get_Name_String (Attribute.Value.Value) &
- """ for Separate_Run_Path_Options",
- Attribute.Value.Location, Project);
- end;
-
- elsif Attribute.Name = Name_Library_Support then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Project.Config.Lib_Support :=
- Library_Support'Value (Get_Name_String
- (Attribute.Value.Value));
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """ &
- Get_Name_String (Attribute.Value.Value) &
- """ for Library_Support",
- Attribute.Value.Location, Project);
- end;
-
- elsif
- Attribute.Name = Name_Library_Encapsulated_Supported
- then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Project.Config.Lib_Encapsulated_Supported :=
- Boolean'Value (Get_Name_String (Attribute.Value.Value));
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """
- & Get_Name_String (Attribute.Value.Value)
- & """ for Library_Encapsulated_Supported",
- Attribute.Value.Location, Project);
- end;
-
- elsif Attribute.Name = Name_Shared_Library_Prefix then
- Project.Config.Shared_Lib_Prefix :=
- File_Name_Type (Attribute.Value.Value);
-
- elsif Attribute.Name = Name_Shared_Library_Suffix then
- Project.Config.Shared_Lib_Suffix :=
- File_Name_Type (Attribute.Value.Value);
-
- elsif Attribute.Name = Name_Symbolic_Link_Supported then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Project.Config.Symbolic_Link_Supported :=
- Boolean'Value (Get_Name_String
- (Attribute.Value.Value));
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """
- & Get_Name_String (Attribute.Value.Value)
- & """ for Symbolic_Link_Supported",
- Attribute.Value.Location, Project);
- end;
-
- elsif
- Attribute.Name = Name_Library_Major_Minor_Id_Supported
- then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Project.Config.Lib_Maj_Min_Id_Supported :=
- Boolean'Value (Get_Name_String
- (Attribute.Value.Value));
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """ &
- Get_Name_String (Attribute.Value.Value) &
- """ for Library_Major_Minor_Id_Supported",
- Attribute.Value.Location, Project);
- end;
-
- elsif Attribute.Name = Name_Library_Auto_Init_Supported then
- declare
- pragma Unsuppress (All_Checks);
- begin
- Project.Config.Auto_Init_Supported :=
- Boolean'Value (Get_Name_String (Attribute.Value.Value));
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """
- & Get_Name_String (Attribute.Value.Value)
- & """ for Library_Auto_Init_Supported",
- Attribute.Value.Location, Project);
- end;
-
- elsif Attribute.Name = Name_Shared_Library_Minimum_Switches then
- List := Attribute.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List => Project.Config.Shared_Lib_Min_Options,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
-
- elsif Attribute.Name = Name_Library_Version_Switches then
- List := Attribute.Value.Values;
-
- if List /= Nil_String then
- Put (Into_List => Project.Config.Lib_Version_Options,
- From_List => List,
- In_Tree => Data.Tree);
- end if;
- end if;
- end if;
-
- Attribute_Id := Attribute.Next;
- end loop;
- end Process_Project_Level_Simple_Attributes;
-
- --------------------------------------------
- -- Process_Project_Level_Array_Attributes --
- --------------------------------------------
-
- procedure Process_Project_Level_Array_Attributes is
- Current_Array_Id : Array_Id;
- Current_Array : Array_Data;
- Element_Id : Array_Element_Id;
- Element : Array_Element;
- List : String_List_Id;
-
- begin
- -- Process the associative array attributes at project level
-
- Current_Array_Id := Project.Decl.Arrays;
- while Current_Array_Id /= No_Array loop
- Current_Array := Shared.Arrays.Table (Current_Array_Id);
-
- Element_Id := Current_Array.Value;
- while Element_Id /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Element_Id);
-
- -- Get the name of the language
-
- Lang_Index :=
- Get_Language_From_Name
- (Project, Get_Name_String (Element.Index));
-
- if Lang_Index /= No_Language_Index then
- case Current_Array.Name is
- when Name_Inherit_Source_Path =>
- List := Element.Value.Values;
-
- if List /= Nil_String then
- Put
- (Into_List =>
- Lang_Index.Config.Include_Compatible_Languages,
- From_List => List,
- In_Tree => Data.Tree,
- Lower_Case => True);
- end if;
-
- when Name_Toolchain_Description =>
-
- -- Attribute Toolchain_Description (<language>)
-
- Lang_Index.Config.Toolchain_Description :=
- Element.Value.Value;
-
- when Name_Toolchain_Version =>
-
- -- Attribute Toolchain_Version (<language>)
-
- Lang_Index.Config.Toolchain_Version :=
- Element.Value.Value;
-
- -- For Ada, set proper checksum computation mode,
- -- which has changed from version to version.
-
- if Lang_Index.Name = Name_Ada then
- declare
- Vers : constant String :=
- Get_Name_String (Element.Value.Value);
- pragma Assert (Vers'First = 1);
-
- begin
- -- Version 6.3 or earlier
-
- if Vers'Length >= 8
- and then Vers (1 .. 5) = "GNAT "
- and then Vers (7) = '.'
- and then
- (Vers (6) < '6'
- or else
- (Vers (6) = '6' and then Vers (8) < '4'))
- then
- Checksum_GNAT_6_3 := True;
-
- -- Version 5.03 or earlier
-
- if Vers (6) < '5'
- or else (Vers (6) = '5'
- and then Vers (Vers'Last) < '4')
- then
- Checksum_GNAT_5_03 := True;
-
- -- Version 5.02 or earlier (no checksums)
-
- if Vers (6) /= '5'
- or else Vers (Vers'Last) < '3'
- then
- Checksum_Accumulate_Token_Checksum :=
- False;
- end if;
- end if;
- end if;
- end;
- end if;
-
- when Name_Runtime_Library_Dir =>
-
- -- Attribute Runtime_Library_Dir (<language>)
-
- Lang_Index.Config.Runtime_Library_Dir :=
- Element.Value.Value;
-
- when Name_Runtime_Source_Dir =>
-
- -- Attribute Runtime_Source_Dir (<language>)
-
- Lang_Index.Config.Runtime_Source_Dir :=
- Element.Value.Value;
-
- when Name_Object_Generated =>
- declare
- pragma Unsuppress (All_Checks);
- Value : Boolean;
-
- begin
- Value :=
- Boolean'Value
- (Get_Name_String (Element.Value.Value));
-
- Lang_Index.Config.Object_Generated := Value;
-
- -- If no object is generated, no object may be
- -- linked.
-
- if not Value then
- Lang_Index.Config.Objects_Linked := False;
- end if;
-
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """
- & Get_Name_String (Element.Value.Value)
- & """ for Object_Generated",
- Element.Value.Location, Project);
- end;
-
- when Name_Objects_Linked =>
- declare
- pragma Unsuppress (All_Checks);
- Value : Boolean;
-
- begin
- Value :=
- Boolean'Value
- (Get_Name_String (Element.Value.Value));
-
- -- No change if Object_Generated is False, as this
- -- forces Objects_Linked to be False too.
-
- if Lang_Index.Config.Object_Generated then
- Lang_Index.Config.Objects_Linked := Value;
- end if;
-
- exception
- when Constraint_Error =>
- Error_Msg
- (Data.Flags,
- "invalid value """
- & Get_Name_String (Element.Value.Value)
- & """ for Objects_Linked",
- Element.Value.Location, Project);
- end;
-
- when others =>
- null;
- end case;
- end if;
-
- Element_Id := Element.Next;
- end loop;
-
- Current_Array_Id := Current_Array.Next;
- end loop;
- end Process_Project_Level_Array_Attributes;
-
- -- Start of processing for Check_Configuration
-
- begin
- Process_Project_Level_Simple_Attributes;
- Process_Project_Level_Array_Attributes;
- Process_Packages;
-
- -- For unit based languages, set Casing, Dot_Replacement and
- -- Separate_Suffix in Naming_Data.
-
- Lang_Index := Project.Languages;
- while Lang_Index /= No_Language_Index loop
- if Lang_Index.Config.Kind = Unit_Based then
- Lang_Index.Config.Naming_Data.Casing := Casing;
- Lang_Index.Config.Naming_Data.Dot_Replacement := Dot_Replacement;
-
- if Separate_Suffix /= No_File then
- Lang_Index.Config.Naming_Data.Separate_Suffix :=
- Separate_Suffix;
- end if;
-
- exit;
- end if;
-
- Lang_Index := Lang_Index.Next;
- end loop;
-
- -- Give empty names to various prefixes/suffixes, if they have not
- -- been specified in the configuration.
-
- if Project.Config.Archive_Suffix = No_File then
- Project.Config.Archive_Suffix := Empty_File;
- end if;
-
- if Project.Config.Shared_Lib_Prefix = No_File then
- Project.Config.Shared_Lib_Prefix := Empty_File;
- end if;
-
- if Project.Config.Shared_Lib_Suffix = No_File then
- Project.Config.Shared_Lib_Suffix := Empty_File;
- end if;
-
- Lang_Index := Project.Languages;
- while Lang_Index /= No_Language_Index loop
-
- -- For all languages, Compiler_Driver needs to be specified. This is
- -- only needed if we do intend to compile (not in GPS for instance).
-
- if Data.Flags.Compiler_Driver_Mandatory
- and then Lang_Index.Config.Compiler_Driver = No_File
- and then not Project.Externally_Built
- then
- Error_Msg_Name_1 := Lang_Index.Display_Name;
- Error_Msg
- (Data.Flags,
- "?\no compiler specified for language %%" &
- ", ignoring all its sources",
- No_Location, Project);
-
- if Lang_Index = Project.Languages then
- Project.Languages := Lang_Index.Next;
- else
- Prev_Index.Next := Lang_Index.Next;
- end if;
-
- elsif Lang_Index.Config.Kind = Unit_Based then
- Prev_Index := Lang_Index;
-
- -- For unit based languages, Dot_Replacement, Spec_Suffix and
- -- Body_Suffix need to be specified.
-
- if Lang_Index.Config.Naming_Data.Dot_Replacement = No_File then
- Error_Msg
- (Data.Flags,
- "Dot_Replacement not specified for " &
- Get_Name_String (Lang_Index.Name),
- No_Location, Project);
- end if;
-
- if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then
- Error_Msg
- (Data.Flags,
- "\Spec_Suffix not specified for " &
- Get_Name_String (Lang_Index.Name),
- No_Location, Project);
- end if;
-
- if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then
- Error_Msg
- (Data.Flags,
- "\Body_Suffix not specified for " &
- Get_Name_String (Lang_Index.Name),
- No_Location, Project);
- end if;
-
- else
- Prev_Index := Lang_Index;
-
- -- For file based languages, either Spec_Suffix or Body_Suffix
- -- need to be specified.
-
- if Data.Flags.Require_Sources_Other_Lang
- and then Lang_Index.Config.Naming_Data.Spec_Suffix = No_File
- and then Lang_Index.Config.Naming_Data.Body_Suffix = No_File
- then
- Error_Msg_Name_1 := Lang_Index.Display_Name;
- Error_Msg
- (Data.Flags,
- "\no suffixes specified for %%",
- No_Location, Project);
- end if;
- end if;
-
- Lang_Index := Lang_Index.Next;
- end loop;
- end Check_Configuration;
-
- -------------------------------
- -- Check_If_Externally_Built --
- -------------------------------
-
- procedure Check_If_Externally_Built
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
- Externally_Built : constant Variable_Value :=
- Util.Value_Of
- (Name_Externally_Built,
- Project.Decl.Attributes, Shared);
-
- begin
- if not Externally_Built.Default then
- Get_Name_String (Externally_Built.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- if Name_Buffer (1 .. Name_Len) = "true" then
- Project.Externally_Built := True;
-
- elsif Name_Buffer (1 .. Name_Len) /= "false" then
- Error_Msg (Data.Flags,
- "Externally_Built may only be true or false",
- Externally_Built.Location, Project);
- end if;
- end if;
-
- -- A virtual project extending an externally built project is itself
- -- externally built.
-
- if Project.Virtual and then Project.Extends /= No_Project then
- Project.Externally_Built := Project.Extends.Externally_Built;
- end if;
-
- if Project.Externally_Built then
- Debug_Output ("project is externally built");
- else
- Debug_Output ("project is not externally built");
- end if;
- end Check_If_Externally_Built;
-
- ----------------------
- -- Check_Interfaces --
- ----------------------
-
- procedure Check_Interfaces
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Interfaces : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Interfaces,
- Project.Decl.Attributes,
- Shared);
-
- Library_Interface : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Interface,
- Project.Decl.Attributes,
- Shared);
-
- List : String_List_Id;
- Element : String_Element;
- Name : File_Name_Type;
- Iter : Source_Iterator;
- Source : Source_Id;
- Project_2 : Project_Id;
- Other : Source_Id;
- Unit_Found : Boolean;
-
- Interface_ALIs : String_List_Id := Nil_String;
- Other_Interfaces : String_List_Id := Nil_String;
-
- begin
- if not Interfaces.Default then
-
- -- Set In_Interfaces to False for all sources. It will be set to True
- -- later for the sources in the Interfaces list.
-
- Project_2 := Project;
- while Project_2 /= No_Project loop
- Iter := For_Each_Source (Data.Tree, Project_2);
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
- Source.In_Interfaces := False;
- Next (Iter);
- end loop;
-
- Project_2 := Project_2.Extends;
- end loop;
-
- List := Interfaces.Values;
- while List /= Nil_String loop
- Element := Shared.String_Elements.Table (List);
- Name := Canonical_Case_File_Name (Element.Value);
-
- Project_2 := Project;
- Big_Loop : while Project_2 /= No_Project loop
- if Project.Qualifier = Aggregate_Library then
-
- -- For an aggregate library we want to consider sources of
- -- all aggregated projects.
-
- Iter := For_Each_Source (Data.Tree);
-
- else
- Iter := For_Each_Source (Data.Tree, Project_2);
- end if;
-
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- if Source.File = Name then
- if not Source.Locally_Removed then
- Source.In_Interfaces := True;
- Source.Declared_In_Interfaces := True;
-
- Other := Other_Part (Source);
-
- if Other /= No_Source then
- Other.In_Interfaces := True;
- Other.Declared_In_Interfaces := True;
- end if;
-
- -- Unit based case
-
- if Source.Language.Config.Kind = Unit_Based then
- if Source.Kind = Spec
- and then Other_Part (Source) /= No_Source
- then
- Source := Other_Part (Source);
- end if;
-
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- Shared.String_Elements.Table
- (String_Element_Table.Last
- (Shared.String_Elements)) :=
- (Value => Name_Id (Source.Dep_Name),
- Index => 0,
- Display_Value => Name_Id (Source.Dep_Name),
- Location => No_Location,
- Flag => False,
- Next => Interface_ALIs);
-
- Interface_ALIs :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- -- File based case
-
- else
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- Shared.String_Elements.Table
- (String_Element_Table.Last
- (Shared.String_Elements)) :=
- (Value => Name_Id (Source.File),
- Index => 0,
- Display_Value => Name_Id (Source.Display_File),
- Location => No_Location,
- Flag => False,
- Next => Other_Interfaces);
-
- Other_Interfaces :=
- String_Element_Table.Last
- (Shared.String_Elements);
- end if;
-
- Debug_Output
- ("interface: ", Name_Id (Source.Path.Name));
- end if;
-
- exit Big_Loop;
- end if;
-
- Next (Iter);
- end loop;
-
- Project_2 := Project_2.Extends;
- end loop Big_Loop;
-
- if Source = No_Source then
- Error_Msg_File_1 := File_Name_Type (Element.Value);
- Error_Msg_Name_1 := Project.Name;
-
- Error_Msg
- (Data.Flags,
- "{ cannot be an interface of project %% "
- & "as it is not one of its sources",
- Element.Location, Project);
- end if;
-
- List := Element.Next;
- end loop;
-
- Project.Interfaces_Defined := True;
- Project.Lib_Interface_ALIs := Interface_ALIs;
- Project.Other_Interfaces := Other_Interfaces;
-
- elsif Project.Library and then not Library_Interface.Default then
-
- -- Set In_Interfaces to False for all sources. It will be set to True
- -- later for the sources in the Library_Interface list.
-
- Project_2 := Project;
- while Project_2 /= No_Project loop
- Iter := For_Each_Source (Data.Tree, Project_2);
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
- Source.In_Interfaces := False;
- Next (Iter);
- end loop;
-
- Project_2 := Project_2.Extends;
- end loop;
-
- List := Library_Interface.Values;
- while List /= Nil_String loop
- Element := Shared.String_Elements.Table (List);
- Get_Name_String (Element.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Name := Name_Find;
- Unit_Found := False;
-
- Project_2 := Project;
- Big_Loop_2 : while Project_2 /= No_Project loop
- if Project.Qualifier = Aggregate_Library then
-
- -- For an aggregate library we want to consider sources of
- -- all aggregated projects.
-
- Iter := For_Each_Source (Data.Tree);
-
- else
- Iter := For_Each_Source (Data.Tree, Project_2);
- end if;
-
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- if Source.Unit /= No_Unit_Index
- and then Source.Unit.Name = Name_Id (Name)
- then
- if not Source.Locally_Removed then
- Source.In_Interfaces := True;
- Source.Declared_In_Interfaces := True;
- Project.Interfaces_Defined := True;
-
- Other := Other_Part (Source);
-
- if Other /= No_Source then
- Other.In_Interfaces := True;
- Other.Declared_In_Interfaces := True;
- end if;
-
- Debug_Output
- ("interface: ", Name_Id (Source.Path.Name));
-
- if Source.Kind = Spec
- and then Other_Part (Source) /= No_Source
- then
- Source := Other_Part (Source);
- end if;
-
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- Shared.String_Elements.Table
- (String_Element_Table.Last
- (Shared.String_Elements)) :=
- (Value => Name_Id (Source.Dep_Name),
- Index => 0,
- Display_Value => Name_Id (Source.Dep_Name),
- Location => No_Location,
- Flag => False,
- Next => Interface_ALIs);
-
- Interface_ALIs :=
- String_Element_Table.Last (Shared.String_Elements);
- end if;
-
- Unit_Found := True;
- exit Big_Loop_2;
- end if;
-
- Next (Iter);
- end loop;
-
- Project_2 := Project_2.Extends;
- end loop Big_Loop_2;
-
- if not Unit_Found then
- Error_Msg_Name_1 := Name_Id (Name);
-
- Error_Msg
- (Data.Flags,
- "%% is not a unit of this project",
- Element.Location, Project);
- end if;
-
- List := Element.Next;
- end loop;
-
- Project.Lib_Interface_ALIs := Interface_ALIs;
-
- elsif Project.Extends /= No_Project
- and then Project.Extends.Interfaces_Defined
- then
- Project.Interfaces_Defined := True;
-
- Iter := For_Each_Source (Data.Tree, Project);
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- if not Source.Declared_In_Interfaces then
- Source.In_Interfaces := False;
- end if;
-
- Next (Iter);
- end loop;
-
- Project.Lib_Interface_ALIs := Project.Extends.Lib_Interface_ALIs;
- end if;
- end Check_Interfaces;
-
- ------------------------------
- -- Check_Library_Attributes --
- ------------------------------
-
- -- This procedure is awfully long (over 700 lines) should be broken up???
-
- procedure Check_Library_Attributes
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Attributes : constant Prj.Variable_Id := Project.Decl.Attributes;
-
- Lib_Dir : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Dir, Attributes, Shared);
-
- Lib_Name : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Name, Attributes, Shared);
-
- Lib_Standalone : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Standalone,
- Attributes, Shared);
-
- Lib_Version : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Version, Attributes, Shared);
-
- Lib_ALI_Dir : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Ali_Dir, Attributes, Shared);
-
- Lib_GCC : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_GCC, Attributes, Shared);
-
- The_Lib_Kind : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Kind, Attributes, Shared);
-
- Imported_Project_List : Project_List;
- Continuation : String_Access := No_Continuation_String'Access;
- Support_For_Libraries : Library_Support;
-
- Library_Directory_Present : Boolean;
-
- procedure Check_Library (Proj : Project_Id; Extends : Boolean);
- -- Check if an imported or extended project if also a library project
-
- procedure Check_Aggregate_Library_Dirs;
- -- Check that the library directory and the library ALI directory of an
- -- aggregate library project are not the same as the object directory or
- -- the library directory of any of its aggregated projects.
-
- ----------------------------------
- -- Check_Aggregate_Library_Dirs --
- ----------------------------------
-
- procedure Check_Aggregate_Library_Dirs is
- procedure Process_Aggregate (Proj : Project_Id);
- -- Recursive procedure to check the aggregated projects, as they may
- -- also be aggregated library projects.
-
- -----------------------
- -- Process_Aggregate --
- -----------------------
-
- procedure Process_Aggregate (Proj : Project_Id) is
- Agg : Aggregated_Project_List;
-
- begin
- Agg := Proj.Aggregated_Projects;
- while Agg /= null loop
- Error_Msg_Name_1 := Agg.Project.Name;
-
- if Agg.Project.Qualifier /= Aggregate_Library
- and then Project.Library_ALI_Dir.Name =
- Agg.Project.Object_Directory.Name
- then
- Error_Msg
- (Data.Flags,
- "aggregate library 'A'L'I directory cannot be shared with"
- & " object directory of aggregated project %%",
- The_Lib_Kind.Location, Project);
-
- elsif Project.Library_ALI_Dir.Name =
- Agg.Project.Library_Dir.Name
- then
- Error_Msg
- (Data.Flags,
- "aggregate library 'A'L'I directory cannot be shared with"
- & " library directory of aggregated project %%",
- The_Lib_Kind.Location, Project);
-
- elsif Agg.Project.Qualifier /= Aggregate_Library
- and then Project.Library_Dir.Name =
- Agg.Project.Object_Directory.Name
- then
- Error_Msg
- (Data.Flags,
- "aggregate library directory cannot be shared with"
- & " object directory of aggregated project %%",
- The_Lib_Kind.Location, Project);
-
- elsif Project.Library_Dir.Name =
- Agg.Project.Library_Dir.Name
- then
- Error_Msg
- (Data.Flags,
- "aggregate library directory cannot be shared with"
- & " library directory of aggregated project %%",
- The_Lib_Kind.Location, Project);
- end if;
-
- if Agg.Project.Qualifier = Aggregate_Library then
- Process_Aggregate (Agg.Project);
- end if;
-
- Agg := Agg.Next;
- end loop;
- end Process_Aggregate;
-
- -- Start of processing for Check_Aggregate_Library_Dirs
-
- begin
- if Project.Qualifier = Aggregate_Library then
- Process_Aggregate (Project);
- end if;
- end Check_Aggregate_Library_Dirs;
-
- -------------------
- -- Check_Library --
- -------------------
-
- procedure Check_Library (Proj : Project_Id; Extends : Boolean) is
- Src_Id : Source_Id;
- Iter : Source_Iterator;
-
- begin
- if Proj /= No_Project then
- if not Proj.Library then
-
- -- The only not library projects that are OK are those that
- -- have no sources. However, header files from non-Ada
- -- languages are OK, as there is nothing to compile.
-
- Iter := For_Each_Source (Data.Tree, Proj);
- loop
- Src_Id := Prj.Element (Iter);
- exit when Src_Id = No_Source
- or else Src_Id.Language.Config.Kind /= File_Based
- or else Src_Id.Kind /= Spec;
- Next (Iter);
- end loop;
-
- if Src_Id /= No_Source then
- Error_Msg_Name_1 := Project.Name;
- Error_Msg_Name_2 := Proj.Name;
-
- if Extends then
- if Project.Library_Kind /= Static then
- Error_Msg
- (Data.Flags,
- Continuation.all &
- "shared library project %% cannot extend " &
- "project %% that is not a library project",
- Project.Location, Project);
- Continuation := Continuation_String'Access;
- end if;
-
- elsif not Unchecked_Shared_Lib_Imports
- and then Project.Library_Kind /= Static
- then
- Error_Msg
- (Data.Flags,
- Continuation.all &
- "shared library project %% cannot import project %% " &
- "that is not a shared library project",
- Project.Location, Project);
- Continuation := Continuation_String'Access;
- end if;
- end if;
-
- elsif Project.Library_Kind /= Static
- and then not Lib_Standalone.Default
- and then Get_Name_String (Lib_Standalone.Value) = "encapsulated"
- and then Proj.Library_Kind /= Static
- then
- -- An encapsulated library must depend only on static libraries
-
- Error_Msg_Name_1 := Project.Name;
- Error_Msg_Name_2 := Proj.Name;
-
- Error_Msg
- (Data.Flags,
- Continuation.all &
- "encapsulated library project %% cannot import shared " &
- "library project %%",
- Project.Location, Project);
- Continuation := Continuation_String'Access;
-
- elsif Project.Library_Kind /= Static
- and then Proj.Library_Kind = Static
- and then
- (Lib_Standalone.Default
- or else
- Get_Name_String (Lib_Standalone.Value) /= "encapsulated")
- then
- Error_Msg_Name_1 := Project.Name;
- Error_Msg_Name_2 := Proj.Name;
-
- if Extends then
- Error_Msg
- (Data.Flags,
- Continuation.all &
- "shared library project %% cannot extend static " &
- "library project %%",
- Project.Location, Project);
- Continuation := Continuation_String'Access;
-
- elsif not Unchecked_Shared_Lib_Imports then
- Error_Msg
- (Data.Flags,
- Continuation.all &
- "shared library project %% cannot import static " &
- "library project %%",
- Project.Location, Project);
- Continuation := Continuation_String'Access;
- end if;
-
- end if;
- end if;
- end Check_Library;
-
- Dir_Exists : Boolean;
-
- -- Start of processing for Check_Library_Attributes
-
- begin
- Library_Directory_Present := Lib_Dir.Value /= Empty_String;
-
- -- Special case of extending project
-
- if Project.Extends /= No_Project then
-
- -- If the project extended is a library project, we inherit the
- -- library name, if it is not redefined; we check that the library
- -- directory is specified.
-
- if Project.Extends.Library then
- if Project.Qualifier = Standard then
- Error_Msg
- (Data.Flags,
- "a standard project cannot extend a library project",
- Project.Location, Project);
-
- else
- if Lib_Name.Default then
- Project.Library_Name := Project.Extends.Library_Name;
- end if;
-
- if Lib_Dir.Default then
- if not Project.Virtual then
- Error_Msg
- (Data.Flags,
- "a project extending a library project must " &
- "specify an attribute Library_Dir",
- Project.Location, Project);
-
- else
- -- For a virtual project extending a library project,
- -- inherit library directory and library kind.
-
- Project.Library_Dir := Project.Extends.Library_Dir;
- Library_Directory_Present := True;
- Project.Library_Kind := Project.Extends.Library_Kind;
- end if;
- end if;
- end if;
- end if;
- end if;
-
- pragma Assert (Lib_Name.Kind = Single);
-
- if Lib_Name.Value = Empty_String then
- if Current_Verbosity = High
- and then Project.Library_Name = No_Name
- then
- Debug_Indent;
- Write_Line ("no library name");
- end if;
-
- else
- -- There is no restriction on the syntax of library names
-
- Project.Library_Name := Lib_Name.Value;
- end if;
-
- if Project.Library_Name /= No_Name then
- if Current_Verbosity = High then
- Write_Attr
- ("Library name: ", Get_Name_String (Project.Library_Name));
- end if;
-
- pragma Assert (Lib_Dir.Kind = Single);
-
- if not Library_Directory_Present then
- Debug_Output ("no library directory");
-
- else
- -- Find path name (unless inherited), check that it is a directory
-
- if Project.Library_Dir = No_Path_Information then
- Locate_Directory
- (Project,
- File_Name_Type (Lib_Dir.Value),
- Path => Project.Library_Dir,
- Dir_Exists => Dir_Exists,
- Data => Data,
- Create => "library",
- Must_Exist => False,
- Location => Lib_Dir.Location,
- Externally_Built => Project.Externally_Built);
-
- else
- Dir_Exists :=
- Is_Directory
- (Get_Name_String (Project.Library_Dir.Display_Name));
- end if;
-
- if not Dir_Exists then
- if Directories_Must_Exist_In_Projects then
-
- -- Get the absolute name of the library directory that does
- -- not exist, to report an error.
-
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Project.Library_Dir.Display_Name);
- Error_Msg
- (Data.Flags,
- "library directory { does not exist",
- Lib_Dir.Location, Project);
- end if;
-
- -- Checks for object/source directories
-
- elsif not Project.Externally_Built
-
- -- An aggregate library does not have sources or objects, so
- -- these tests are not required in this case.
-
- and then Project.Qualifier /= Aggregate_Library
- then
- -- Library directory cannot be the same as Object directory
-
- if Project.Library_Dir.Name = Project.Object_Directory.Name then
- Error_Msg
- (Data.Flags,
- "library directory cannot be the same " &
- "as object directory",
- Lib_Dir.Location, Project);
- Project.Library_Dir := No_Path_Information;
-
- else
- declare
- OK : Boolean := True;
- Dirs_Id : String_List_Id;
- Dir_Elem : String_Element;
- Pid : Project_List;
-
- begin
- -- The library directory cannot be the same as a source
- -- directory of the current project.
-
- Dirs_Id := Project.Source_Dirs;
- while Dirs_Id /= Nil_String loop
- Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
- Dirs_Id := Dir_Elem.Next;
-
- if Project.Library_Dir.Name =
- Path_Name_Type (Dir_Elem.Value)
- then
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Dir_Elem.Value);
- Error_Msg
- (Data.Flags,
- "library directory cannot be the same "
- & "as source directory {",
- Lib_Dir.Location, Project);
- OK := False;
- exit;
- end if;
- end loop;
-
- if OK then
-
- -- The library directory cannot be the same as a
- -- source directory of another project either.
-
- Pid := Data.Tree.Projects;
- Project_Loop : loop
- exit Project_Loop when Pid = null;
-
- if Pid.Project /= Project then
- Dirs_Id := Pid.Project.Source_Dirs;
-
- Dir_Loop : while Dirs_Id /= Nil_String loop
- Dir_Elem :=
- Shared.String_Elements.Table (Dirs_Id);
- Dirs_Id := Dir_Elem.Next;
-
- if Project.Library_Dir.Name =
- Path_Name_Type (Dir_Elem.Value)
- then
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Dir_Elem.Value);
- Err_Vars.Error_Msg_Name_1 :=
- Pid.Project.Name;
-
- Error_Msg
- (Data.Flags,
- "library directory cannot be the same "
- & "as source directory { of project %%",
- Lib_Dir.Location, Project);
- OK := False;
- exit Project_Loop;
- end if;
- end loop Dir_Loop;
- end if;
-
- Pid := Pid.Next;
- end loop Project_Loop;
- end if;
-
- if not OK then
- Project.Library_Dir := No_Path_Information;
-
- elsif Current_Verbosity = High then
-
- -- Display the Library directory in high verbosity
-
- Write_Attr
- ("Library directory",
- Get_Name_String (Project.Library_Dir.Display_Name));
- end if;
- end;
- end if;
- end if;
- end if;
-
- end if;
-
- Project.Library :=
- Project.Library_Dir /= No_Path_Information
- and then Project.Library_Name /= No_Name;
-
- if Project.Extends = No_Project then
- case Project.Qualifier is
- when Standard =>
- if Project.Library then
- Error_Msg
- (Data.Flags,
- "a standard project cannot be a library project",
- Lib_Name.Location, Project);
- end if;
-
- when Aggregate_Library
- | Library
- =>
- if not Project.Library then
- if Project.Library_Name = No_Name then
- Error_Msg
- (Data.Flags,
- "attribute Library_Name not declared",
- Project.Location, Project);
-
- if not Library_Directory_Present then
- Error_Msg
- (Data.Flags,
- "\attribute Library_Dir not declared",
- Project.Location, Project);
- end if;
-
- elsif Project.Library_Dir = No_Path_Information then
- Error_Msg
- (Data.Flags,
- "attribute Library_Dir not declared",
- Project.Location, Project);
- end if;
- end if;
-
- when others =>
- null;
- end case;
- end if;
-
- if Project.Library then
- Support_For_Libraries := Project.Config.Lib_Support;
-
- if not Project.Externally_Built
- and then Support_For_Libraries = Prj.None
- then
- Error_Msg
- (Data.Flags,
- "?libraries are not supported on this platform",
- Lib_Name.Location, Project);
- Project.Library := False;
-
- else
- if Lib_ALI_Dir.Value = Empty_String then
- Debug_Output ("no library ALI directory specified");
- Project.Library_ALI_Dir := Project.Library_Dir;
-
- else
- -- Find path name, check that it is a directory
-
- Locate_Directory
- (Project,
- File_Name_Type (Lib_ALI_Dir.Value),
- Path => Project.Library_ALI_Dir,
- Create => "library ALI",
- Dir_Exists => Dir_Exists,
- Data => Data,
- Must_Exist => False,
- Location => Lib_ALI_Dir.Location,
- Externally_Built => Project.Externally_Built);
-
- if not Dir_Exists then
-
- -- Get the absolute name of the library ALI directory that
- -- does not exist, to report an error.
-
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Project.Library_ALI_Dir.Display_Name);
- Error_Msg
- (Data.Flags,
- "library 'A'L'I directory { does not exist",
- Lib_ALI_Dir.Location, Project);
- end if;
-
- if not Project.Externally_Built
- and then Project.Library_ALI_Dir /= Project.Library_Dir
- then
- -- The library ALI directory cannot be the same as the
- -- Object directory.
-
- if Project.Library_ALI_Dir = Project.Object_Directory then
- Error_Msg
- (Data.Flags,
- "library 'A'L'I directory cannot be the same " &
- "as object directory",
- Lib_ALI_Dir.Location, Project);
- Project.Library_ALI_Dir := No_Path_Information;
-
- else
- declare
- OK : Boolean := True;
- Dirs_Id : String_List_Id;
- Dir_Elem : String_Element;
- Pid : Project_List;
-
- begin
- -- The library ALI directory cannot be the same as
- -- a source directory of the current project.
-
- Dirs_Id := Project.Source_Dirs;
- while Dirs_Id /= Nil_String loop
- Dir_Elem := Shared.String_Elements.Table (Dirs_Id);
- Dirs_Id := Dir_Elem.Next;
-
- if Project.Library_ALI_Dir.Name =
- Path_Name_Type (Dir_Elem.Value)
- then
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Dir_Elem.Value);
- Error_Msg
- (Data.Flags,
- "library 'A'L'I directory cannot be " &
- "the same as source directory {",
- Lib_ALI_Dir.Location, Project);
- OK := False;
- exit;
- end if;
- end loop;
-
- if OK then
-
- -- The library ALI directory cannot be the same as
- -- a source directory of another project either.
-
- Pid := Data.Tree.Projects;
- ALI_Project_Loop : loop
- exit ALI_Project_Loop when Pid = null;
-
- if Pid.Project /= Project then
- Dirs_Id := Pid.Project.Source_Dirs;
-
- ALI_Dir_Loop :
- while Dirs_Id /= Nil_String loop
- Dir_Elem :=
- Shared.String_Elements.Table (Dirs_Id);
- Dirs_Id := Dir_Elem.Next;
-
- if Project.Library_ALI_Dir.Name =
- Path_Name_Type (Dir_Elem.Value)
- then
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Dir_Elem.Value);
- Err_Vars.Error_Msg_Name_1 :=
- Pid.Project.Name;
-
- Error_Msg
- (Data.Flags,
- "library 'A'L'I directory cannot " &
- "be the same as source directory " &
- "{ of project %%",
- Lib_ALI_Dir.Location, Project);
- OK := False;
- exit ALI_Project_Loop;
- end if;
- end loop ALI_Dir_Loop;
- end if;
- Pid := Pid.Next;
- end loop ALI_Project_Loop;
- end if;
-
- if not OK then
- Project.Library_ALI_Dir := No_Path_Information;
-
- elsif Current_Verbosity = High then
-
- -- Display Library ALI directory in high verbosity
-
- Write_Attr
- ("Library ALI dir",
- Get_Name_String
- (Project.Library_ALI_Dir.Display_Name));
- end if;
- end;
- end if;
- end if;
- end if;
-
- pragma Assert (Lib_Version.Kind = Single);
-
- if Lib_Version.Value = Empty_String then
- Debug_Output ("no library version specified");
-
- else
- Project.Lib_Internal_Name := Lib_Version.Value;
- end if;
-
- pragma Assert (The_Lib_Kind.Kind = Single);
-
- if The_Lib_Kind.Value = Empty_String then
- Debug_Output ("no library kind specified");
-
- else
- Get_Name_String (The_Lib_Kind.Value);
-
- declare
- Kind_Name : constant String :=
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- OK : Boolean := True;
-
- begin
- if Kind_Name = "static" then
- Project.Library_Kind := Static;
-
- elsif Kind_Name = "dynamic" then
- Project.Library_Kind := Dynamic;
-
- elsif Kind_Name = "relocatable" then
- Project.Library_Kind := Relocatable;
-
- else
- Error_Msg
- (Data.Flags,
- "illegal value for Library_Kind",
- The_Lib_Kind.Location, Project);
- OK := False;
- end if;
-
- if Current_Verbosity = High and then OK then
- Write_Attr ("Library kind", Kind_Name);
- end if;
-
- if Project.Library_Kind /= Static then
- if not Project.Externally_Built
- and then Support_For_Libraries = Prj.Static_Only
- then
- Error_Msg
- (Data.Flags,
- "only static libraries are supported " &
- "on this platform",
- The_Lib_Kind.Location, Project);
- Project.Library := False;
-
- else
- -- Check if (obsolescent) attribute Library_GCC or
- -- Linker'Driver is declared.
-
- if Lib_GCC.Value /= Empty_String then
- Error_Msg
- (Data.Flags,
- "?Library_'G'C'C is an obsolescent attribute, " &
- "use Linker''Driver instead",
- Lib_GCC.Location, Project);
- Project.Config.Shared_Lib_Driver :=
- File_Name_Type (Lib_GCC.Value);
-
- else
- declare
- Linker : constant Package_Id :=
- Value_Of
- (Name_Linker,
- Project.Decl.Packages,
- Shared);
- Driver : constant Variable_Value :=
- Value_Of
- (Name => No_Name,
- Attribute_Or_Array_Name =>
- Name_Driver,
- In_Package => Linker,
- Shared => Shared);
-
- begin
- if Driver /= Nil_Variable_Value
- and then Driver.Value /= Empty_String
- then
- Project.Config.Shared_Lib_Driver :=
- File_Name_Type (Driver.Value);
- end if;
- end;
- end if;
- end if;
- end if;
- end;
- end if;
-
- if Project.Library
- and then Project.Qualifier /= Aggregate_Library
- then
- Debug_Output ("this is a library project file");
-
- Check_Library (Project.Extends, Extends => True);
-
- Imported_Project_List := Project.Imported_Projects;
- while Imported_Project_List /= null loop
- Check_Library
- (Imported_Project_List.Project,
- Extends => False);
- Imported_Project_List := Imported_Project_List.Next;
- end loop;
- end if;
- end if;
- end if;
-
- -- Check if Linker'Switches or Linker'Default_Switches are declared.
- -- Warn if they are declared, as it is a common error to think that
- -- library are "linked" with Linker switches.
-
- if Project.Library then
- declare
- Linker_Package_Id : constant Package_Id :=
- Util.Value_Of
- (Name_Linker,
- Project.Decl.Packages, Shared);
- Linker_Package : Package_Element;
- Switches : Array_Element_Id := No_Array_Element;
-
- begin
- if Linker_Package_Id /= No_Package then
- Linker_Package := Shared.Packages.Table (Linker_Package_Id);
-
- Switches :=
- Value_Of
- (Name => Name_Switches,
- In_Arrays => Linker_Package.Decl.Arrays,
- Shared => Shared);
-
- if Switches = No_Array_Element then
- Switches :=
- Value_Of
- (Name => Name_Default_Switches,
- In_Arrays => Linker_Package.Decl.Arrays,
- Shared => Shared);
- end if;
-
- if Switches /= No_Array_Element then
- Error_Msg
- (Data.Flags,
- "?\Linker switches not taken into account in library " &
- "projects",
- No_Location, Project);
- end if;
- end if;
- end;
- end if;
-
- if Project.Extends /= No_Project and then Project.Extends.Library then
-
- -- Remove the library name from Lib_Data_Table
-
- for J in 1 .. Lib_Data_Table.Last loop
- if Lib_Data_Table.Table (J).Proj = Project.Extends then
- Lib_Data_Table.Table (J) :=
- Lib_Data_Table.Table (Lib_Data_Table.Last);
- Lib_Data_Table.Set_Last (Lib_Data_Table.Last - 1);
- exit;
- end if;
- end loop;
- end if;
-
- if Project.Library and then not Lib_Name.Default then
-
- -- Check if the same library name is used in an other library project
-
- for J in 1 .. Lib_Data_Table.Last loop
- if Lib_Data_Table.Table (J).Name = Project.Library_Name
- and then Lib_Data_Table.Table (J).Tree = Data.Tree
- then
- Error_Msg_Name_1 := Lib_Data_Table.Table (J).Proj.Name;
- Error_Msg
- (Data.Flags,
- "Library name cannot be the same as in project %%",
- Lib_Name.Location, Project);
- Project.Library := False;
- exit;
- end if;
- end loop;
- end if;
-
- if not Lib_Standalone.Default
- and then Project.Library_Kind = Static
- then
- -- An standalone library must be a shared library
-
- Error_Msg_Name_1 := Project.Name;
-
- Error_Msg
- (Data.Flags,
- Continuation.all &
- "standalone library project %% must be a shared library",
- Project.Location, Project);
- Continuation := Continuation_String'Access;
- end if;
-
- -- Check that aggregated libraries do not share the aggregate
- -- Library_ALI_Dir.
-
- if Project.Qualifier = Aggregate_Library then
- Check_Aggregate_Library_Dirs;
- end if;
-
- if Project.Library and not Data.In_Aggregate_Lib then
-
- -- Record the library name
-
- Lib_Data_Table.Append
- ((Name => Project.Library_Name,
- Proj => Project,
- Tree => Data.Tree));
- end if;
- end Check_Library_Attributes;
-
- --------------------------
- -- Check_Package_Naming --
- --------------------------
-
- procedure Check_Package_Naming
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
- Naming_Id : constant Package_Id :=
- Util.Value_Of
- (Name_Naming, Project.Decl.Packages, Shared);
- Naming : Package_Element;
-
- Ada_Body_Suffix_Loc : Source_Ptr := No_Location;
-
- procedure Check_Naming;
- -- Check the validity of the Naming package (suffixes valid, ...)
-
- procedure Check_Common
- (Dot_Replacement : in out File_Name_Type;
- Casing : in out Casing_Type;
- Casing_Defined : out Boolean;
- Separate_Suffix : in out File_Name_Type;
- Sep_Suffix_Loc : out Source_Ptr);
- -- Check attributes common
-
- procedure Process_Exceptions_File_Based
- (Lang_Id : Language_Ptr;
- Kind : Source_Kind);
- procedure Process_Exceptions_Unit_Based
- (Lang_Id : Language_Ptr;
- Kind : Source_Kind);
- -- Process the naming exceptions for the two types of languages
-
- procedure Initialize_Naming_Data;
- -- Initialize internal naming data for the various languages
-
- ------------------
- -- Check_Common --
- ------------------
-
- procedure Check_Common
- (Dot_Replacement : in out File_Name_Type;
- Casing : in out Casing_Type;
- Casing_Defined : out Boolean;
- Separate_Suffix : in out File_Name_Type;
- Sep_Suffix_Loc : out Source_Ptr)
- is
- Dot_Repl : constant Variable_Value :=
- Util.Value_Of
- (Name_Dot_Replacement,
- Naming.Decl.Attributes,
- Shared);
- Casing_String : constant Variable_Value :=
- Util.Value_Of
- (Name_Casing,
- Naming.Decl.Attributes,
- Shared);
- Sep_Suffix : constant Variable_Value :=
- Util.Value_Of
- (Name_Separate_Suffix,
- Naming.Decl.Attributes,
- Shared);
- Dot_Repl_Loc : Source_Ptr;
-
- begin
- Sep_Suffix_Loc := No_Location;
-
- if not Dot_Repl.Default then
- pragma Assert
- (Dot_Repl.Kind = Single, "Dot_Replacement is not a string");
-
- if Length_Of_Name (Dot_Repl.Value) = 0 then
- Error_Msg
- (Data.Flags, "Dot_Replacement cannot be empty",
- Dot_Repl.Location, Project);
- end if;
-
- Dot_Replacement := Canonical_Case_File_Name (Dot_Repl.Value);
- Dot_Repl_Loc := Dot_Repl.Location;
-
- declare
- Repl : constant String := Get_Name_String (Dot_Replacement);
-
- begin
- -- Dot_Replacement cannot
- -- - be empty
- -- - start or end with an alphanumeric
- -- - be a single '_'
- -- - start with an '_' followed by an alphanumeric
- -- - contain a '.' except if it is "."
-
- if Repl'Length = 0
- or else Is_Alphanumeric (Repl (Repl'First))
- or else Is_Alphanumeric (Repl (Repl'Last))
- or else (Repl (Repl'First) = '_'
- and then
- (Repl'Length = 1
- or else
- Is_Alphanumeric (Repl (Repl'First + 1))))
- or else (Repl'Length > 1
- and then
- Index (Source => Repl, Pattern => ".") /= 0)
- then
- Error_Msg
- (Data.Flags,
- '"' & Repl &
- """ is illegal for Dot_Replacement.",
- Dot_Repl_Loc, Project);
- end if;
- end;
- end if;
-
- if Dot_Replacement /= No_File then
- Write_Attr
- ("Dot_Replacement", Get_Name_String (Dot_Replacement));
- end if;
-
- Casing_Defined := False;
-
- if not Casing_String.Default then
- pragma Assert
- (Casing_String.Kind = Single, "Casing is not a string");
-
- declare
- Casing_Image : constant String :=
- Get_Name_String (Casing_String.Value);
-
- begin
- if Casing_Image'Length = 0 then
- Error_Msg
- (Data.Flags,
- "Casing cannot be an empty string",
- Casing_String.Location, Project);
- end if;
-
- Casing := Value (Casing_Image);
- Casing_Defined := True;
-
- exception
- when Constraint_Error =>
- Name_Len := Casing_Image'Length;
- Name_Buffer (1 .. Name_Len) := Casing_Image;
- Err_Vars.Error_Msg_Name_1 := Name_Find;
- Error_Msg
- (Data.Flags,
- "%% is not a correct Casing",
- Casing_String.Location, Project);
- end;
- end if;
-
- Write_Attr ("Casing", Image (Casing));
-
- if not Sep_Suffix.Default then
- if Length_Of_Name (Sep_Suffix.Value) = 0 then
- Error_Msg
- (Data.Flags,
- "Separate_Suffix cannot be empty",
- Sep_Suffix.Location, Project);
-
- else
- Separate_Suffix := Canonical_Case_File_Name (Sep_Suffix.Value);
- Sep_Suffix_Loc := Sep_Suffix.Location;
-
- Check_Illegal_Suffix
- (Project, Separate_Suffix,
- Dot_Replacement, "Separate_Suffix", Sep_Suffix.Location,
- Data);
- end if;
- end if;
-
- if Separate_Suffix /= No_File then
- Write_Attr
- ("Separate_Suffix", Get_Name_String (Separate_Suffix));
- end if;
- end Check_Common;
-
- -----------------------------------
- -- Process_Exceptions_File_Based --
- -----------------------------------
-
- procedure Process_Exceptions_File_Based
- (Lang_Id : Language_Ptr;
- Kind : Source_Kind)
- is
- Lang : constant Name_Id := Lang_Id.Name;
- Exceptions : Array_Element_Id;
- Exception_List : Variable_Value;
- Element_Id : String_List_Id;
- Element : String_Element;
- File_Name : File_Name_Type;
- Source : Source_Id;
-
- begin
- case Kind is
- when Impl
- | Sep
- =>
- Exceptions :=
- Value_Of
- (Name_Implementation_Exceptions,
- In_Arrays => Naming.Decl.Arrays,
- Shared => Shared);
-
- when Spec =>
- Exceptions :=
- Value_Of
- (Name_Specification_Exceptions,
- In_Arrays => Naming.Decl.Arrays,
- Shared => Shared);
- end case;
-
- Exception_List :=
- Value_Of
- (Index => Lang,
- In_Array => Exceptions,
- Shared => Shared);
-
- if Exception_List /= Nil_Variable_Value then
- Element_Id := Exception_List.Values;
- while Element_Id /= Nil_String loop
- Element := Shared.String_Elements.Table (Element_Id);
- File_Name := Canonical_Case_File_Name (Element.Value);
-
- Source :=
- Source_Files_Htable.Get
- (Data.Tree.Source_Files_HT, File_Name);
- while Source /= No_Source
- and then Source.Project /= Project
- loop
- Source := Source.Next_With_File_Name;
- end loop;
-
- if Source = No_Source then
- Add_Source
- (Id => Source,
- Data => Data,
- Project => Project,
- Source_Dir_Rank => 0,
- Lang_Id => Lang_Id,
- Kind => Kind,
- File_Name => File_Name,
- Display_File => File_Name_Type (Element.Value),
- Naming_Exception => Yes,
- Location => Element.Location);
-
- else
- -- Check if the file name is already recorded for another
- -- language or another kind.
-
- if Source.Language /= Lang_Id then
- Error_Msg
- (Data.Flags,
- "the same file cannot be a source of two languages",
- Element.Location, Project);
-
- elsif Source.Kind /= Kind then
- Error_Msg
- (Data.Flags,
- "the same file cannot be a source and a template",
- Element.Location, Project);
- end if;
-
- -- If the file is already recorded for the same
- -- language and the same kind, it means that the file
- -- name appears several times in the *_Exceptions
- -- attribute; so there is nothing to do.
- end if;
-
- Element_Id := Element.Next;
- end loop;
- end if;
- end Process_Exceptions_File_Based;
-
- -----------------------------------
- -- Process_Exceptions_Unit_Based --
- -----------------------------------
-
- procedure Process_Exceptions_Unit_Based
- (Lang_Id : Language_Ptr;
- Kind : Source_Kind)
- is
- Exceptions : Array_Element_Id;
- Element : Array_Element;
- Unit : Name_Id;
- Index : Int;
- File_Name : File_Name_Type;
- Source : Source_Id;
-
- Naming_Exception : Naming_Exception_Type;
-
- begin
- case Kind is
- when Impl
- | Sep
- =>
- Exceptions :=
- Value_Of
- (Name_Body,
- In_Arrays => Naming.Decl.Arrays,
- Shared => Shared);
-
- if Exceptions = No_Array_Element then
- Exceptions :=
- Value_Of
- (Name_Implementation,
- In_Arrays => Naming.Decl.Arrays,
- Shared => Shared);
- end if;
-
- when Spec =>
- Exceptions :=
- Value_Of
- (Name_Spec,
- In_Arrays => Naming.Decl.Arrays,
- Shared => Shared);
-
- if Exceptions = No_Array_Element then
- Exceptions :=
- Value_Of
- (Name_Specification,
- In_Arrays => Naming.Decl.Arrays,
- Shared => Shared);
- end if;
- end case;
-
- while Exceptions /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Exceptions);
-
- if Element.Restricted then
- Naming_Exception := Inherited;
- else
- Naming_Exception := Yes;
- end if;
-
- File_Name := Canonical_Case_File_Name (Element.Value.Value);
-
- Get_Name_String (Element.Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Index := Element.Value.Index;
-
- -- Check if it is a valid unit name
-
- Get_Name_String (Element.Index);
- Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
-
- if Unit = No_Name then
- Err_Vars.Error_Msg_Name_1 := Element.Index;
- Error_Msg
- (Data.Flags,
- "%% is not a valid unit name.",
- Element.Value.Location, Project);
- end if;
-
- if Unit /= No_Name then
- Add_Source
- (Id => Source,
- Data => Data,
- Project => Project,
- Source_Dir_Rank => 0,
- Lang_Id => Lang_Id,
- Kind => Kind,
- File_Name => File_Name,
- Display_File => File_Name_Type (Element.Value.Value),
- Unit => Unit,
- Index => Index,
- Location => Element.Value.Location,
- Naming_Exception => Naming_Exception);
- end if;
-
- Exceptions := Element.Next;
- end loop;
- end Process_Exceptions_Unit_Based;
-
- ------------------
- -- Check_Naming --
- ------------------
-
- procedure Check_Naming is
- Dot_Replacement : File_Name_Type :=
- File_Name_Type
- (First_Name_Id + Character'Pos ('-'));
- Separate_Suffix : File_Name_Type := No_File;
- Casing : Casing_Type := All_Lower_Case;
- Casing_Defined : Boolean;
- Lang_Id : Language_Ptr;
- Sep_Suffix_Loc : Source_Ptr;
- Suffix : Variable_Value;
- Lang : Name_Id;
-
- begin
- Check_Common
- (Dot_Replacement => Dot_Replacement,
- Casing => Casing,
- Casing_Defined => Casing_Defined,
- Separate_Suffix => Separate_Suffix,
- Sep_Suffix_Loc => Sep_Suffix_Loc);
-
- -- For all unit based languages, if any, set the specified value
- -- of Dot_Replacement, Casing and/or Separate_Suffix. Do not
- -- systematically overwrite, since the defaults come from the
- -- configuration file.
-
- if Dot_Replacement /= No_File
- or else Casing_Defined
- or else Separate_Suffix /= No_File
- then
- Lang_Id := Project.Languages;
- while Lang_Id /= No_Language_Index loop
- if Lang_Id.Config.Kind = Unit_Based then
- if Dot_Replacement /= No_File then
- Lang_Id.Config.Naming_Data.Dot_Replacement :=
- Dot_Replacement;
- end if;
-
- if Casing_Defined then
- Lang_Id.Config.Naming_Data.Casing := Casing;
- end if;
- end if;
-
- Lang_Id := Lang_Id.Next;
- end loop;
- end if;
-
- -- Next, get the spec and body suffixes
-
- Lang_Id := Project.Languages;
- while Lang_Id /= No_Language_Index loop
- Lang := Lang_Id.Name;
-
- -- Spec_Suffix
-
- Suffix := Value_Of
- (Name => Lang,
- Attribute_Or_Array_Name => Name_Spec_Suffix,
- In_Package => Naming_Id,
- Shared => Shared);
-
- if Suffix = Nil_Variable_Value then
- Suffix := Value_Of
- (Name => Lang,
- Attribute_Or_Array_Name => Name_Specification_Suffix,
- In_Package => Naming_Id,
- Shared => Shared);
- end if;
-
- if Suffix /= Nil_Variable_Value
- and then Suffix.Value /= No_Name
- then
- Lang_Id.Config.Naming_Data.Spec_Suffix :=
- File_Name_Type (Suffix.Value);
-
- Check_Illegal_Suffix
- (Project,
- Lang_Id.Config.Naming_Data.Spec_Suffix,
- Lang_Id.Config.Naming_Data.Dot_Replacement,
- "Spec_Suffix", Suffix.Location, Data);
-
- Write_Attr
- ("Spec_Suffix",
- Get_Name_String (Lang_Id.Config.Naming_Data.Spec_Suffix));
- end if;
-
- -- Body_Suffix
-
- Suffix :=
- Value_Of
- (Name => Lang,
- Attribute_Or_Array_Name => Name_Body_Suffix,
- In_Package => Naming_Id,
- Shared => Shared);
-
- if Suffix = Nil_Variable_Value then
- Suffix :=
- Value_Of
- (Name => Lang,
- Attribute_Or_Array_Name => Name_Implementation_Suffix,
- In_Package => Naming_Id,
- Shared => Shared);
- end if;
-
- if Suffix /= Nil_Variable_Value
- and then Suffix.Value /= No_Name
- then
- Lang_Id.Config.Naming_Data.Body_Suffix :=
- File_Name_Type (Suffix.Value);
-
- -- The default value of separate suffix should be the same as
- -- the body suffix, so we need to compute that first.
-
- if Separate_Suffix = No_File then
- Lang_Id.Config.Naming_Data.Separate_Suffix :=
- Lang_Id.Config.Naming_Data.Body_Suffix;
- Write_Attr
- ("Sep_Suffix",
- Get_Name_String
- (Lang_Id.Config.Naming_Data.Separate_Suffix));
- else
- Lang_Id.Config.Naming_Data.Separate_Suffix :=
- Separate_Suffix;
- end if;
-
- Check_Illegal_Suffix
- (Project,
- Lang_Id.Config.Naming_Data.Body_Suffix,
- Lang_Id.Config.Naming_Data.Dot_Replacement,
- "Body_Suffix", Suffix.Location, Data);
-
- Write_Attr
- ("Body_Suffix",
- Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix));
-
- elsif Separate_Suffix /= No_File then
- Lang_Id.Config.Naming_Data.Separate_Suffix := Separate_Suffix;
- end if;
-
- -- Spec_Suffix cannot be equal to Body_Suffix or Separate_Suffix,
- -- since that would cause a clear ambiguity. Note that we do allow
- -- a Spec_Suffix to have the same termination as one of these,
- -- which causes a potential ambiguity, but we resolve that by
- -- matching the longest possible suffix.
-
- if Lang_Id.Config.Naming_Data.Spec_Suffix /= No_File
- and then Lang_Id.Config.Naming_Data.Spec_Suffix =
- Lang_Id.Config.Naming_Data.Body_Suffix
- then
- Error_Msg
- (Data.Flags,
- "Body_Suffix ("""
- & Get_Name_String (Lang_Id.Config.Naming_Data.Body_Suffix)
- & """) cannot be the same as Spec_Suffix.",
- Ada_Body_Suffix_Loc, Project);
- end if;
-
- if Lang_Id.Config.Naming_Data.Body_Suffix /=
- Lang_Id.Config.Naming_Data.Separate_Suffix
- and then Lang_Id.Config.Naming_Data.Spec_Suffix =
- Lang_Id.Config.Naming_Data.Separate_Suffix
- then
- Error_Msg
- (Data.Flags,
- "Separate_Suffix ("""
- & Get_Name_String
- (Lang_Id.Config.Naming_Data.Separate_Suffix)
- & """) cannot be the same as Spec_Suffix.",
- Sep_Suffix_Loc, Project);
- end if;
-
- Lang_Id := Lang_Id.Next;
- end loop;
-
- -- Get the naming exceptions for all languages, but not for virtual
- -- projects.
-
- if not Project.Virtual then
- for Kind in Spec_Or_Body loop
- Lang_Id := Project.Languages;
- while Lang_Id /= No_Language_Index loop
- case Lang_Id.Config.Kind is
- when File_Based =>
- Process_Exceptions_File_Based (Lang_Id, Kind);
-
- when Unit_Based =>
- Process_Exceptions_Unit_Based (Lang_Id, Kind);
- end case;
-
- Lang_Id := Lang_Id.Next;
- end loop;
- end loop;
- end if;
- end Check_Naming;
-
- ----------------------------
- -- Initialize_Naming_Data --
- ----------------------------
-
- procedure Initialize_Naming_Data is
- Specs : Array_Element_Id :=
- Util.Value_Of
- (Name_Spec_Suffix,
- Naming.Decl.Arrays,
- Shared);
-
- Impls : Array_Element_Id :=
- Util.Value_Of
- (Name_Body_Suffix,
- Naming.Decl.Arrays,
- Shared);
-
- Lang : Language_Ptr;
- Lang_Name : Name_Id;
- Value : Variable_Value;
- Extended : Project_Id;
-
- begin
- -- At this stage, the project already contains the default extensions
- -- for the various languages. We now merge those suffixes read in the
- -- user project, and they override the default.
-
- while Specs /= No_Array_Element loop
- Lang_Name := Shared.Array_Elements.Table (Specs).Index;
- Lang :=
- Get_Language_From_Name
- (Project, Name => Get_Name_String (Lang_Name));
-
- -- An extending project inherits its parent projects' languages
- -- so if needed we should create entries for those languages
-
- if Lang = null then
- Extended := Project.Extends;
- while Extended /= null loop
- Lang := Get_Language_From_Name
- (Extended, Name => Get_Name_String (Lang_Name));
- exit when Lang /= null;
-
- Extended := Extended.Extends;
- end loop;
-
- if Lang /= null then
- Lang := new Language_Data'(Lang.all);
- Lang.First_Source := null;
- Lang.Next := Project.Languages;
- Project.Languages := Lang;
- end if;
- end if;
-
- -- If language was not found in project or the projects it extends
-
- if Lang = null then
- Debug_Output
- ("ignoring spec naming data (lang. not in project): ",
- Lang_Name);
-
- else
- Value := Shared.Array_Elements.Table (Specs).Value;
-
- if Value.Kind = Single then
- Lang.Config.Naming_Data.Spec_Suffix :=
- Canonical_Case_File_Name (Value.Value);
- end if;
- end if;
-
- Specs := Shared.Array_Elements.Table (Specs).Next;
- end loop;
-
- while Impls /= No_Array_Element loop
- Lang_Name := Shared.Array_Elements.Table (Impls).Index;
- Lang :=
- Get_Language_From_Name
- (Project, Name => Get_Name_String (Lang_Name));
-
- if Lang = null then
- Debug_Output
- ("ignoring impl naming data (lang. not in project): ",
- Lang_Name);
- else
- Value := Shared.Array_Elements.Table (Impls).Value;
-
- if Lang.Name = Name_Ada then
- Ada_Body_Suffix_Loc := Value.Location;
- end if;
-
- if Value.Kind = Single then
- Lang.Config.Naming_Data.Body_Suffix :=
- Canonical_Case_File_Name (Value.Value);
- end if;
- end if;
-
- Impls := Shared.Array_Elements.Table (Impls).Next;
- end loop;
- end Initialize_Naming_Data;
-
- -- Start of processing for Check_Naming_Schemes
-
- begin
- -- No Naming package or parsing a configuration file? nothing to do
-
- if Naming_Id /= No_Package
- and then Project.Qualifier /= Configuration
- then
- Naming := Shared.Packages.Table (Naming_Id);
- Debug_Increase_Indent ("checking package Naming for ", Project.Name);
- Initialize_Naming_Data;
- Check_Naming;
- Debug_Decrease_Indent ("done checking package naming");
- end if;
- end Check_Package_Naming;
-
- ---------------------------------
- -- Check_Programming_Languages --
- ---------------------------------
-
- procedure Check_Programming_Languages
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Languages : Variable_Value := Nil_Variable_Value;
- Def_Lang : Variable_Value := Nil_Variable_Value;
- Def_Lang_Id : Name_Id;
-
- procedure Add_Language (Name, Display_Name : Name_Id);
- -- Add a new language to the list of languages for the project.
- -- Nothing is done if the language has already been defined
-
- ------------------
- -- Add_Language --
- ------------------
-
- procedure Add_Language (Name, Display_Name : Name_Id) is
- Lang : Language_Ptr;
-
- begin
- Lang := Project.Languages;
- while Lang /= No_Language_Index loop
- if Name = Lang.Name then
- return;
- end if;
-
- Lang := Lang.Next;
- end loop;
-
- Lang := new Language_Data'(No_Language_Data);
- Lang.Next := Project.Languages;
- Project.Languages := Lang;
- Lang.Name := Name;
- Lang.Display_Name := Display_Name;
- end Add_Language;
-
- -- Start of processing for Check_Programming_Languages
-
- begin
- Project.Languages := null;
- Languages :=
- Prj.Util.Value_Of (Name_Languages, Project.Decl.Attributes, Shared);
- Def_Lang :=
- Prj.Util.Value_Of
- (Name_Default_Language, Project.Decl.Attributes, Shared);
-
- if Project.Source_Dirs /= Nil_String then
-
- -- Check if languages are specified in this project
-
- if Languages.Default then
-
- -- Fail if there is no default language defined
-
- if Def_Lang.Default then
- Error_Msg
- (Data.Flags,
- "no languages defined for this project",
- Project.Location, Project);
- Def_Lang_Id := No_Name;
-
- else
- Get_Name_String (Def_Lang.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Def_Lang_Id := Name_Find;
- end if;
-
- if Def_Lang_Id /= No_Name then
- Get_Name_String (Def_Lang_Id);
- Name_Buffer (1) := GNAT.Case_Util.To_Upper (Name_Buffer (1));
- Add_Language
- (Name => Def_Lang_Id,
- Display_Name => Name_Find);
- end if;
-
- else
- declare
- Current : String_List_Id := Languages.Values;
- Element : String_Element;
-
- begin
- -- If there are no languages declared, there are no sources
-
- if Current = Nil_String then
- Project.Source_Dirs := Nil_String;
-
- if Project.Qualifier = Standard then
- Error_Msg
- (Data.Flags,
- "a standard project must have at least one language",
- Languages.Location, Project);
- end if;
-
- else
- -- Look through all the languages specified in attribute
- -- Languages.
-
- while Current /= Nil_String loop
- Element := Shared.String_Elements.Table (Current);
- Get_Name_String (Element.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- Add_Language
- (Name => Name_Find,
- Display_Name => Element.Value);
-
- Current := Element.Next;
- end loop;
- end if;
- end;
- end if;
- end if;
- end Check_Programming_Languages;
-
- -------------------------------
- -- Check_Stand_Alone_Library --
- -------------------------------
-
- procedure Check_Stand_Alone_Library
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Lib_Name : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Name,
- Project.Decl.Attributes,
- Shared);
-
- Lib_Standalone : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Standalone,
- Project.Decl.Attributes,
- Shared);
-
- Lib_Auto_Init : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Auto_Init,
- Project.Decl.Attributes,
- Shared);
-
- Lib_Src_Dir : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Src_Dir,
- Project.Decl.Attributes,
- Shared);
-
- Lib_Symbol_File : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Symbol_File,
- Project.Decl.Attributes,
- Shared);
-
- Lib_Symbol_Policy : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Symbol_Policy,
- Project.Decl.Attributes,
- Shared);
-
- Lib_Ref_Symbol_File : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Reference_Symbol_File,
- Project.Decl.Attributes,
- Shared);
-
- Auto_Init_Supported : Boolean;
- OK : Boolean := True;
-
- begin
- Auto_Init_Supported := Project.Config.Auto_Init_Supported;
-
- -- It is a stand-alone library project file if there is at least one
- -- unit in the declared or inherited interface.
-
- if Project.Lib_Interface_ALIs = Nil_String then
- if not Lib_Standalone.Default
- and then Get_Name_String (Lib_Standalone.Value) /= "no"
- then
- Error_Msg
- (Data.Flags,
- "Library_Standalone valid only if library has Ada interfaces",
- Lib_Standalone.Location, Project);
- end if;
-
- else
- if Project.Standalone_Library = No then
- Project.Standalone_Library := Standard;
- end if;
-
- -- The name of a stand-alone library needs to have the syntax of an
- -- Ada identifier.
-
- declare
- Name : constant String := Get_Name_String (Project.Library_Name);
- OK : Boolean := Is_Letter (Name (Name'First));
-
- Underline : Boolean := False;
-
- begin
- for J in Name'First + 1 .. Name'Last loop
- exit when not OK;
-
- if Is_Alphanumeric (Name (J)) then
- Underline := False;
-
- elsif Name (J) = '_' then
- if Underline then
- OK := False;
- else
- Underline := True;
- end if;
-
- else
- OK := False;
- end if;
- end loop;
-
- OK := OK and not Underline;
-
- if not OK then
- Error_Msg
- (Data.Flags,
- "Incorrect library name for a Stand-Alone Library",
- Lib_Name.Location, Project);
- return;
- end if;
- end;
-
- if Lib_Standalone.Default then
- Project.Standalone_Library := Standard;
-
- else
- Get_Name_String (Lib_Standalone.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- if Name_Buffer (1 .. Name_Len) = "standard" then
- Project.Standalone_Library := Standard;
-
- elsif Name_Buffer (1 .. Name_Len) = "encapsulated" then
- Project.Standalone_Library := Encapsulated;
-
- elsif Name_Buffer (1 .. Name_Len) = "no" then
- Project.Standalone_Library := No;
- Error_Msg
- (Data.Flags,
- "wrong value for Library_Standalone "
- & "when Library_Interface defined",
- Lib_Standalone.Location, Project);
-
- else
- Error_Msg
- (Data.Flags,
- "invalid value for attribute Library_Standalone",
- Lib_Standalone.Location, Project);
- end if;
- end if;
-
- -- Check value of attribute Library_Auto_Init and set Lib_Auto_Init
- -- accordingly.
-
- if Lib_Auto_Init.Default then
-
- -- If no attribute Library_Auto_Init is declared, then set auto
- -- init only if it is supported.
-
- Project.Lib_Auto_Init := Auto_Init_Supported;
-
- else
- Get_Name_String (Lib_Auto_Init.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- if Name_Buffer (1 .. Name_Len) = "false" then
- Project.Lib_Auto_Init := False;
-
- elsif Name_Buffer (1 .. Name_Len) = "true" then
- if Auto_Init_Supported then
- Project.Lib_Auto_Init := True;
-
- else
- -- Library_Auto_Init cannot be "true" if auto init is not
- -- supported.
-
- Error_Msg
- (Data.Flags,
- "library auto init not supported " &
- "on this platform",
- Lib_Auto_Init.Location, Project);
- end if;
-
- else
- Error_Msg
- (Data.Flags,
- "invalid value for attribute Library_Auto_Init",
- Lib_Auto_Init.Location, Project);
- end if;
- end if;
-
- -- If attribute Library_Src_Dir is defined and not the empty string,
- -- check if the directory exist and is not the object directory or
- -- one of the source directories. This is the directory where copies
- -- of the interface sources will be copied. Note that this directory
- -- may be the library directory.
-
- if Lib_Src_Dir.Value /= Empty_String then
- declare
- Dir_Id : constant File_Name_Type :=
- File_Name_Type (Lib_Src_Dir.Value);
- Dir_Exists : Boolean;
-
- begin
- Locate_Directory
- (Project,
- Dir_Id,
- Path => Project.Library_Src_Dir,
- Dir_Exists => Dir_Exists,
- Data => Data,
- Must_Exist => False,
- Create => "library source copy",
- Location => Lib_Src_Dir.Location,
- Externally_Built => Project.Externally_Built);
-
- -- If directory does not exist, report an error
-
- if not Dir_Exists then
-
- -- Get the absolute name of the library directory that does
- -- not exist, to report an error.
-
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Project.Library_Src_Dir.Display_Name);
- Error_Msg
- (Data.Flags,
- "Directory { does not exist",
- Lib_Src_Dir.Location, Project);
-
- -- Report error if it is the same as the object directory
-
- elsif Project.Library_Src_Dir = Project.Object_Directory then
- Error_Msg
- (Data.Flags,
- "directory to copy interfaces cannot be " &
- "the object directory",
- Lib_Src_Dir.Location, Project);
- Project.Library_Src_Dir := No_Path_Information;
-
- else
- declare
- Src_Dirs : String_List_Id;
- Src_Dir : String_Element;
- Pid : Project_List;
-
- begin
- -- Interface copy directory cannot be one of the source
- -- directory of the current project.
-
- Src_Dirs := Project.Source_Dirs;
- while Src_Dirs /= Nil_String loop
- Src_Dir := Shared.String_Elements.Table (Src_Dirs);
-
- -- Report error if it is one of the source directories
-
- if Project.Library_Src_Dir.Name =
- Path_Name_Type (Src_Dir.Value)
- then
- Error_Msg
- (Data.Flags,
- "directory to copy interfaces cannot " &
- "be one of the source directories",
- Lib_Src_Dir.Location, Project);
- Project.Library_Src_Dir := No_Path_Information;
- exit;
- end if;
-
- Src_Dirs := Src_Dir.Next;
- end loop;
-
- if Project.Library_Src_Dir /= No_Path_Information then
-
- -- It cannot be a source directory of any other
- -- project either.
-
- Pid := Data.Tree.Projects;
- Project_Loop : loop
- exit Project_Loop when Pid = null;
-
- Src_Dirs := Pid.Project.Source_Dirs;
- Dir_Loop : while Src_Dirs /= Nil_String loop
- Src_Dir :=
- Shared.String_Elements.Table (Src_Dirs);
-
- -- Report error if it is one of the source
- -- directories.
-
- if Project.Library_Src_Dir.Name =
- Path_Name_Type (Src_Dir.Value)
- then
- Error_Msg_File_1 :=
- File_Name_Type (Src_Dir.Value);
- Error_Msg_Name_1 := Pid.Project.Name;
- Error_Msg
- (Data.Flags,
- "directory to copy interfaces cannot " &
- "be the same as source directory { of " &
- "project %%",
- Lib_Src_Dir.Location, Project);
- Project.Library_Src_Dir :=
- No_Path_Information;
- exit Project_Loop;
- end if;
-
- Src_Dirs := Src_Dir.Next;
- end loop Dir_Loop;
-
- Pid := Pid.Next;
- end loop Project_Loop;
- end if;
- end;
-
- -- In high verbosity, if there is a valid Library_Src_Dir,
- -- display its path name.
-
- if Project.Library_Src_Dir /= No_Path_Information
- and then Current_Verbosity = High
- then
- Write_Attr
- ("Directory to copy interfaces",
- Get_Name_String (Project.Library_Src_Dir.Name));
- end if;
- end if;
- end;
- end if;
-
- -- Check the symbol related attributes
-
- -- First, the symbol policy
-
- if not Lib_Symbol_Policy.Default then
- declare
- Value : constant String :=
- To_Lower
- (Get_Name_String (Lib_Symbol_Policy.Value));
-
- begin
- -- Symbol policy must have one of a limited number of values
-
- if Value = "autonomous" or else Value = "default" then
- Project.Symbol_Data.Symbol_Policy := Autonomous;
-
- elsif Value = "compliant" then
- Project.Symbol_Data.Symbol_Policy := Compliant;
-
- elsif Value = "controlled" then
- Project.Symbol_Data.Symbol_Policy := Controlled;
-
- elsif Value = "restricted" then
- Project.Symbol_Data.Symbol_Policy := Restricted;
-
- elsif Value = "direct" then
- Project.Symbol_Data.Symbol_Policy := Direct;
-
- else
- Error_Msg
- (Data.Flags,
- "illegal value for Library_Symbol_Policy",
- Lib_Symbol_Policy.Location, Project);
- end if;
- end;
- end if;
-
- -- If attribute Library_Symbol_File is not specified, symbol policy
- -- cannot be Restricted.
-
- if Lib_Symbol_File.Default then
- if Project.Symbol_Data.Symbol_Policy = Restricted then
- Error_Msg
- (Data.Flags,
- "Library_Symbol_File needs to be defined when " &
- "symbol policy is Restricted",
- Lib_Symbol_Policy.Location, Project);
- end if;
-
- else
- -- Library_Symbol_File is defined
-
- Project.Symbol_Data.Symbol_File :=
- Path_Name_Type (Lib_Symbol_File.Value);
-
- Get_Name_String (Lib_Symbol_File.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Data.Flags,
- "symbol file name cannot be an empty string",
- Lib_Symbol_File.Location, Project);
-
- else
- OK := not Is_Absolute_Path (Name_Buffer (1 .. Name_Len));
-
- if OK then
- for J in 1 .. Name_Len loop
- if Is_Directory_Separator (Name_Buffer (J)) then
- OK := False;
- exit;
- end if;
- end loop;
- end if;
-
- if not OK then
- Error_Msg_File_1 := File_Name_Type (Lib_Symbol_File.Value);
- Error_Msg
- (Data.Flags,
- "symbol file name { is illegal. " &
- "Name cannot include directory info.",
- Lib_Symbol_File.Location, Project);
- end if;
- end if;
- end if;
-
- -- If attribute Library_Reference_Symbol_File is not defined,
- -- symbol policy cannot be Compliant or Controlled.
-
- if Lib_Ref_Symbol_File.Default then
- if Project.Symbol_Data.Symbol_Policy = Compliant
- or else Project.Symbol_Data.Symbol_Policy = Controlled
- then
- Error_Msg
- (Data.Flags,
- "a reference symbol file needs to be defined",
- Lib_Symbol_Policy.Location, Project);
- end if;
-
- else
- -- Library_Reference_Symbol_File is defined, check file exists
-
- Project.Symbol_Data.Reference :=
- Path_Name_Type (Lib_Ref_Symbol_File.Value);
-
- Get_Name_String (Lib_Ref_Symbol_File.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Data.Flags,
- "reference symbol file name cannot be an empty string",
- Lib_Symbol_File.Location, Project);
-
- else
- if not Is_Absolute_Path (Name_Buffer (1 .. Name_Len)) then
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (Get_Name_String (Project.Directory.Name));
- Add_Str_To_Name_Buffer
- (Get_Name_String (Lib_Ref_Symbol_File.Value));
- Project.Symbol_Data.Reference := Name_Find;
- end if;
-
- if not Is_Regular_File
- (Get_Name_String (Project.Symbol_Data.Reference))
- then
- Error_Msg_File_1 :=
- File_Name_Type (Lib_Ref_Symbol_File.Value);
-
- -- For controlled and direct symbol policies, it is an error
- -- if the reference symbol file does not exist. For other
- -- symbol policies, this is just a warning
-
- Error_Msg_Warn :=
- Project.Symbol_Data.Symbol_Policy /= Controlled
- and then Project.Symbol_Data.Symbol_Policy /= Direct;
-
- Error_Msg
- (Data.Flags,
- "<library reference symbol file { does not exist",
- Lib_Ref_Symbol_File.Location, Project);
-
- -- In addition in the non-controlled case, if symbol policy
- -- is Compliant, it is changed to Autonomous, because there
- -- is no reference to check against, and we don't want to
- -- fail in this case.
-
- if Project.Symbol_Data.Symbol_Policy /= Controlled then
- if Project.Symbol_Data.Symbol_Policy = Compliant then
- Project.Symbol_Data.Symbol_Policy := Autonomous;
- end if;
- end if;
- end if;
-
- -- If both the reference symbol file and the symbol file are
- -- defined, then check that they are not the same file.
-
- if Project.Symbol_Data.Symbol_File /= No_Path then
- Get_Name_String (Project.Symbol_Data.Symbol_File);
-
- if Name_Len > 0 then
- declare
- -- We do not need to pass a Directory to
- -- Normalize_Pathname, since the path_information
- -- already contains absolute information.
-
- Symb_Path : constant String :=
- Normalize_Pathname
- (Get_Name_String
- (Project.Object_Directory.Name) &
- Name_Buffer (1 .. Name_Len),
- Directory => "/",
- Resolve_Links =>
- Opt.Follow_Links_For_Files);
- Ref_Path : constant String :=
- Normalize_Pathname
- (Get_Name_String
- (Project.Symbol_Data.Reference),
- Directory => "/",
- Resolve_Links =>
- Opt.Follow_Links_For_Files);
- begin
- if Symb_Path = Ref_Path then
- Error_Msg
- (Data.Flags,
- "library reference symbol file and library" &
- " symbol file cannot be the same file",
- Lib_Ref_Symbol_File.Location, Project);
- end if;
- end;
- end if;
- end if;
- end if;
- end if;
- end if;
- end Check_Stand_Alone_Library;
-
- ---------------------
- -- Check_Unit_Name --
- ---------------------
-
- procedure Check_Unit_Name (Name : String; Unit : out Name_Id) is
- The_Name : String := Name;
- Real_Name : Name_Id;
- Need_Letter : Boolean := True;
- Last_Underscore : Boolean := False;
- OK : Boolean := The_Name'Length > 0;
- First : Positive;
-
- function Is_Reserved (Name : Name_Id) return Boolean;
- function Is_Reserved (S : String) return Boolean;
- -- Check that the given name is not an Ada 95 reserved word. The reason
- -- for the Ada 95 here is that we do not want to exclude the case of an
- -- Ada 95 unit called Interface (for example). In Ada 2005, such a unit
- -- name would be rejected anyway by the compiler. That means there is no
- -- requirement that the project file parser reject this.
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (S : String) return Boolean is
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer (S);
- return Is_Reserved (Name_Find);
- end Is_Reserved;
-
- -----------------
- -- Is_Reserved --
- -----------------
-
- function Is_Reserved (Name : Name_Id) return Boolean is
- begin
- if Get_Name_Table_Byte (Name) /= 0
- and then
- not Nam_In (Name, Name_Project, Name_Extends, Name_External)
- and then Name not in Ada_2005_Reserved_Words
- then
- Unit := No_Name;
- Debug_Output ("Ada reserved word: ", Name);
- return True;
-
- else
- return False;
- end if;
- end Is_Reserved;
-
- -- Start of processing for Check_Unit_Name
-
- begin
- To_Lower (The_Name);
-
- Name_Len := The_Name'Length;
- Name_Buffer (1 .. Name_Len) := The_Name;
-
- Real_Name := Name_Find;
-
- if Is_Reserved (Real_Name) then
- return;
- end if;
-
- First := The_Name'First;
-
- for Index in The_Name'Range loop
- if Need_Letter then
-
- -- We need a letter (at the beginning, and following a dot),
- -- but we don't have one.
-
- if Is_Letter (The_Name (Index)) then
- Need_Letter := False;
-
- else
- OK := False;
-
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Int (Types.Int (Index));
- Write_Str (": '");
- Write_Char (The_Name (Index));
- Write_Line ("' is not a letter.");
- end if;
-
- exit;
- end if;
-
- elsif Last_Underscore
- and then (The_Name (Index) = '_' or else The_Name (Index) = '.')
- then
- -- Two underscores are illegal, and a dot cannot follow
- -- an underscore.
-
- OK := False;
-
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Int (Types.Int (Index));
- Write_Str (": '");
- Write_Char (The_Name (Index));
- Write_Line ("' is illegal here.");
- end if;
-
- exit;
-
- elsif The_Name (Index) = '.' then
-
- -- First, check if the name before the dot is not a reserved word
-
- if Is_Reserved (The_Name (First .. Index - 1)) then
- return;
- end if;
-
- First := Index + 1;
-
- -- We need a letter after a dot
-
- Need_Letter := True;
-
- elsif The_Name (Index) = '_' then
- Last_Underscore := True;
-
- else
- -- We need an letter or a digit
-
- Last_Underscore := False;
-
- if not Is_Alphanumeric (The_Name (Index)) then
- OK := False;
-
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Int (Types.Int (Index));
- Write_Str (": '");
- Write_Char (The_Name (Index));
- Write_Line ("' is not alphanumeric.");
- end if;
-
- exit;
- end if;
- end if;
- end loop;
-
- -- Cannot end with an underscore or a dot
-
- OK := OK and then not Need_Letter and then not Last_Underscore;
-
- if OK then
- if First /= Name'First
- and then Is_Reserved (The_Name (First .. The_Name'Last))
- then
- return;
- end if;
-
- Unit := Real_Name;
-
- else
- -- Signal a problem with No_Name
-
- Unit := No_Name;
- end if;
- end Check_Unit_Name;
-
- ----------------------------
- -- Compute_Directory_Last --
- ----------------------------
-
- function Compute_Directory_Last (Dir : String) return Natural is
- begin
- if Dir'Length > 1
- and then Is_Directory_Separator (Dir (Dir'Last - 1))
- then
- return Dir'Last - 1;
- else
- return Dir'Last;
- end if;
- end Compute_Directory_Last;
-
- ---------------------
- -- Get_Directories --
- ---------------------
-
- procedure Get_Directories
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Object_Dir : constant Variable_Value :=
- Util.Value_Of
- (Name_Object_Dir, Project.Decl.Attributes, Shared);
-
- Exec_Dir : constant Variable_Value :=
- Util.Value_Of
- (Name_Exec_Dir, Project.Decl.Attributes, Shared);
-
- Source_Dirs : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_Dirs, Project.Decl.Attributes, Shared);
-
- Ignore_Source_Sub_Dirs : constant Variable_Value :=
- Util.Value_Of
- (Name_Ignore_Source_Sub_Dirs,
- Project.Decl.Attributes,
- Shared);
-
- Excluded_Source_Dirs : constant Variable_Value :=
- Util.Value_Of
- (Name_Excluded_Source_Dirs,
- Project.Decl.Attributes,
- Shared);
-
- Source_Files : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_Files,
- Project.Decl.Attributes, Shared);
-
- Last_Source_Dir : String_List_Id := Nil_String;
- Last_Src_Dir_Rank : Number_List_Index := No_Number_List;
-
- Languages : constant Variable_Value :=
- Prj.Util.Value_Of
- (Name_Languages, Project.Decl.Attributes, Shared);
-
- Remove_Source_Dirs : Boolean := False;
-
- procedure Add_To_Or_Remove_From_Source_Dirs
- (Path : Path_Information;
- Rank : Natural);
- -- When Removed = False, the directory Path_Id to the list of
- -- source_dirs if not already in the list. When Removed = True,
- -- removed directory Path_Id if in the list.
-
- procedure Find_Source_Dirs is new Expand_Subdirectory_Pattern
- (Add_To_Or_Remove_From_Source_Dirs);
-
- ---------------------------------------
- -- Add_To_Or_Remove_From_Source_Dirs --
- ---------------------------------------
-
- procedure Add_To_Or_Remove_From_Source_Dirs
- (Path : Path_Information;
- Rank : Natural)
- is
- List : String_List_Id;
- Prev : String_List_Id;
- Rank_List : Number_List_Index;
- Prev_Rank : Number_List_Index;
- Element : String_Element;
-
- begin
- Prev := Nil_String;
- Prev_Rank := No_Number_List;
- List := Project.Source_Dirs;
- Rank_List := Project.Source_Dir_Ranks;
- while List /= Nil_String loop
- Element := Shared.String_Elements.Table (List);
- exit when Element.Value = Name_Id (Path.Name);
- Prev := List;
- List := Element.Next;
- Prev_Rank := Rank_List;
- Rank_List := Shared.Number_Lists.Table (Prev_Rank).Next;
- end loop;
-
- -- The directory is in the list if List is not Nil_String
-
- if not Remove_Source_Dirs and then List = Nil_String then
- Debug_Output ("adding source dir=", Name_Id (Path.Display_Name));
-
- String_Element_Table.Increment_Last (Shared.String_Elements);
- Element :=
- (Value => Name_Id (Path.Name),
- Index => 0,
- Display_Value => Name_Id (Path.Display_Name),
- Location => No_Location,
- Flag => False,
- Next => Nil_String);
-
- Number_List_Table.Increment_Last (Shared.Number_Lists);
-
- if Last_Source_Dir = Nil_String then
-
- -- This is the first source directory
-
- Project.Source_Dirs :=
- String_Element_Table.Last (Shared.String_Elements);
- Project.Source_Dir_Ranks :=
- Number_List_Table.Last (Shared.Number_Lists);
-
- else
- -- We already have source directories, link the previous
- -- last to the new one.
-
- Shared.String_Elements.Table (Last_Source_Dir).Next :=
- String_Element_Table.Last (Shared.String_Elements);
- Shared.Number_Lists.Table (Last_Src_Dir_Rank).Next :=
- Number_List_Table.Last (Shared.Number_Lists);
- end if;
-
- -- And register this source directory as the new last
-
- Last_Source_Dir :=
- String_Element_Table.Last (Shared.String_Elements);
- Shared.String_Elements.Table (Last_Source_Dir) := Element;
- Last_Src_Dir_Rank := Number_List_Table.Last (Shared.Number_Lists);
- Shared.Number_Lists.Table (Last_Src_Dir_Rank) :=
- (Number => Rank, Next => No_Number_List);
-
- elsif Remove_Source_Dirs and then List /= Nil_String then
-
- -- Remove source dir if present
-
- if Prev = Nil_String then
- Project.Source_Dirs := Shared.String_Elements.Table (List).Next;
- Project.Source_Dir_Ranks :=
- Shared.Number_Lists.Table (Rank_List).Next;
-
- else
- Shared.String_Elements.Table (Prev).Next :=
- Shared.String_Elements.Table (List).Next;
- Shared.Number_Lists.Table (Prev_Rank).Next :=
- Shared.Number_Lists.Table (Rank_List).Next;
- end if;
- end if;
- end Add_To_Or_Remove_From_Source_Dirs;
-
- -- Local declarations
-
- Dir_Exists : Boolean;
-
- No_Sources : constant Boolean :=
- Project.Qualifier = Abstract_Project
- or else (((not Source_Files.Default
- and then Source_Files.Values = Nil_String)
- or else
- (not Source_Dirs.Default
- and then Source_Dirs.Values = Nil_String)
- or else
- (not Languages.Default
- and then Languages.Values = Nil_String))
- and then Project.Extends = No_Project);
-
- -- Start of processing for Get_Directories
-
- begin
- Debug_Output ("starting to look for directories");
-
- -- Set the object directory to its default which may be nil, if there
- -- is no sources in the project.
-
- if No_Sources then
- Project.Object_Directory := No_Path_Information;
- else
- Project.Object_Directory := Project.Directory;
- end if;
-
- -- Check the object directory
-
- if Object_Dir.Value /= Empty_String then
- Get_Name_String (Object_Dir.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Data.Flags,
- "Object_Dir cannot be empty",
- Object_Dir.Location, Project);
-
- elsif Setup_Projects
- and then No_Sources
- and then Project.Extends = No_Project
- then
- -- Do not create an object directory for a non extending project
- -- with no sources.
-
- Locate_Directory
- (Project,
- File_Name_Type (Object_Dir.Value),
- Path => Project.Object_Directory,
- Dir_Exists => Dir_Exists,
- Data => Data,
- Location => Object_Dir.Location,
- Must_Exist => False,
- Externally_Built => Project.Externally_Built);
-
- else
- -- We check that the specified object directory does exist.
- -- However, even when it doesn't exist, we set it to a default
- -- value. This is for the benefit of tools that recover from
- -- errors; for example, these tools could create the non existent
- -- directory. We always return an absolute directory name though.
-
- Locate_Directory
- (Project,
- File_Name_Type (Object_Dir.Value),
- Path => Project.Object_Directory,
- Create => "object",
- Dir_Exists => Dir_Exists,
- Data => Data,
- Location => Object_Dir.Location,
- Must_Exist => False,
- Externally_Built => Project.Externally_Built);
-
- if not Dir_Exists and then not Project.Externally_Built then
- if Opt.Directories_Must_Exist_In_Projects then
-
- -- The object directory does not exist, report an error if
- -- the project is not externally built.
-
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Object_Dir.Value);
- Error_Or_Warning
- (Data.Flags, Data.Flags.Require_Obj_Dirs,
- "object directory { not found",
- Project.Location, Project);
- end if;
- end if;
- end if;
-
- elsif not No_Sources
- and then (Subdirs /= null or else Build_Tree_Dir /= null)
- then
- Name_Len := 1;
- Name_Buffer (1) := '.';
- Locate_Directory
- (Project,
- Name_Find,
- Path => Project.Object_Directory,
- Create => "object",
- Dir_Exists => Dir_Exists,
- Data => Data,
- Location => Object_Dir.Location,
- Externally_Built => Project.Externally_Built);
- end if;
-
- if Current_Verbosity = High then
- if Project.Object_Directory = No_Path_Information then
- Debug_Output ("no object directory");
- else
- Write_Attr
- ("Object directory",
- Get_Name_String (Project.Object_Directory.Display_Name));
- end if;
- end if;
-
- -- Check the exec directory
-
- -- We set the object directory to its default
-
- Project.Exec_Directory := Project.Object_Directory;
-
- if Exec_Dir.Value /= Empty_String then
- Get_Name_String (Exec_Dir.Value);
-
- if Name_Len = 0 then
- Error_Msg
- (Data.Flags,
- "Exec_Dir cannot be empty",
- Exec_Dir.Location, Project);
-
- elsif Setup_Projects
- and then No_Sources
- and then Project.Extends = No_Project
- then
- -- Do not create an exec directory for a non extending project
- -- with no sources.
-
- Locate_Directory
- (Project,
- File_Name_Type (Exec_Dir.Value),
- Path => Project.Exec_Directory,
- Dir_Exists => Dir_Exists,
- Data => Data,
- Location => Exec_Dir.Location,
- Externally_Built => Project.Externally_Built);
-
- else
- -- We check that the specified exec directory does exist
-
- Locate_Directory
- (Project,
- File_Name_Type (Exec_Dir.Value),
- Path => Project.Exec_Directory,
- Dir_Exists => Dir_Exists,
- Data => Data,
- Create => "exec",
- Location => Exec_Dir.Location,
- Externally_Built => Project.Externally_Built);
-
- if not Dir_Exists then
- if Opt.Directories_Must_Exist_In_Projects then
- Err_Vars.Error_Msg_File_1 := File_Name_Type (Exec_Dir.Value);
- Error_Or_Warning
- (Data.Flags, Data.Flags.Missing_Source_Files,
- "exec directory { not found", Project.Location, Project);
-
- else
- Project.Exec_Directory := No_Path_Information;
- end if;
- end if;
- end if;
- end if;
-
- if Current_Verbosity = High then
- if Project.Exec_Directory = No_Path_Information then
- Debug_Output ("no exec directory");
- else
- Debug_Output
- ("exec directory: ",
- Name_Id (Project.Exec_Directory.Display_Name));
- end if;
- end if;
-
- -- Look for the source directories
-
- Debug_Output ("starting to look for source directories");
-
- pragma Assert (Source_Dirs.Kind = List, "Source_Dirs is not a list");
-
- if not Source_Files.Default and then Source_Files.Values = Nil_String
- then
- Project.Source_Dirs := Nil_String;
-
- if Project.Qualifier = Standard then
- Error_Msg
- (Data.Flags,
- "a standard project cannot have no sources",
- Source_Files.Location, Project);
- end if;
-
- elsif Source_Dirs.Default then
-
- -- No Source_Dirs specified: the single source directory is the one
- -- containing the project file.
-
- Remove_Source_Dirs := False;
- Add_To_Or_Remove_From_Source_Dirs
- (Path => (Name => Project.Directory.Name,
- Display_Name => Project.Directory.Display_Name),
- Rank => 1);
-
- else
- Remove_Source_Dirs := False;
- Find_Source_Dirs
- (Project => Project,
- Data => Data,
- Patterns => Source_Dirs.Values,
- Ignore => Ignore_Source_Sub_Dirs.Values,
- Search_For => Search_Directories,
- Resolve_Links => Opt.Follow_Links_For_Dirs);
-
- if Project.Source_Dirs = Nil_String
- and then Project.Qualifier = Standard
- then
- Error_Msg
- (Data.Flags,
- "a standard project cannot have no source directories",
- Source_Dirs.Location, Project);
- end if;
- end if;
-
- if not Excluded_Source_Dirs.Default
- and then Excluded_Source_Dirs.Values /= Nil_String
- then
- Remove_Source_Dirs := True;
- Find_Source_Dirs
- (Project => Project,
- Data => Data,
- Patterns => Excluded_Source_Dirs.Values,
- Ignore => Nil_String,
- Search_For => Search_Directories,
- Resolve_Links => Opt.Follow_Links_For_Dirs);
- end if;
-
- Debug_Output ("putting source directories in canonical cases");
-
- declare
- Current : String_List_Id := Project.Source_Dirs;
- Element : String_Element;
-
- begin
- while Current /= Nil_String loop
- Element := Shared.String_Elements.Table (Current);
- if Element.Value /= No_Name then
- Element.Value :=
- Name_Id (Canonical_Case_File_Name (Element.Value));
- Shared.String_Elements.Table (Current) := Element;
- end if;
-
- Current := Element.Next;
- end loop;
- end;
- end Get_Directories;
-
- ---------------
- -- Get_Mains --
- ---------------
-
- procedure Get_Mains
- (Project : Project_Id;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Mains : constant Variable_Value :=
- Prj.Util.Value_Of
- (Name_Main, Project.Decl.Attributes, Shared);
- List : String_List_Id;
- Elem : String_Element;
-
- begin
- Project.Mains := Mains.Values;
-
- -- If no Mains were specified, and if we are an extending project,
- -- inherit the Mains from the project we are extending.
-
- if Mains.Default then
- if not Project.Library and then Project.Extends /= No_Project then
- Project.Mains := Project.Extends.Mains;
- end if;
-
- -- In a library project file, Main cannot be specified
-
- elsif Project.Library then
- Error_Msg
- (Data.Flags,
- "a library project file cannot have Main specified",
- Mains.Location, Project);
-
- else
- List := Mains.Values;
- while List /= Nil_String loop
- Elem := Shared.String_Elements.Table (List);
-
- if Length_Of_Name (Elem.Value) = 0 then
- Error_Msg
- (Data.Flags,
- "?a main cannot have an empty name",
- Elem.Location, Project);
- exit;
- end if;
-
- List := Elem.Next;
- end loop;
- end if;
- end Get_Mains;
-
- ---------------------------
- -- Get_Sources_From_File --
- ---------------------------
-
- procedure Get_Sources_From_File
- (Path : String;
- Location : Source_Ptr;
- Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data)
- is
- File : Prj.Util.Text_File;
- Line : String (1 .. 250);
- Last : Natural;
- Source_Name : File_Name_Type;
- Name_Loc : Name_Location;
-
- begin
- if Current_Verbosity = High then
- Debug_Output ("opening """ & Path & '"');
- end if;
-
- -- Open the file
-
- Prj.Util.Open (File, Path);
-
- if not Prj.Util.Is_Valid (File) then
- Error_Msg
- (Data.Flags, "file does not exist", Location, Project.Project);
-
- else
- -- Read the lines one by one
-
- while not Prj.Util.End_Of_File (File) loop
- Prj.Util.Get_Line (File, Line, Last);
-
- -- A non empty, non comment line should contain a file name
-
- if Last /= 0 and then (Last = 1 or else Line (1 .. 2) /= "--") then
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Source_Name := Name_Find;
-
- -- Check that there is no directory information
-
- for J in 1 .. Last loop
- if Is_Directory_Separator (Line (J)) then
- Error_Msg_File_1 := Source_Name;
- Error_Msg
- (Data.Flags,
- "file name cannot include directory information ({)",
- Location, Project.Project);
- exit;
- end if;
- end loop;
-
- Name_Loc := Source_Names_Htable.Get
- (Project.Source_Names, Source_Name);
-
- if Name_Loc = No_Name_Location then
- Name_Loc :=
- (Name => Source_Name,
- Location => Location,
- Source => No_Source,
- Listed => True,
- Found => False);
-
- else
- Name_Loc.Listed := True;
- end if;
-
- Source_Names_Htable.Set
- (Project.Source_Names, Source_Name, Name_Loc);
- end if;
- end loop;
-
- Prj.Util.Close (File);
-
- end if;
- end Get_Sources_From_File;
-
- ------------------
- -- No_Space_Img --
- ------------------
-
- function No_Space_Img (N : Natural) return String is
- Image : constant String := N'Img;
- begin
- return Image (2 .. Image'Last);
- end No_Space_Img;
-
- -----------------------
- -- Compute_Unit_Name --
- -----------------------
-
- procedure Compute_Unit_Name
- (File_Name : File_Name_Type;
- Naming : Lang_Naming_Data;
- Kind : out Source_Kind;
- Unit : out Name_Id;
- Project : Project_Processing_Data)
- is
- Filename : constant String := Get_Name_String (File_Name);
- Last : Integer := Filename'Last;
- Sep_Len : Integer;
- Body_Len : Integer;
- Spec_Len : Integer;
-
- Unit_Except : Unit_Exception;
- Masked : Boolean := False;
-
- begin
- Unit := No_Name;
- Kind := Spec;
-
- if Naming.Separate_Suffix = No_File
- or else Naming.Body_Suffix = No_File
- or else Naming.Spec_Suffix = No_File
- then
- return;
- end if;
-
- if Naming.Dot_Replacement = No_File then
- Debug_Output ("no dot_replacement specified");
- return;
- end if;
-
- Sep_Len := Integer (Length_Of_Name (Naming.Separate_Suffix));
- Spec_Len := Integer (Length_Of_Name (Naming.Spec_Suffix));
- Body_Len := Integer (Length_Of_Name (Naming.Body_Suffix));
-
- -- Choose the longest suffix that matches. If there are several matches,
- -- give priority to specs, then bodies, then separates.
-
- if Naming.Separate_Suffix /= Naming.Body_Suffix
- and then Suffix_Matches (Filename, Naming.Separate_Suffix)
- then
- Last := Filename'Last - Sep_Len;
- Kind := Sep;
- end if;
-
- if Filename'Last - Body_Len <= Last
- and then Suffix_Matches (Filename, Naming.Body_Suffix)
- then
- Last := Natural'Min (Last, Filename'Last - Body_Len);
- Kind := Impl;
- end if;
-
- if Filename'Last - Spec_Len <= Last
- and then Suffix_Matches (Filename, Naming.Spec_Suffix)
- then
- Last := Natural'Min (Last, Filename'Last - Spec_Len);
- Kind := Spec;
- end if;
-
- if Last = Filename'Last then
- Debug_Output ("no matching suffix");
- return;
- end if;
-
- -- Check that the casing matches
-
- if File_Names_Case_Sensitive then
- case Naming.Casing is
- when All_Lower_Case =>
- for J in Filename'First .. Last loop
- if Is_Letter (Filename (J))
- and then not Is_Lower (Filename (J))
- then
- Debug_Output ("invalid casing");
- return;
- end if;
- end loop;
-
- when All_Upper_Case =>
- for J in Filename'First .. Last loop
- if Is_Letter (Filename (J))
- and then not Is_Upper (Filename (J))
- then
- Debug_Output ("invalid casing");
- return;
- end if;
- end loop;
-
- when Mixed_Case
- | Unknown
- =>
- null;
- end case;
- end if;
-
- -- If Dot_Replacement is not a single dot, then there should not
- -- be any dot in the name.
-
- declare
- Dot_Repl : constant String :=
- Get_Name_String (Naming.Dot_Replacement);
-
- begin
- if Dot_Repl /= "." then
- for Index in Filename'First .. Last loop
- if Filename (Index) = '.' then
- Debug_Output ("invalid name, contains dot");
- return;
- end if;
- end loop;
-
- Replace_Into_Name_Buffer
- (Filename (Filename'First .. Last), Dot_Repl, '.');
-
- else
- Name_Len := Last - Filename'First + 1;
- Name_Buffer (1 .. Name_Len) := Filename (Filename'First .. Last);
- Fixed.Translate
- (Source => Name_Buffer (1 .. Name_Len),
- Mapping => Lower_Case_Map);
- end if;
- end;
-
- -- In the standard GNAT naming scheme, check for special cases: children
- -- or separates of A, G, I or S, and run time sources.
-
- if Is_Standard_GNAT_Naming (Naming) and then Name_Len >= 3 then
- declare
- S1 : constant Character := Name_Buffer (1);
- S2 : constant Character := Name_Buffer (2);
- S3 : constant Character := Name_Buffer (3);
-
- begin
- if S1 = 'a' or else S1 = 'g' or else S1 = 'i' or else S1 = 's' then
-
- -- Children or separates of packages A, G, I or S. These names
- -- are x__ ... or x~... (where x is a, g, i, or s). Both
- -- versions (x__... and x~...) are allowed in all platforms,
- -- because it is not possible to know the platform before
- -- processing of the project files.
-
- if S2 = '_' and then S3 = '_' then
- Name_Buffer (2) := '.';
- Name_Buffer (3 .. Name_Len - 1) :=
- Name_Buffer (4 .. Name_Len);
- Name_Len := Name_Len - 1;
-
- elsif S2 = '~' then
- Name_Buffer (2) := '.';
-
- elsif S2 = '.' then
-
- -- If it is potentially a run time source
-
- null;
- end if;
- end if;
- end;
- end if;
-
- -- Name_Buffer contains the name of the unit in lower-cases. Check
- -- that this is a valid unit name
-
- Check_Unit_Name (Name_Buffer (1 .. Name_Len), Unit);
-
- -- If there is a naming exception for the same unit, the file is not
- -- a source for the unit.
-
- if Unit /= No_Name then
- Unit_Except :=
- Unit_Exceptions_Htable.Get (Project.Unit_Exceptions, Unit);
-
- if Kind = Spec then
- Masked := Unit_Except.Spec /= No_File
- and then
- Unit_Except.Spec /= File_Name;
- else
- Masked := Unit_Except.Impl /= No_File
- and then
- Unit_Except.Impl /= File_Name;
- end if;
-
- if Masked then
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Str (" """ & Filename & """ contains the ");
-
- if Kind = Spec then
- Write_Str ("spec of a unit found in """);
- Write_Str (Get_Name_String (Unit_Except.Spec));
- else
- Write_Str ("body of a unit found in """);
- Write_Str (Get_Name_String (Unit_Except.Impl));
- end if;
-
- Write_Line (""" (ignored)");
- end if;
-
- Unit := No_Name;
- end if;
- end if;
-
- if Unit /= No_Name and then Current_Verbosity = High then
- case Kind is
- when Spec => Debug_Output ("spec of", Unit);
- when Impl => Debug_Output ("body of", Unit);
- when Sep => Debug_Output ("sep of", Unit);
- end case;
- end if;
- end Compute_Unit_Name;
-
- --------------------------
- -- Check_Illegal_Suffix --
- --------------------------
-
- procedure Check_Illegal_Suffix
- (Project : Project_Id;
- Suffix : File_Name_Type;
- Dot_Replacement : File_Name_Type;
- Attribute_Name : String;
- Location : Source_Ptr;
- Data : in out Tree_Processing_Data)
- is
- Suffix_Str : constant String := Get_Name_String (Suffix);
-
- begin
- if Suffix_Str'Length = 0 then
-
- -- Always valid
-
- return;
-
- elsif Index (Suffix_Str, ".") = 0 then
- Err_Vars.Error_Msg_File_1 := Suffix;
- Error_Msg
- (Data.Flags,
- "{ is illegal for " & Attribute_Name & ": must have a dot",
- Location, Project);
- return;
- end if;
-
- -- Case of dot replacement is a single dot, and first character of
- -- suffix is also a dot.
-
- if Dot_Replacement /= No_File
- and then Get_Name_String (Dot_Replacement) = "."
- and then Suffix_Str (Suffix_Str'First) = '.'
- then
- for Index in Suffix_Str'First + 1 .. Suffix_Str'Last loop
-
- -- If there are multiple dots in the name
-
- if Suffix_Str (Index) = '.' then
-
- -- It is illegal to have a letter following the initial dot
-
- if Is_Letter (Suffix_Str (Suffix_Str'First + 1)) then
- Err_Vars.Error_Msg_File_1 := Suffix;
- Error_Msg
- (Data.Flags,
- "{ is illegal for " & Attribute_Name
- & ": ambiguous prefix when Dot_Replacement is a dot",
- Location, Project);
- end if;
- return;
- end if;
- end loop;
- end if;
- end Check_Illegal_Suffix;
-
- ----------------------
- -- Locate_Directory --
- ----------------------
-
- procedure Locate_Directory
- (Project : Project_Id;
- Name : File_Name_Type;
- Path : out Path_Information;
- Dir_Exists : out Boolean;
- Data : in out Tree_Processing_Data;
- Create : String := "";
- Location : Source_Ptr := No_Location;
- Must_Exist : Boolean := True;
- Externally_Built : Boolean := False)
- is
- Parent : constant Path_Name_Type :=
- Project.Directory.Display_Name;
- The_Parent : constant String :=
- Get_Name_String (Parent);
- The_Parent_Last : constant Natural :=
- Compute_Directory_Last (The_Parent);
- Full_Name : File_Name_Type;
- The_Name : File_Name_Type;
-
- begin
- -- Check if we have a root-object dir specified, if so relocate all
- -- artefact directories to it.
-
- if Build_Tree_Dir /= null
- and then Create /= ""
- and then not Is_Absolute_Path (Get_Name_String (Name))
- then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Build_Tree_Dir.all);
-
- if The_Parent_Last - The_Parent'First + 1 < Root_Dir'Length then
- Err_Vars.Error_Msg_File_1 := Name;
- Error_Or_Warning
- (Data.Flags, Error,
- "{ cannot relocate deeper than " & Create & " directory",
- No_Location, Project);
- end if;
-
- Add_Str_To_Name_Buffer
- (Relative_Path
- (The_Parent (The_Parent'First .. The_Parent_Last),
- Root_Dir.all));
- Add_Str_To_Name_Buffer (Get_Name_String (Name));
-
- else
- if Build_Tree_Dir /= null and then Create /= "" then
-
- -- Issue a warning that we cannot relocate absolute obj dir
-
- Err_Vars.Error_Msg_File_1 := Name;
- Error_Or_Warning
- (Data.Flags, Warning,
- "{ cannot relocate absolute object directory",
- No_Location, Project);
- end if;
-
- Get_Name_String (Name);
- end if;
-
- -- Add Subdirs.all if it is a directory that may be created and
- -- Subdirs is not null;
-
- if Create /= "" and then Subdirs /= null then
- if Name_Buffer (Name_Len) /= Directory_Separator then
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
-
- Add_Str_To_Name_Buffer (Subdirs.all);
- end if;
-
- -- Convert '/' to directory separator (for Windows)
-
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '/' then
- Name_Buffer (J) := Directory_Separator;
- end if;
- end loop;
-
- The_Name := Name_Find;
-
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Str ("Locate_Directory (""");
- Write_Str (Get_Name_String (The_Name));
- Write_Str (""", in """);
- Write_Str (The_Parent);
- Write_Line (""")");
- end if;
-
- Path := No_Path_Information;
- Dir_Exists := False;
-
- if Is_Absolute_Path (Get_Name_String (The_Name)) then
- Full_Name := The_Name;
-
- else
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (The_Parent (The_Parent'First .. The_Parent_Last));
- Add_Str_To_Name_Buffer (Get_Name_String (The_Name));
- Full_Name := Name_Find;
- end if;
-
- declare
- Full_Path_Name : String_Access :=
- new String'(Get_Name_String (Full_Name));
-
- begin
- if (Setup_Projects or else Subdirs /= null)
- and then Create'Length > 0
- then
- if not Is_Directory (Full_Path_Name.all) then
-
- -- If project is externally built, do not create a subdir,
- -- use the specified directory, without the subdir.
-
- if Externally_Built then
- if Is_Absolute_Path (Get_Name_String (Name)) then
- Get_Name_String (Name);
-
- else
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (The_Parent (The_Parent'First .. The_Parent_Last));
- Add_Str_To_Name_Buffer (Get_Name_String (Name));
- end if;
-
- Full_Path_Name := new String'(Name_Buffer (1 .. Name_Len));
-
- else
- begin
- Create_Path (Full_Path_Name.all);
-
- if not Quiet_Output then
- Write_Str (Create);
- Write_Str (" directory """);
- Write_Str (Full_Path_Name.all);
- Write_Str (""" created for project ");
- Write_Line (Get_Name_String (Project.Name));
- end if;
-
- exception
- when Use_Error =>
-
- -- Output message with name of directory. Note that we
- -- use the ~ insertion method here in case the name
- -- has special characters in it.
-
- Error_Msg_Strlen := Full_Path_Name'Length;
- Error_Msg_String (1 .. Error_Msg_Strlen) :=
- Full_Path_Name.all;
- Error_Msg
- (Data.Flags,
- "could not create " & Create & " directory ~",
- Location,
- Project);
- end;
- end if;
- end if;
- end if;
-
- Dir_Exists := Is_Directory (Full_Path_Name.all);
-
- if not Must_Exist or Dir_Exists then
- declare
- Normed : constant String :=
- Normalize_Pathname
- (Full_Path_Name.all,
- Directory =>
- The_Parent (The_Parent'First .. The_Parent_Last),
- Resolve_Links => False,
- Case_Sensitive => True);
-
- Canonical_Path : constant String :=
- Normalize_Pathname
- (Normed,
- Directory =>
- The_Parent
- (The_Parent'First .. The_Parent_Last),
- Resolve_Links =>
- Opt.Follow_Links_For_Dirs,
- Case_Sensitive => False);
-
- begin
- Name_Len := Normed'Length;
- Name_Buffer (1 .. Name_Len) := Normed;
-
- -- Directories should always end with a directory separator
-
- if Name_Buffer (Name_Len) /= Directory_Separator then
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
-
- Path.Display_Name := Name_Find;
-
- Name_Len := Canonical_Path'Length;
- Name_Buffer (1 .. Name_Len) := Canonical_Path;
-
- if Name_Buffer (Name_Len) /= Directory_Separator then
- Add_Char_To_Name_Buffer (Directory_Separator);
- end if;
-
- Path.Name := Name_Find;
- end;
- end if;
-
- Free (Full_Path_Name);
- end;
- end Locate_Directory;
-
- ---------------------------
- -- Find_Excluded_Sources --
- ---------------------------
-
- procedure Find_Excluded_Sources
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Excluded_Source_List_File : constant Variable_Value :=
- Util.Value_Of
- (Name_Excluded_Source_List_File,
- Project.Project.Decl.Attributes,
- Shared);
- Excluded_Sources : Variable_Value := Util.Value_Of
- (Name_Excluded_Source_Files,
- Project.Project.Decl.Attributes,
- Shared);
-
- Current : String_List_Id;
- Element : String_Element;
- Location : Source_Ptr;
- Name : File_Name_Type;
- File : Prj.Util.Text_File;
- Line : String (1 .. 300);
- Last : Natural;
- Locally_Removed : Boolean := False;
-
- begin
- -- If Excluded_Source_Files is not declared, check Locally_Removed_Files
-
- if Excluded_Sources.Default then
- Locally_Removed := True;
- Excluded_Sources :=
- Util.Value_Of
- (Name_Locally_Removed_Files,
- Project.Project.Decl.Attributes, Shared);
- end if;
-
- -- If there are excluded sources, put them in the table
-
- if not Excluded_Sources.Default then
- if not Excluded_Source_List_File.Default then
- if Locally_Removed then
- Error_Msg
- (Data.Flags,
- "?both attributes Locally_Removed_Files and " &
- "Excluded_Source_List_File are present",
- Excluded_Source_List_File.Location, Project.Project);
- else
- Error_Msg
- (Data.Flags,
- "?both attributes Excluded_Source_Files and " &
- "Excluded_Source_List_File are present",
- Excluded_Source_List_File.Location, Project.Project);
- end if;
- end if;
-
- Current := Excluded_Sources.Values;
- while Current /= Nil_String loop
- Element := Shared.String_Elements.Table (Current);
- Name := Canonical_Case_File_Name (Element.Value);
-
- -- If the element has no location, then use the location of
- -- Excluded_Sources to report possible errors.
-
- if Element.Location = No_Location then
- Location := Excluded_Sources.Location;
- else
- Location := Element.Location;
- end if;
-
- Excluded_Sources_Htable.Set
- (Project.Excluded, Name,
- (Name, No_File, 0, False, Location));
- Current := Element.Next;
- end loop;
-
- elsif not Excluded_Source_List_File.Default then
- Location := Excluded_Source_List_File.Location;
-
- declare
- Source_File_Name : constant File_Name_Type :=
- File_Name_Type
- (Excluded_Source_List_File.Value);
- Source_File_Line : Natural := 0;
-
- Source_File_Path_Name : constant String :=
- Path_Name_Of
- (Source_File_Name,
- Project.Project.Directory.Name);
-
- begin
- if Source_File_Path_Name'Length = 0 then
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Excluded_Source_List_File.Value);
- Error_Msg
- (Data.Flags,
- "file with excluded sources { does not exist",
- Excluded_Source_List_File.Location, Project.Project);
-
- else
- -- Open the file
-
- Prj.Util.Open (File, Source_File_Path_Name);
-
- if not Prj.Util.Is_Valid (File) then
- Error_Msg
- (Data.Flags, "file does not exist",
- Location, Project.Project);
- else
- -- Read the lines one by one
-
- while not Prj.Util.End_Of_File (File) loop
- Prj.Util.Get_Line (File, Line, Last);
- Source_File_Line := Source_File_Line + 1;
-
- -- Non empty, non comment line should contain a file name
-
- if Last /= 0
- and then (Last = 1 or else Line (1 .. 2) /= "--")
- then
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) := Line (1 .. Last);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Name := Name_Find;
-
- -- Check that there is no directory information
-
- for J in 1 .. Last loop
- if Is_Directory_Separator (Line (J)) then
- Error_Msg_File_1 := Name;
- Error_Msg
- (Data.Flags,
- "file name cannot include "
- & "directory information ({)",
- Location, Project.Project);
- exit;
- end if;
- end loop;
-
- Excluded_Sources_Htable.Set
- (Project.Excluded,
- Name,
- (Name, Source_File_Name, Source_File_Line,
- False, Location));
- end if;
- end loop;
-
- Prj.Util.Close (File);
- end if;
- end if;
- end;
- end if;
- end Find_Excluded_Sources;
-
- ------------------
- -- Find_Sources --
- ------------------
-
- procedure Find_Sources
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Sources : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_Files,
- Project.Project.Decl.Attributes,
- Shared);
-
- Source_List_File : constant Variable_Value :=
- Util.Value_Of
- (Name_Source_List_File,
- Project.Project.Decl.Attributes,
- Shared);
-
- Name_Loc : Name_Location;
- Has_Explicit_Sources : Boolean;
-
- begin
- pragma Assert (Sources.Kind = List, "Source_Files is not a list");
- pragma Assert
- (Source_List_File.Kind = Single,
- "Source_List_File is not a single string");
-
- Project.Source_List_File_Location := Source_List_File.Location;
-
- -- If the user has specified a Source_Files attribute
-
- if not Sources.Default then
- if not Source_List_File.Default then
- Error_Msg
- (Data.Flags,
- "?both attributes source_files and " &
- "source_list_file are present",
- Source_List_File.Location, Project.Project);
- end if;
-
- -- Sources is a list of file names
-
- declare
- Current : String_List_Id := Sources.Values;
- Element : String_Element;
- Location : Source_Ptr;
- Name : File_Name_Type;
-
- begin
- if Current = Nil_String then
- Project.Project.Languages := No_Language_Index;
-
- -- This project contains no source. For projects that don't
- -- extend other projects, this also means that there is no
- -- need for an object directory, if not specified.
-
- if Project.Project.Extends = No_Project
- and then
- Project.Project.Object_Directory = Project.Project.Directory
- and then not (Project.Project.Qualifier = Aggregate_Library)
- then
- Project.Project.Object_Directory := No_Path_Information;
- end if;
- end if;
-
- while Current /= Nil_String loop
- Element := Shared.String_Elements.Table (Current);
- Name := Canonical_Case_File_Name (Element.Value);
- Get_Name_String (Element.Value);
-
- -- If the element has no location, then use the location of
- -- Sources to report possible errors.
-
- if Element.Location = No_Location then
- Location := Sources.Location;
- else
- Location := Element.Location;
- end if;
-
- -- Check that there is no directory information
-
- for J in 1 .. Name_Len loop
- if Is_Directory_Separator (Name_Buffer (J)) then
- Error_Msg_File_1 := Name;
- Error_Msg
- (Data.Flags,
- "file name cannot include directory " &
- "information ({)",
- Location, Project.Project);
- exit;
- end if;
- end loop;
-
- -- Check whether the file is already there: the same file name
- -- may be in the list. If the source is missing, the error will
- -- be on the first mention of the source file name.
-
- Name_Loc := Source_Names_Htable.Get
- (Project.Source_Names, Name);
-
- if Name_Loc = No_Name_Location then
- Name_Loc :=
- (Name => Name,
- Location => Location,
- Source => No_Source,
- Listed => True,
- Found => False);
-
- else
- Name_Loc.Listed := True;
- end if;
-
- Source_Names_Htable.Set
- (Project.Source_Names, Name, Name_Loc);
-
- Current := Element.Next;
- end loop;
-
- Has_Explicit_Sources := True;
- end;
-
- -- If we have no Source_Files attribute, check the Source_List_File
- -- attribute.
-
- elsif not Source_List_File.Default then
-
- -- Source_List_File is the name of the file that contains the source
- -- file names.
-
- declare
- Source_File_Path_Name : constant String :=
- Path_Name_Of
- (File_Name_Type
- (Source_List_File.Value),
- Project.Project.
- Directory.Display_Name);
-
- begin
- Has_Explicit_Sources := True;
-
- if Source_File_Path_Name'Length = 0 then
- Err_Vars.Error_Msg_File_1 :=
- File_Name_Type (Source_List_File.Value);
- Error_Msg
- (Data.Flags,
- "file with sources { does not exist",
- Source_List_File.Location, Project.Project);
-
- else
- Get_Sources_From_File
- (Source_File_Path_Name, Source_List_File.Location,
- Project, Data);
- end if;
- end;
-
- else
- -- Neither Source_Files nor Source_List_File has been specified. Find
- -- all the files that satisfy the naming scheme in all the source
- -- directories.
-
- Has_Explicit_Sources := False;
- end if;
-
- -- Remove any exception that is not in the specified list of sources
-
- if Has_Explicit_Sources then
- declare
- Source : Source_Id;
- Iter : Source_Iterator;
- NL : Name_Location;
- Again : Boolean;
- begin
- Iter_Loop :
- loop
- Again := False;
- Iter := For_Each_Source (Data.Tree, Project.Project);
-
- Source_Loop :
- loop
- Source := Prj.Element (Iter);
- exit Source_Loop when Source = No_Source;
-
- if Source.Naming_Exception /= No then
- NL := Source_Names_Htable.Get
- (Project.Source_Names, Source.File);
-
- if NL /= No_Name_Location and then not NL.Listed then
-
- -- Remove the exception
-
- Source_Names_Htable.Set
- (Project.Source_Names,
- Source.File,
- No_Name_Location);
- Remove_Source (Data.Tree, Source, No_Source);
-
- if Source.Naming_Exception = Yes then
- Error_Msg_Name_1 := Name_Id (Source.File);
- Error_Msg
- (Data.Flags,
- "? unknown source file %%",
- NL.Location,
- Project.Project);
- end if;
-
- Again := True;
- exit Source_Loop;
- end if;
- end if;
-
- Next (Iter);
- end loop Source_Loop;
-
- exit Iter_Loop when not Again;
- end loop Iter_Loop;
- end;
- end if;
-
- Search_Directories
- (Project,
- Data => Data,
- For_All_Sources => Sources.Default and then Source_List_File.Default);
-
- -- Check if all exceptions have been found
-
- declare
- Source : Source_Id;
- Iter : Source_Iterator;
- Found : Boolean := False;
-
- begin
- Iter := For_Each_Source (Data.Tree, Project.Project);
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- -- If the full source path is unknown for this source_id, there
- -- could be several reasons:
- -- * we simply did not find the file itself, this is an error
- -- * we have a multi-unit source file. Another Source_Id from
- -- the same file has received the full path, so we need to
- -- propagate it.
-
- if Source.Path = No_Path_Information then
- if Source.Naming_Exception = Yes then
- if Source.Unit /= No_Unit_Index then
- Found := False;
-
- if Source.Index /= 0 then -- Only multi-unit files
- declare
- S : Source_Id :=
- Source_Files_Htable.Get
- (Data.Tree.Source_Files_HT, Source.File);
-
- begin
- while S /= null loop
- if S.Path /= No_Path_Information then
- Source.Path := S.Path;
- Found := True;
-
- if Current_Verbosity = High then
- Debug_Output
- ("setting full path for "
- & Get_Name_String (Source.File)
- & " at" & Source.Index'Img
- & " to "
- & Get_Name_String (Source.Path.Name));
- end if;
-
- exit;
- end if;
-
- S := S.Next_With_File_Name;
- end loop;
- end;
- end if;
-
- if not Found then
- Error_Msg_Name_1 := Name_Id (Source.Display_File);
- Error_Msg_Name_2 := Source.Unit.Name;
- Error_Or_Warning
- (Data.Flags, Data.Flags.Missing_Source_Files,
- "\source file %% for unit %% not found",
- No_Location, Project.Project);
- end if;
- end if;
-
- if Source.Path = No_Path_Information then
- Remove_Source (Data.Tree, Source, No_Source);
- end if;
-
- elsif Source.Naming_Exception = Inherited then
- Remove_Source (Data.Tree, Source, No_Source);
- end if;
- end if;
-
- Next (Iter);
- end loop;
- end;
-
- -- It is an error if a source file name in a source list or in a source
- -- list file is not found.
-
- if Has_Explicit_Sources then
- declare
- NL : Name_Location;
- First_Error : Boolean;
-
- begin
- NL := Source_Names_Htable.Get_First (Project.Source_Names);
- First_Error := True;
- while NL /= No_Name_Location loop
- if not NL.Found then
- Err_Vars.Error_Msg_File_1 := NL.Name;
- if First_Error then
- Error_Or_Warning
- (Data.Flags, Data.Flags.Missing_Source_Files,
- "source file { not found",
- NL.Location, Project.Project);
- First_Error := False;
- else
- Error_Or_Warning
- (Data.Flags, Data.Flags.Missing_Source_Files,
- "\source file { not found",
- NL.Location, Project.Project);
- end if;
- end if;
-
- NL := Source_Names_Htable.Get_Next (Project.Source_Names);
- end loop;
- end;
- end if;
- end Find_Sources;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Data : out Tree_Processing_Data;
- Tree : Project_Tree_Ref;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Prj.Processing_Flags)
- is
- begin
- Data.Tree := Tree;
- Data.Node_Tree := Node_Tree;
- Data.Flags := Flags;
- end Initialize;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Data : in out Tree_Processing_Data) is
- pragma Unreferenced (Data);
- begin
- null;
- end Free;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Data : in out Project_Processing_Data;
- Project : Project_Id)
- is
- begin
- Data.Project := Project;
- end Initialize;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Data : in out Project_Processing_Data) is
- begin
- Source_Names_Htable.Reset (Data.Source_Names);
- Unit_Exceptions_Htable.Reset (Data.Unit_Exceptions);
- Excluded_Sources_Htable.Reset (Data.Excluded);
- end Free;
-
- -------------------------------
- -- Check_File_Naming_Schemes --
- -------------------------------
-
- procedure Check_File_Naming_Schemes
- (Project : Project_Processing_Data;
- File_Name : File_Name_Type;
- Alternate_Languages : out Language_List;
- Language : out Language_Ptr;
- Display_Language_Name : out Name_Id;
- Unit : out Name_Id;
- Lang_Kind : out Language_Kind;
- Kind : out Source_Kind)
- is
- Filename : constant String := Get_Name_String (File_Name);
- Config : Language_Config;
- Tmp_Lang : Language_Ptr;
-
- Header_File : Boolean := False;
- -- True if we found at least one language for which the file is a header
- -- In such a case, we search for all possible languages where this is
- -- also a header (C and C++ for instance), since the file might be used
- -- for several such languages.
-
- procedure Check_File_Based_Lang;
- -- Does the naming scheme test for file-based languages. For those,
- -- there is no Unit. Just check if the file name has the implementation
- -- or, if it is specified, the template suffix of the language.
- --
- -- Returns True if the file belongs to the current language and we
- -- should stop searching for matching languages. Not that a given header
- -- file could belong to several languages (C and C++ for instance). Thus
- -- if we found a header we'll check whether it matches other languages.
-
- ---------------------------
- -- Check_File_Based_Lang --
- ---------------------------
-
- procedure Check_File_Based_Lang is
- begin
- if not Header_File
- and then Suffix_Matches (Filename, Config.Naming_Data.Body_Suffix)
- then
- Unit := No_Name;
- Kind := Impl;
- Language := Tmp_Lang;
-
- Debug_Output
- ("implementation of language ", Display_Language_Name);
-
- elsif Suffix_Matches (Filename, Config.Naming_Data.Spec_Suffix) then
- Debug_Output
- ("header of language ", Display_Language_Name);
-
- if Header_File then
- Alternate_Languages := new Language_List_Element'
- (Language => Language,
- Next => Alternate_Languages);
-
- else
- Header_File := True;
- Kind := Spec;
- Unit := No_Name;
- Language := Tmp_Lang;
- end if;
- end if;
- end Check_File_Based_Lang;
-
- -- Start of processing for Check_File_Naming_Schemes
-
- begin
- Language := No_Language_Index;
- Alternate_Languages := null;
- Display_Language_Name := No_Name;
- Unit := No_Name;
- Lang_Kind := File_Based;
- Kind := Spec;
-
- Tmp_Lang := Project.Project.Languages;
- while Tmp_Lang /= No_Language_Index loop
- if Current_Verbosity = High then
- Debug_Output
- ("testing language "
- & Get_Name_String (Tmp_Lang.Name)
- & " Header_File=" & Header_File'Img);
- end if;
-
- Display_Language_Name := Tmp_Lang.Display_Name;
- Config := Tmp_Lang.Config;
- Lang_Kind := Config.Kind;
-
- case Config.Kind is
- when File_Based =>
- Check_File_Based_Lang;
- exit when Kind = Impl;
-
- when Unit_Based =>
-
- -- We know it belongs to a least a file_based language, no
- -- need to check unit-based ones.
-
- if not Header_File then
- Compute_Unit_Name
- (File_Name => File_Name,
- Naming => Config.Naming_Data,
- Kind => Kind,
- Unit => Unit,
- Project => Project);
-
- if Unit /= No_Name then
- Language := Tmp_Lang;
- exit;
- end if;
- end if;
- end case;
-
- Tmp_Lang := Tmp_Lang.Next;
- end loop;
-
- if Language = No_Language_Index then
- Debug_Output ("not a source of any language");
- end if;
- end Check_File_Naming_Schemes;
-
- -------------------
- -- Override_Kind --
- -------------------
-
- procedure Override_Kind (Source : Source_Id; Kind : Source_Kind) is
- begin
- -- If the file was previously already associated with a unit, change it
-
- if Source.Unit /= null
- and then Source.Kind in Spec_Or_Body
- and then Source.Unit.File_Names (Source.Kind) /= null
- then
- -- If we had another file referencing the same unit (for instance it
- -- was in an extended project), that source file is in fact invisible
- -- from now on, and in particular doesn't belong to the same unit.
- -- If the source is an inherited naming exception, then it may not
- -- really exist: the source potentially replaced is left untouched.
-
- if Source.Unit.File_Names (Source.Kind) /= Source then
- Source.Unit.File_Names (Source.Kind).Unit := No_Unit_Index;
- end if;
-
- Source.Unit.File_Names (Source.Kind) := null;
- end if;
-
- Source.Kind := Kind;
-
- if Current_Verbosity = High and then Source.File /= No_File then
- Debug_Output ("override kind for "
- & Get_Name_String (Source.File)
- & " idx=" & Source.Index'Img
- & " kind=" & Source.Kind'Img);
- end if;
-
- if Source.Unit /= null then
- if Source.Kind = Spec then
- Source.Unit.File_Names (Spec) := Source;
- else
- Source.Unit.File_Names (Impl) := Source;
- end if;
- end if;
- end Override_Kind;
-
- ----------------
- -- Check_File --
- ----------------
-
- procedure Check_File
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data;
- Source_Dir_Rank : Natural;
- Path : Path_Name_Type;
- Display_Path : Path_Name_Type;
- File_Name : File_Name_Type;
- Display_File_Name : File_Name_Type;
- Locally_Removed : Boolean;
- For_All_Sources : Boolean)
- is
- Name_Loc : Name_Location :=
- Source_Names_Htable.Get
- (Project.Source_Names, File_Name);
- Check_Name : Boolean := False;
- Alternate_Languages : Language_List;
- Language : Language_Ptr;
- Source : Source_Id;
- Src_Ind : Source_File_Index;
- Unit : Name_Id;
- Display_Language_Name : Name_Id;
- Lang_Kind : Language_Kind;
- Kind : Source_Kind := Spec;
-
- begin
- if Current_Verbosity = High then
- Debug_Increase_Indent
- ("checking file (rank=" & Source_Dir_Rank'Img & ")",
- Name_Id (Display_Path));
- end if;
-
- if Name_Loc = No_Name_Location then
- Check_Name := For_All_Sources;
-
- else
- if Name_Loc.Found then
-
- -- Check if it is OK to have the same file name in several
- -- source directories.
-
- if Name_Loc.Source /= No_Source
- and then Source_Dir_Rank = Name_Loc.Source.Source_Dir_Rank
- then
- Error_Msg_File_1 := File_Name;
- Error_Msg
- (Data.Flags,
- "{ is found in several source directories",
- Name_Loc.Location, Project.Project);
- end if;
-
- else
- Name_Loc.Found := True;
-
- Source_Names_Htable.Set
- (Project.Source_Names, File_Name, Name_Loc);
-
- if Name_Loc.Source = No_Source then
- Check_Name := True;
-
- else
- -- Set the full path for the source_id (which might have been
- -- created when parsing the naming exceptions, and therefore
- -- might not have the full path).
- -- We only set this for this source_id, but not for other
- -- source_id in the same file (case of multi-unit source files)
- -- For the latter, they will be set in Find_Sources when we
- -- check that all source_id have known full paths.
- -- Doing this later saves one htable lookup per file in the
- -- common case where the user is not using multi-unit files.
-
- Name_Loc.Source.Path := (Path, Display_Path);
-
- Source_Paths_Htable.Set
- (Data.Tree.Source_Paths_HT, Path, Name_Loc.Source);
-
- -- Check if this is a subunit
-
- if Name_Loc.Source.Unit /= No_Unit_Index
- and then Name_Loc.Source.Kind = Impl
- then
- Src_Ind := Sinput.P.Load_Project_File
- (Get_Name_String (Display_Path));
-
- if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
- Override_Kind (Name_Loc.Source, Sep);
- end if;
- end if;
-
- -- If this is an inherited naming exception, make sure that
- -- the naming exception it replaces is no longer a source.
-
- if Name_Loc.Source.Naming_Exception = Inherited then
- declare
- Proj : Project_Id := Name_Loc.Source.Project.Extends;
- Iter : Source_Iterator;
- Src : Source_Id;
- begin
- while Proj /= No_Project loop
- Iter := For_Each_Source (Data.Tree, Proj);
- Src := Prj.Element (Iter);
- while Src /= No_Source loop
- if Src.File = Name_Loc.Source.File then
- Src.Replaced_By := Name_Loc.Source;
- exit;
- end if;
-
- Next (Iter);
- Src := Prj.Element (Iter);
- end loop;
-
- Proj := Proj.Extends;
- end loop;
- end;
-
- if Name_Loc.Source.Unit /= No_Unit_Index then
- if Name_Loc.Source.Kind = Spec then
- Name_Loc.Source.Unit.File_Names (Spec) :=
- Name_Loc.Source;
-
- elsif Name_Loc.Source.Kind = Impl then
- Name_Loc.Source.Unit.File_Names (Impl) :=
- Name_Loc.Source;
- end if;
-
- Units_Htable.Set
- (Data.Tree.Units_HT,
- Name_Loc.Source.Unit.Name,
- Name_Loc.Source.Unit);
- end if;
- end if;
- end if;
- end if;
- end if;
-
- if Check_Name then
- Check_File_Naming_Schemes
- (Project => Project,
- File_Name => File_Name,
- Alternate_Languages => Alternate_Languages,
- Language => Language,
- Display_Language_Name => Display_Language_Name,
- Unit => Unit,
- Lang_Kind => Lang_Kind,
- Kind => Kind);
-
- if Language = No_Language_Index then
-
- -- A file name in a list must be a source of a language
-
- if Data.Flags.Error_On_Unknown_Language and then Name_Loc.Found
- then
- Error_Msg_File_1 := File_Name;
- Error_Msg
- (Data.Flags,
- "language unknown for {",
- Name_Loc.Location, Project.Project);
- end if;
-
- else
- Add_Source
- (Id => Source,
- Project => Project.Project,
- Source_Dir_Rank => Source_Dir_Rank,
- Lang_Id => Language,
- Kind => Kind,
- Data => Data,
- Alternate_Languages => Alternate_Languages,
- File_Name => File_Name,
- Display_File => Display_File_Name,
- Unit => Unit,
- Locally_Removed => Locally_Removed,
- Path => (Path, Display_Path));
-
- -- If it is a source specified in a list, update the entry in
- -- the Source_Names table.
-
- if Name_Loc.Found and then Name_Loc.Source = No_Source then
- Name_Loc.Source := Source;
- Source_Names_Htable.Set
- (Project.Source_Names, File_Name, Name_Loc);
- end if;
- end if;
- end if;
-
- Debug_Decrease_Indent;
- end Check_File;
-
- ---------------------------------
- -- Expand_Subdirectory_Pattern --
- ---------------------------------
-
- procedure Expand_Subdirectory_Pattern
- (Project : Project_Id;
- Data : in out Tree_Processing_Data;
- Patterns : String_List_Id;
- Ignore : String_List_Id;
- Search_For : Search_Type;
- Resolve_Links : Boolean)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- package Recursive_Dirs is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => Path_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- Hash table stores recursive source directories, to avoid looking
- -- several times, and to avoid cycles that may be introduced by symbolic
- -- links.
-
- File_Pattern : GNAT.Regexp.Regexp;
- -- Pattern to use when matching file names
-
- Visited : Recursive_Dirs.Instance;
-
- procedure Find_Pattern
- (Pattern_Id : Name_Id;
- Rank : Natural;
- Location : Source_Ptr);
- -- Find a specific pattern
-
- function Recursive_Find_Dirs
- (Path : Path_Information;
- Rank : Natural) return Boolean;
- -- Search all the subdirectories (recursively) of Path.
- -- Return True if at least one file or directory was processed
-
- function Subdirectory_Matches
- (Path : Path_Information;
- Rank : Natural) return Boolean;
- -- Called when a matching directory was found. If the user is in fact
- -- searching for files, we then search for those files matching the
- -- pattern within the directory.
- -- Return True if at least one file or directory was processed
-
- --------------------------
- -- Subdirectory_Matches --
- --------------------------
-
- function Subdirectory_Matches
- (Path : Path_Information;
- Rank : Natural) return Boolean
- is
- Dir : Dir_Type;
- Name : String (1 .. 250);
- Last : Natural;
- Found : Path_Information;
- Success : Boolean := False;
-
- begin
- case Search_For is
- when Search_Directories =>
- Callback (Path, Rank);
- return True;
-
- when Search_Files =>
- Open (Dir, Get_Name_String (Path.Display_Name));
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
-
- if Name (Name'First .. Last) /= "."
- and then Name (Name'First .. Last) /= ".."
- and then Match (Name (Name'First .. Last), File_Pattern)
- then
- Get_Name_String (Path.Display_Name);
- Add_Str_To_Name_Buffer (Name (Name'First .. Last));
-
- Found.Display_Name := Name_Find;
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Found.Name := Name_Find;
-
- Callback (Found, Rank);
- Success := True;
- end if;
- end loop;
-
- Close (Dir);
-
- return Success;
- end case;
- end Subdirectory_Matches;
-
- -------------------------
- -- Recursive_Find_Dirs --
- -------------------------
-
- function Recursive_Find_Dirs
- (Path : Path_Information;
- Rank : Natural) return Boolean
- is
- Path_Str : constant String := Get_Name_String (Path.Display_Name);
- Dir : Dir_Type;
- Name : String (1 .. 250);
- Last : Natural;
- Success : Boolean := False;
-
- begin
- Debug_Output ("looking for subdirs of ", Name_Id (Path.Display_Name));
-
- if Recursive_Dirs.Get (Visited, Path.Name) then
- return Success;
- end if;
-
- Recursive_Dirs.Set (Visited, Path.Name, True);
-
- Success := Subdirectory_Matches (Path, Rank) or Success;
-
- Open (Dir, Path_Str);
-
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
-
- if Name (1 .. Last) /= "." and then Name (1 .. Last) /= ".." then
- declare
- Path_Name : constant String :=
- Normalize_Pathname
- (Name => Name (1 .. Last),
- Directory => Path_Str,
- Resolve_Links => Resolve_Links)
- & Directory_Separator;
-
- Path2 : Path_Information;
- OK : Boolean := True;
-
- begin
- if Is_Directory (Path_Name) then
- if Ignore /= Nil_String then
- declare
- Dir_Name : String := Name (1 .. Last);
- List : String_List_Id := Ignore;
-
- begin
- Canonical_Case_File_Name (Dir_Name);
-
- while List /= Nil_String loop
- Get_Name_String
- (Shared.String_Elements.Table (List).Value);
- Canonical_Case_File_Name
- (Name_Buffer (1 .. Name_Len));
- OK := Name_Buffer (1 .. Name_Len) /= Dir_Name;
- exit when not OK;
- List := Shared.String_Elements.Table (List).Next;
- end loop;
- end;
- end if;
-
- if OK then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Path_Name);
- Path2.Display_Name := Name_Find;
-
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Path2.Name := Name_Find;
-
- Success :=
- Recursive_Find_Dirs (Path2, Rank) or Success;
- end if;
- end if;
- end;
- end if;
- end loop;
-
- Close (Dir);
-
- return Success;
-
- exception
- when Directory_Error =>
- return Success;
- end Recursive_Find_Dirs;
-
- ------------------
- -- Find_Pattern --
- ------------------
-
- procedure Find_Pattern
- (Pattern_Id : Name_Id;
- Rank : Natural;
- Location : Source_Ptr)
- is
- Pattern : constant String := Get_Name_String (Pattern_Id);
- Pattern_End : Natural := Pattern'Last;
- Recursive : Boolean;
- Dir : File_Name_Type;
- Path_Name : Path_Information;
- Dir_Exists : Boolean;
- Has_Error : Boolean := False;
- Success : Boolean;
-
- begin
- Debug_Increase_Indent ("Find_Pattern", Pattern_Id);
-
- -- If we are looking for files, find the pattern for the files
-
- if Search_For = Search_Files then
- while Pattern_End >= Pattern'First
- and then not Is_Directory_Separator (Pattern (Pattern_End))
- loop
- Pattern_End := Pattern_End - 1;
- end loop;
-
- if Pattern_End = Pattern'Last then
- Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id);
- Error_Or_Warning
- (Data.Flags, Data.Flags.Missing_Source_Files,
- "Missing file name or pattern in {", Location, Project);
- return;
- end if;
-
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Str ("file_pattern=");
- Write_Str (Pattern (Pattern_End + 1 .. Pattern'Last));
- Write_Str (" dir_pattern=");
- Write_Line (Pattern (Pattern'First .. Pattern_End));
- end if;
-
- File_Pattern := Compile
- (Pattern (Pattern_End + 1 .. Pattern'Last),
- Glob => True,
- Case_Sensitive => File_Names_Case_Sensitive);
-
- -- If we had just "*.gpr", this is equivalent to "./*.gpr"
-
- if Pattern_End > Pattern'First then
- Pattern_End := Pattern_End - 1; -- Skip directory separator
- end if;
- end if;
-
- Recursive :=
- Pattern_End - 1 >= Pattern'First
- and then Pattern (Pattern_End - 1 .. Pattern_End) = "**"
- and then
- (Pattern_End - 1 = Pattern'First
- or else Is_Directory_Separator (Pattern (Pattern_End - 2)));
-
- if Recursive then
- Pattern_End := Pattern_End - 2;
- if Pattern_End > Pattern'First then
- Pattern_End := Pattern_End - 1; -- Skip '/'
- end if;
- end if;
-
- Name_Len := Pattern_End - Pattern'First + 1;
- Name_Buffer (1 .. Name_Len) := Pattern (Pattern'First .. Pattern_End);
- Dir := Name_Find;
-
- Locate_Directory
- (Project => Project,
- Name => Dir,
- Path => Path_Name,
- Dir_Exists => Dir_Exists,
- Data => Data,
- Must_Exist => False);
-
- if not Dir_Exists then
- Err_Vars.Error_Msg_File_1 := Dir;
- Error_Or_Warning
- (Data.Flags, Data.Flags.Missing_Source_Files,
- "{ is not a valid directory", Location, Project);
- Has_Error := Data.Flags.Missing_Source_Files = Error;
- end if;
-
- if not Has_Error then
-
- -- Links have been resolved if necessary, and Path_Name
- -- always ends with a directory separator.
-
- if Recursive then
- Success := Recursive_Find_Dirs (Path_Name, Rank);
- else
- Success := Subdirectory_Matches (Path_Name, Rank);
- end if;
-
- if not Success then
- case Search_For is
- when Search_Directories =>
- null; -- Error can't occur
-
- when Search_Files =>
- Err_Vars.Error_Msg_File_1 := File_Name_Type (Pattern_Id);
- Error_Or_Warning
- (Data.Flags, Data.Flags.Missing_Source_Files,
- "file { not found", Location, Project);
- end case;
- end if;
- end if;
-
- Debug_Decrease_Indent ("done Find_Pattern");
- end Find_Pattern;
-
- -- Local variables
-
- Pattern_Id : String_List_Id := Patterns;
- Element : String_Element;
- Rank : Natural := 1;
-
- -- Start of processing for Expand_Subdirectory_Pattern
-
- begin
- while Pattern_Id /= Nil_String loop
- Element := Shared.String_Elements.Table (Pattern_Id);
- Find_Pattern (Element.Value, Rank, Element.Location);
- Rank := Rank + 1;
- Pattern_Id := Element.Next;
- end loop;
-
- Recursive_Dirs.Reset (Visited);
- end Expand_Subdirectory_Pattern;
-
- ------------------------
- -- Search_Directories --
- ------------------------
-
- procedure Search_Directories
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data;
- For_All_Sources : Boolean)
- is
- Shared : constant Shared_Project_Tree_Data_Access := Data.Tree.Shared;
-
- Source_Dir : String_List_Id;
- Element : String_Element;
- Src_Dir_Rank : Number_List_Index;
- Num_Nod : Number_Node;
- Dir : Dir_Type;
- Name : String (1 .. 1_000);
- Last : Natural;
- File_Name : File_Name_Type;
- Display_File_Name : File_Name_Type;
-
- begin
- Debug_Increase_Indent ("looking for sources of", Project.Project.Name);
-
- -- Loop through subdirectories
-
- Src_Dir_Rank := Project.Project.Source_Dir_Ranks;
-
- Source_Dir := Project.Project.Source_Dirs;
- while Source_Dir /= Nil_String loop
- begin
- Num_Nod := Shared.Number_Lists.Table (Src_Dir_Rank);
- Element := Shared.String_Elements.Table (Source_Dir);
-
- -- Use Element.Value in this test, not Display_Value, because we
- -- want the symbolic links to be resolved when appropriate.
-
- if Element.Value /= No_Name then
- declare
- Source_Directory : constant String :=
- Get_Name_String (Element.Value)
- & Directory_Separator;
-
- Dir_Last : constant Natural :=
- Compute_Directory_Last (Source_Directory);
-
- Display_Source_Directory : constant String :=
- Get_Name_String
- (Element.Display_Value)
- & Directory_Separator;
- -- Display_Source_Directory is to allow us to open a UTF-8
- -- encoded directory on Windows.
-
- begin
- if Current_Verbosity = High then
- Debug_Increase_Indent
- ("Source_Dir (node=" & Num_Nod.Number'Img & ") """
- & Source_Directory (Source_Directory'First .. Dir_Last)
- & '"');
- end if;
-
- -- We look to every entry in the source directory
-
- Open (Dir, Display_Source_Directory);
-
- loop
- Read (Dir, Name, Last);
- exit when Last = 0;
-
- -- In fast project loading mode (without -eL), the user
- -- guarantees that no directory has a name which is a
- -- valid source name, so we can avoid doing a system call
- -- here. This provides a very significant speed up on
- -- slow file systems (remote files for instance).
-
- if not Opt.Follow_Links_For_Files
- or else Is_Regular_File
- (Display_Source_Directory & Name (1 .. Last))
- then
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
- Display_File_Name := Name_Find;
-
- if Osint.File_Names_Case_Sensitive then
- File_Name := Display_File_Name;
- else
- Canonical_Case_File_Name
- (Name_Buffer (1 .. Name_Len));
- File_Name := Name_Find;
- end if;
-
- declare
- Path_Name : constant String :=
- Normalize_Pathname
- (Name (1 .. Last),
- Directory =>
- Source_Directory
- (Source_Directory'First ..
- Dir_Last),
- Resolve_Links =>
- Opt.Follow_Links_For_Files,
- Case_Sensitive => True);
-
- Path : Path_Name_Type;
- FF : File_Found :=
- Excluded_Sources_Htable.Get
- (Project.Excluded, File_Name);
- To_Remove : Boolean := False;
-
- begin
- Name_Len := Path_Name'Length;
- Name_Buffer (1 .. Name_Len) := Path_Name;
-
- if Osint.File_Names_Case_Sensitive then
- Path := Name_Find;
- else
- Canonical_Case_File_Name
- (Name_Buffer (1 .. Name_Len));
- Path := Name_Find;
- end if;
-
- if FF /= No_File_Found then
- if not FF.Found then
- FF.Found := True;
- Excluded_Sources_Htable.Set
- (Project.Excluded, File_Name, FF);
-
- Debug_Output
- ("excluded source ",
- Name_Id (Display_File_Name));
-
- -- Will mark the file as removed, but we
- -- still need to add it to the list: if we
- -- don't, the file will not appear in the
- -- mapping file and will cause the compiler
- -- to fail.
-
- To_Remove := True;
- end if;
- end if;
-
- -- Preserve the user's original casing and use of
- -- links. The display_value (a directory) already
- -- ends with a directory separator by construction,
- -- so no need to add one.
-
- Get_Name_String (Element.Display_Value);
- Get_Name_String_And_Append (Display_File_Name);
-
- Check_File
- (Project => Project,
- Source_Dir_Rank => Num_Nod.Number,
- Data => Data,
- Path => Path,
- Display_Path => Name_Find,
- File_Name => File_Name,
- Locally_Removed => To_Remove,
- Display_File_Name => Display_File_Name,
- For_All_Sources => For_All_Sources);
- end;
-
- else
- if Current_Verbosity = High then
- Debug_Output ("ignore " & Name (1 .. Last));
- end if;
- end if;
- end loop;
-
- Debug_Decrease_Indent;
- Close (Dir);
- end;
- end if;
-
- exception
- when Directory_Error =>
- null;
- end;
-
- Source_Dir := Element.Next;
- Src_Dir_Rank := Num_Nod.Next;
- end loop;
-
- Debug_Decrease_Indent ("end looking for sources.");
- end Search_Directories;
-
- ----------------------------
- -- Load_Naming_Exceptions --
- ----------------------------
-
- procedure Load_Naming_Exceptions
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data)
- is
- Source : Source_Id;
- Iter : Source_Iterator;
-
- begin
- Iter := For_Each_Source (Data.Tree, Project.Project);
- loop
- Source := Prj.Element (Iter);
- exit when Source = No_Source;
-
- -- An excluded file cannot also be an exception file name
-
- if Excluded_Sources_Htable.Get (Project.Excluded, Source.File) /=
- No_File_Found
- then
- Error_Msg_File_1 := Source.File;
- Error_Msg
- (Data.Flags,
- "\{ cannot be both excluded and an exception file name",
- No_Location, Project.Project);
- end if;
-
- Debug_Output
- ("naming exception: adding source file to source_Names: ",
- Name_Id (Source.File));
-
- Source_Names_Htable.Set
- (Project.Source_Names,
- K => Source.File,
- E => Name_Location'
- (Name => Source.File,
- Location => Source.Location,
- Source => Source,
- Listed => False,
- Found => False));
-
- -- If this is an Ada exception, record in table Unit_Exceptions
-
- if Source.Unit /= No_Unit_Index then
- declare
- Unit_Except : Unit_Exception :=
- Unit_Exceptions_Htable.Get
- (Project.Unit_Exceptions, Source.Unit.Name);
-
- begin
- Unit_Except.Name := Source.Unit.Name;
-
- if Source.Kind = Spec then
- Unit_Except.Spec := Source.File;
- else
- Unit_Except.Impl := Source.File;
- end if;
-
- Unit_Exceptions_Htable.Set
- (Project.Unit_Exceptions, Source.Unit.Name, Unit_Except);
- end;
- end if;
-
- Next (Iter);
- end loop;
- end Load_Naming_Exceptions;
-
- ----------------------
- -- Look_For_Sources --
- ----------------------
-
- procedure Look_For_Sources
- (Project : in out Project_Processing_Data;
- Data : in out Tree_Processing_Data)
- is
- Object_Files : Object_File_Names_Htable.Instance;
- Iter : Source_Iterator;
- Src : Source_Id;
-
- procedure Check_Object (Src : Source_Id);
- -- Check if object file name of Src is already used in the project tree,
- -- and report an error if so.
-
- procedure Check_Object_Files;
- -- Check that no two sources of this project have the same object file
-
- procedure Mark_Excluded_Sources;
- -- Mark as such the sources that are declared as excluded
-
- procedure Check_Missing_Sources;
- -- Check whether one of the languages has no sources, and report an
- -- error when appropriate
-
- procedure Get_Sources_From_Source_Info;
- -- Get the source information from the tables that were created when a
- -- source info file was read.
-
- ---------------------------
- -- Check_Missing_Sources --
- ---------------------------
-
- procedure Check_Missing_Sources is
- Extending : constant Boolean :=
- Project.Project.Extends /= No_Project;
- Language : Language_Ptr;
- Source : Source_Id;
- Alt_Lang : Language_List;
- Continuation : Boolean := False;
- Iter : Source_Iterator;
- begin
- if not Project.Project.Externally_Built and then not Extending then
- Language := Project.Project.Languages;
- while Language /= No_Language_Index loop
-
- -- If there are no sources for this language, check if there
- -- 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)
- then
- Iter := For_Each_Source (In_Tree => Data.Tree,
- Project => Project.Project);
- Source_Loop : loop
- Source := Element (Iter);
- exit Source_Loop when Source = No_Source
- or else Source.Language = Language;
-
- Alt_Lang := Source.Alternate_Languages;
- while Alt_Lang /= null loop
- exit Source_Loop when Alt_Lang.Language = Language;
- Alt_Lang := Alt_Lang.Next;
- end loop;
-
- Next (Iter);
- end loop Source_Loop;
-
- if Source = No_Source then
- Report_No_Sources
- (Project.Project,
- Get_Name_String (Language.Display_Name),
- Data,
- Project.Source_List_File_Location,
- Continuation);
- Continuation := True;
- end if;
- end if;
-
- Language := Language.Next;
- end loop;
- end if;
- end Check_Missing_Sources;
-
- ------------------
- -- Check_Object --
- ------------------
-
- procedure Check_Object (Src : Source_Id) is
- Source : Source_Id;
-
- begin
- Source := Object_File_Names_Htable.Get (Object_Files, Src.Object);
-
- -- We cannot just check on "Source /= Src", since we might have
- -- two different entries for the same file (and since that's
- -- the same file it is expected that it has the same object)
-
- if Source /= No_Source
- and then Source.Replaced_By = No_Source
- and then Source.Path /= Src.Path
- and then Source.Index = 0
- and then Src.Index = 0
- and then Is_Extending (Src.Project, Source.Project)
- then
- Error_Msg_File_1 := Src.File;
- Error_Msg_File_2 := Source.File;
- Error_Msg
- (Data.Flags,
- "\{ and { have the same object file name",
- No_Location, Project.Project);
-
- else
- Object_File_Names_Htable.Set (Object_Files, Src.Object, Src);
- end if;
- end Check_Object;
-
- ---------------------------
- -- Mark_Excluded_Sources --
- ---------------------------
-
- procedure Mark_Excluded_Sources is
- Source : Source_Id := No_Source;
- Excluded : File_Found;
- Proj : Project_Id;
-
- begin
- -- Minor optimization: if there are no excluded files, no need to
- -- traverse the list of sources. We cannot however also check whether
- -- the existing exceptions have ".Found" set to True (indicating we
- -- found them before) because we need to do some final processing on
- -- them in any case.
-
- if Excluded_Sources_Htable.Get_First (Project.Excluded) /=
- No_File_Found
- then
- Proj := Project.Project;
- while Proj /= No_Project loop
- Iter := For_Each_Source (Data.Tree, Proj);
- while Prj.Element (Iter) /= No_Source loop
- Source := Prj.Element (Iter);
- Excluded := Excluded_Sources_Htable.Get
- (Project.Excluded, Source.File);
-
- if Excluded /= No_File_Found then
- Source.In_Interfaces := False;
- Source.Locally_Removed := True;
-
- if Proj = Project.Project then
- Source.Suppressed := True;
- end if;
-
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Str ("removing file ");
- Write_Line
- (Get_Name_String (Excluded.File)
- & " " & Get_Name_String (Source.Project.Name));
- end if;
-
- Excluded_Sources_Htable.Remove
- (Project.Excluded, Source.File);
- end if;
-
- Next (Iter);
- end loop;
-
- Proj := Proj.Extends;
- end loop;
- end if;
-
- -- If we have any excluded element left, that means we did not find
- -- the source file
-
- Excluded := Excluded_Sources_Htable.Get_First (Project.Excluded);
- while Excluded /= No_File_Found loop
- if not Excluded.Found then
-
- -- Check if the file belongs to another imported project to
- -- provide a better error message.
-
- Src := Find_Source
- (In_Tree => Data.Tree,
- Project => Project.Project,
- In_Imported_Only => True,
- Base_Name => Excluded.File);
-
- Err_Vars.Error_Msg_File_1 := Excluded.File;
-
- if Src = No_Source then
- if Excluded.Excl_File = No_File then
- Error_Msg
- (Data.Flags,
- "unknown file {", Excluded.Location, Project.Project);
-
- else
- Error_Msg
- (Data.Flags,
- "in " &
- Get_Name_String (Excluded.Excl_File) & ":" &
- No_Space_Img (Excluded.Excl_Line) &
- ": unknown file {", Excluded.Location, Project.Project);
- end if;
-
- else
- if Excluded.Excl_File = No_File then
- Error_Msg
- (Data.Flags,
- "cannot remove a source from an imported project: {",
- Excluded.Location, Project.Project);
-
- else
- Error_Msg
- (Data.Flags,
- "in " &
- Get_Name_String (Excluded.Excl_File) & ":" &
- No_Space_Img (Excluded.Excl_Line) &
- ": cannot remove a source from an imported project: {",
- Excluded.Location, Project.Project);
- end if;
- end if;
- end if;
-
- Excluded := Excluded_Sources_Htable.Get_Next (Project.Excluded);
- end loop;
- end Mark_Excluded_Sources;
-
- ------------------------
- -- Check_Object_Files --
- ------------------------
-
- procedure Check_Object_Files is
- Iter : Source_Iterator;
- Src_Id : Source_Id;
- Src_Ind : Source_File_Index;
-
- begin
- Iter := For_Each_Source (Data.Tree);
- loop
- Src_Id := Prj.Element (Iter);
- exit when Src_Id = No_Source;
-
- if Is_Compilable (Src_Id)
- and then Src_Id.Language.Config.Object_Generated
- and then Is_Extending (Project.Project, Src_Id.Project)
- then
- if Src_Id.Unit = No_Unit_Index then
- if Src_Id.Kind = Impl then
- Check_Object (Src_Id);
- end if;
-
- else
- case Src_Id.Kind is
- when Spec =>
- if Other_Part (Src_Id) = No_Source then
- Check_Object (Src_Id);
- end if;
-
- when Sep =>
- null;
-
- when Impl =>
- if Other_Part (Src_Id) /= No_Source then
- Check_Object (Src_Id);
-
- else
- -- Check if it is a subunit
-
- Src_Ind :=
- Sinput.P.Load_Project_File
- (Get_Name_String (Src_Id.Path.Display_Name));
-
- if Sinput.P.Source_File_Is_Subunit (Src_Ind) then
- Override_Kind (Src_Id, Sep);
- else
- Check_Object (Src_Id);
- end if;
- end if;
- end case;
- end if;
- end if;
-
- Next (Iter);
- end loop;
- end Check_Object_Files;
-
- ----------------------------------
- -- Get_Sources_From_Source_Info --
- ----------------------------------
-
- procedure Get_Sources_From_Source_Info is
- Iter : Source_Info_Iterator;
- Src : Source_Info;
- Id : Source_Id;
- Lang_Id : Language_Ptr;
-
- begin
- Initialize (Iter, Project.Project.Name);
-
- loop
- Src := Source_Info_Of (Iter);
-
- exit when Src = No_Source_Info;
-
- Id := new Source_Data;
-
- Id.Project := Project.Project;
-
- Lang_Id := Project.Project.Languages;
- while Lang_Id /= No_Language_Index
- and then Lang_Id.Name /= Src.Language
- loop
- Lang_Id := Lang_Id.Next;
- end loop;
-
- if Lang_Id = No_Language_Index then
- Prj.Com.Fail
- ("unknown language " &
- Get_Name_String (Src.Language) &
- " for project " &
- Get_Name_String (Src.Project) &
- " in source info file");
- end if;
-
- Id.Language := Lang_Id;
- Id.Kind := Src.Kind;
- Id.Index := Src.Index;
-
- Id.Path :=
- (Path_Name_Type (Src.Display_Path_Name),
- Path_Name_Type (Src.Path_Name));
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (Directories.Simple_Name (Get_Name_String (Src.Path_Name)));
- Id.File := Name_Find;
-
- Id.Next_With_File_Name :=
- Source_Files_Htable.Get (Data.Tree.Source_Files_HT, Id.File);
- Source_Files_Htable.Set (Data.Tree.Source_Files_HT, Id.File, Id);
-
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (Directories.Simple_Name
- (Get_Name_String (Src.Display_Path_Name)));
- Id.Display_File := Name_Find;
-
- Id.Dep_Name :=
- Dependency_Name (Id.File, Id.Language.Config.Dependency_Kind);
- Id.Naming_Exception := Src.Naming_Exception;
- Id.Object :=
- Object_Name (Id.File, Id.Language.Config.Object_File_Suffix);
- Id.Switches := Switches_Name (Id.File);
-
- -- Add the source id to the Unit_Sources_HT hash table, if the
- -- unit name is not null.
-
- if Src.Kind /= Sep and then Src.Unit_Name /= No_Name then
- declare
- UData : Unit_Index :=
- Units_Htable.Get (Data.Tree.Units_HT, Src.Unit_Name);
- begin
- if UData = No_Unit_Index then
- UData := new Unit_Data;
- UData.Name := Src.Unit_Name;
- Units_Htable.Set
- (Data.Tree.Units_HT, Src.Unit_Name, UData);
- end if;
-
- Id.Unit := UData;
- end;
-
- -- Note that this updates Unit information as well
-
- Override_Kind (Id, Id.Kind);
- end if;
-
- if Src.Index /= 0 then
- Project.Project.Has_Multi_Unit_Sources := True;
- end if;
-
- -- Add the source to the language list
-
- Id.Next_In_Lang := Id.Language.First_Source;
- Id.Language.First_Source := Id;
-
- Next (Iter);
- end loop;
- end Get_Sources_From_Source_Info;
-
- -- Start of processing for Look_For_Sources
-
- begin
- if Data.Tree.Source_Info_File_Exists then
- Get_Sources_From_Source_Info;
-
- else
- if Project.Project.Source_Dirs /= Nil_String then
- Find_Excluded_Sources (Project, Data);
-
- if Project.Project.Languages /= No_Language_Index then
- Load_Naming_Exceptions (Project, Data);
- Find_Sources (Project, Data);
- Mark_Excluded_Sources;
- Check_Object_Files;
- Check_Missing_Sources;
- end if;
- end if;
-
- Object_File_Names_Htable.Reset (Object_Files);
- end if;
- end Look_For_Sources;
-
- ------------------
- -- Path_Name_Of --
- ------------------
-
- function Path_Name_Of
- (File_Name : File_Name_Type;
- Directory : Path_Name_Type) return String
- is
- Result : String_Access;
- The_Directory : constant String := Get_Name_String (Directory);
-
- begin
- Debug_Output ("Path_Name_Of file name=", Name_Id (File_Name));
- Debug_Output ("Path_Name_Of directory=", Name_Id (Directory));
- Get_Name_String (File_Name);
- Result :=
- Locate_Regular_File
- (File_Name => Name_Buffer (1 .. Name_Len),
- Path => The_Directory);
-
- if Result = null then
- return "";
- else
- declare
- R : constant String := Result.all;
- begin
- Free (Result);
- return R;
- end;
- end if;
- end Path_Name_Of;
-
- -------------------
- -- Remove_Source --
- -------------------
-
- procedure Remove_Source
- (Tree : Project_Tree_Ref;
- Id : Source_Id;
- Replaced_By : Source_Id)
- is
- Source : Source_Id;
-
- begin
- if Current_Verbosity = High then
- Debug_Indent;
- Write_Str ("removing source ");
- Write_Str (Get_Name_String (Id.File));
-
- if Id.Index /= 0 then
- Write_Str (" at" & Id.Index'Img);
- end if;
-
- Write_Eol;
- end if;
-
- if Replaced_By /= No_Source then
- Id.Replaced_By := Replaced_By;
- Replaced_By.Declared_In_Interfaces := Id.Declared_In_Interfaces;
-
- if Id.File /= Replaced_By.File then
- declare
- Replacement : constant File_Name_Type :=
- Replaced_Source_HTable.Get
- (Tree.Replaced_Sources, Id.File);
-
- begin
- Replaced_Source_HTable.Set
- (Tree.Replaced_Sources, Id.File, Replaced_By.File);
-
- if Replacement = No_File then
- Tree.Replaced_Source_Number :=
- Tree.Replaced_Source_Number + 1;
- end if;
- end;
- end if;
- end if;
-
- Id.In_Interfaces := False;
- Id.Locally_Removed := True;
-
- -- ??? Should we remove the source from the unit ? The file is not used,
- -- so probably should not be referenced from the unit. On the other hand
- -- it might give useful additional info
- -- if Id.Unit /= null then
- -- Id.Unit.File_Names (Id.Kind) := null;
- -- end if;
-
- Source := Id.Language.First_Source;
-
- if Source = Id then
- Id.Language.First_Source := Id.Next_In_Lang;
-
- else
- while Source.Next_In_Lang /= Id loop
- Source := Source.Next_In_Lang;
- end loop;
-
- Source.Next_In_Lang := Id.Next_In_Lang;
- end if;
- end Remove_Source;
-
- -----------------------
- -- Report_No_Sources --
- -----------------------
-
- procedure Report_No_Sources
- (Project : Project_Id;
- Lang_Name : String;
- Data : Tree_Processing_Data;
- Location : Source_Ptr;
- Continuation : Boolean := False)
- is
- begin
- case Data.Flags.When_No_Sources is
- when Silent =>
- null;
-
- when Error
- | Warning
- =>
- declare
- Msg : constant String :=
- "<there are no " & Lang_Name
- & " sources in this project";
-
- begin
- Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;
-
- if Continuation then
- Error_Msg (Data.Flags, "\" & Msg, Location, Project);
- else
- Error_Msg (Data.Flags, Msg, Location, Project);
- end if;
- end;
- end case;
- end Report_No_Sources;
-
- ----------------------
- -- Show_Source_Dirs --
- ----------------------
-
- procedure Show_Source_Dirs
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access)
- is
- Current : String_List_Id;
- 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 := Shared.String_Elements.Table (Current);
- 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;
-
- ---------------------------
- -- Process_Naming_Scheme --
- ---------------------------
-
- procedure Process_Naming_Scheme
- (Tree : Project_Tree_Ref;
- Root_Project : Project_Id;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Processing_Flags)
- is
-
- procedure Check
- (Project : Project_Id;
- In_Aggregate_Lib : Boolean;
- Data : in out Tree_Processing_Data);
- -- Process the naming scheme for a single project
-
- procedure Recursive_Check
- (Project : Project_Id;
- Prj_Tree : Project_Tree_Ref;
- Context : Project_Context;
- Data : in out Tree_Processing_Data);
- -- Check_Naming_Scheme for the project
-
- -----------
- -- Check --
- -----------
-
- procedure Check
- (Project : Project_Id;
- In_Aggregate_Lib : Boolean;
- Data : in out Tree_Processing_Data)
- is
- procedure Check_Aggregated;
- -- Check aggregated projects which should not be externally built
-
- ----------------------
- -- Check_Aggregated --
- ----------------------
-
- procedure Check_Aggregated is
- L : Aggregated_Project_List;
-
- begin
- -- Check that aggregated projects are not externally built
-
- L := Project.Aggregated_Projects;
- while L /= null loop
- declare
- Var : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Externally_Built,
- L.Project.Decl.Attributes,
- Data.Tree.Shared);
- begin
- if not Var.Default then
- Error_Msg_Name_1 := L.Project.Display_Name;
- Error_Msg
- (Data.Flags,
- "cannot aggregate externally built project %%",
- Var.Location, Project);
- end if;
- end;
-
- L := L.Next;
- end loop;
- end Check_Aggregated;
-
- -- Local Variables
-
- Shared : constant Shared_Project_Tree_Data_Access :=
- Data.Tree.Shared;
- Prj_Data : Project_Processing_Data;
-
- -- Start of processing for Check
-
- begin
- Debug_Increase_Indent ("check", Project.Name);
-
- Initialize (Prj_Data, Project);
-
- Check_If_Externally_Built (Project, Data);
-
- case Project.Qualifier is
- when Aggregate =>
- Check_Aggregated;
-
- when Aggregate_Library =>
- Check_Aggregated;
-
- if Project.Object_Directory = No_Path_Information then
- Project.Object_Directory := Project.Directory;
- end if;
-
- when others =>
- Get_Directories (Project, Data);
- Check_Programming_Languages (Project, Data);
-
- if Current_Verbosity = High then
- Show_Source_Dirs (Project, Shared);
- end if;
-
- if Project.Qualifier = Abstract_Project then
- Check_Abstract_Project (Project, Data);
- end if;
- end case;
-
- -- Check configuration. Must be done for gnatmake (even though no
- -- user configuration file was provided) since the default config we
- -- generate indicates whether libraries are supported for instance.
-
- Check_Configuration (Project, Data);
-
- if Project.Qualifier /= Aggregate then
- Check_Library_Attributes (Project, Data);
- Check_Package_Naming (Project, Data);
-
- -- An aggregate library has no source, no need to look for them
-
- if Project.Qualifier /= Aggregate_Library then
- Look_For_Sources (Prj_Data, Data);
- end if;
-
- Check_Interfaces (Project, Data);
-
- -- If this library is part of an aggregated library don't check it
- -- as it has no sources by itself and so interface won't be found.
-
- if Project.Library and not In_Aggregate_Lib then
- Check_Stand_Alone_Library (Project, Data);
- end if;
-
- Get_Mains (Project, Data);
- end if;
-
- Free (Prj_Data);
-
- Debug_Decrease_Indent ("done check");
- end Check;
-
- ---------------------
- -- Recursive_Check --
- ---------------------
-
- procedure Recursive_Check
- (Project : Project_Id;
- Prj_Tree : Project_Tree_Ref;
- Context : Project_Context;
- Data : in out Tree_Processing_Data)
- is
- begin
- if Current_Verbosity = High then
- Debug_Increase_Indent
- ("Processing_Naming_Scheme for project", Project.Name);
- end if;
-
- Data.Tree := Prj_Tree;
- Data.In_Aggregate_Lib := Context.In_Aggregate_Lib;
-
- Check (Project, Context.In_Aggregate_Lib, Data);
-
- if Current_Verbosity = High then
- Debug_Decrease_Indent ("done Processing_Naming_Scheme");
- end if;
- end Recursive_Check;
-
- procedure Check_All_Projects is new For_Every_Project_Imported_Context
- (Tree_Processing_Data, Recursive_Check);
- -- Comment required???
-
- -- Local Variables
-
- Data : Tree_Processing_Data;
-
- -- Start of processing for Process_Naming_Scheme
-
- begin
- Lib_Data_Table.Init;
- Initialize (Data, Tree => Tree, Node_Tree => Node_Tree, Flags => Flags);
- Check_All_Projects (Root_Project, Tree, Data, Imported_First => True);
- Free (Data);
-
- -- Adjust language configs for projects that are extended
-
- declare
- List : Project_List;
- Proj : Project_Id;
- Exte : Project_Id;
- Lang : Language_Ptr;
- Elng : Language_Ptr;
-
- begin
- List := Tree.Projects;
- while List /= null loop
- Proj := List.Project;
-
- Exte := Proj;
- while Exte.Extended_By /= No_Project loop
- Exte := Exte.Extended_By;
- end loop;
-
- if Exte /= Proj then
- Lang := Proj.Languages;
-
- if Lang /= No_Language_Index then
- loop
- Elng := Get_Language_From_Name
- (Exte, Get_Name_String (Lang.Name));
- exit when Elng /= No_Language_Index;
- Exte := Exte.Extends;
- end loop;
-
- if Elng /= Lang then
- Lang.Config := Elng.Config;
- end if;
- end if;
- end if;
-
- List := List.Next;
- end loop;
- end;
- end Process_Naming_Scheme;
-
-end Prj.Nmsc;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . N M S C --
--- --
--- S p e c --
--- --
--- Copyright (C) 2000-2011, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Find source dirs and source files for a project
-
-with Prj.Tree;
-
-private package Prj.Nmsc is
-
- procedure Process_Naming_Scheme
- (Tree : Project_Tree_Ref;
- Root_Project : Project_Id;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Processing_Flags);
- -- Perform consistency and semantic checks on all the projects in the tree.
- -- This procedure interprets the various case statements in the project
- -- based on the current external references. After checking the validity of
- -- the naming scheme, it searches for all the source files of the project.
- -- The result of this procedure is a filled-in data structure for
- -- Project_Id which contains all the information about the project. This
- -- information is only valid while the external references are preserved.
-
- procedure Process_Aggregated_Projects
- (Tree : Project_Tree_Ref;
- Project : Project_Id;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Processing_Flags);
- -- Assuming Project is an aggregate project, find out (based on the
- -- current external references) what are the projects it aggregates.
- -- This has to be done in phase 1 of the processing, so that we know the
- -- full list of languages required for root_project and its aggregated
- -- projects. As a result, it cannot be done as part of
- -- Process_Naming_Scheme.
-
-end Prj.Nmsc;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P A R S --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Exceptions; use Ada.Exceptions;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-
-with Output; use Output;
-with Prj.Conf; use Prj.Conf;
-with Prj.Err; use Prj.Err;
-with Prj.Part;
-with Prj.Tree; use Prj.Tree;
-with Sinput.P;
-
-package body Prj.Pars is
-
- -----------
- -- Parse --
- -----------
-
- procedure Parse
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Project_File_Name : String;
- Packages_To_Check : String_List_Access;
- Reset_Tree : Boolean := True;
- In_Node_Tree : Prj.Tree.Project_Node_Tree_Ref := null;
- Env : in out Prj.Tree.Environment)
- is
- Project_Node : Project_Node_Id := Empty_Node;
- The_Project : Project_Id := No_Project;
- Success : Boolean := True;
- Current_Dir : constant String := Get_Current_Dir;
- Project_Node_Tree : Prj.Tree.Project_Node_Tree_Ref := In_Node_Tree;
- Automatically_Generated : Boolean;
- Config_File_Path : String_Access;
-
- begin
- if Project_Node_Tree = null then
- Project_Node_Tree := new Project_Node_Tree_Data;
- Prj.Tree.Initialize (Project_Node_Tree);
- end if;
-
- -- Parse the main project file into a tree
-
- Sinput.P.Reset_First;
- Prj.Part.Parse
- (In_Tree => Project_Node_Tree,
- Project => Project_Node,
- Project_File_Name => Project_File_Name,
- Errout_Handling => Prj.Part.Finalize_If_Error,
- Packages_To_Check => Packages_To_Check,
- Current_Directory => Current_Dir,
- Env => Env,
- Is_Config_File => False);
-
- -- If there were no error, process the tree
-
- if Project_Node /= Empty_Node then
- begin
- -- No config file should be read from the disk for gnatmake.
- -- However, we will simulate one that only contains the default
- -- GNAT naming scheme.
-
- Process_Project_And_Apply_Config
- (Main_Project => The_Project,
- User_Project_Node => Project_Node,
- Config_File_Name => No_Configuration_File,
- Autoconf_Specified => False,
- Project_Tree => In_Tree,
- Project_Node_Tree => Project_Node_Tree,
- Packages_To_Check => null,
- Allow_Automatic_Generation => False,
- Automatically_Generated => Automatically_Generated,
- Config_File_Path => Config_File_Path,
- Env => Env,
- Normalized_Hostname => "",
- On_Load_Config =>
- Add_Default_GNAT_Naming_Scheme'Access,
- Reset_Tree => Reset_Tree);
-
- Success := The_Project /= No_Project;
-
- exception
- when E : Invalid_Config =>
- Osint.Fail (Exception_Message (E));
- end;
-
- Prj.Err.Finalize;
-
- if not Success then
- The_Project := No_Project;
- end if;
- end if;
-
- Project := The_Project;
-
- -- ??? Should free the project_node_tree, no longer useful
-
- exception
- when X : others =>
-
- -- Internal error
-
- Write_Line (Exception_Information (X));
- Write_Str ("Exception ");
- Write_Str (Exception_Name (X));
- Write_Line (" raised, while processing project file");
- Project := No_Project;
- end Parse;
-
- -------------------
- -- Set_Verbosity --
- -------------------
-
- procedure Set_Verbosity (To : Verbosity) is
- begin
- Current_Verbosity := To;
- end Set_Verbosity;
-
-end Prj.Pars;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P A R S --
--- --
--- S p e c --
--- --
--- Copyright (C) 2000-2011, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- General wrapper for the parsing of project files
-
-with Prj.Tree;
-
-package Prj.Pars is
-
- procedure Set_Verbosity (To : Verbosity);
- -- Set the verbosity when parsing the project files
-
- procedure Parse
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Project_File_Name : String;
- Packages_To_Check : String_List_Access;
- Reset_Tree : Boolean := True;
- In_Node_Tree : Prj.Tree.Project_Node_Tree_Ref := null;
- 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
- -- references. This function is only a convenient wrapper over other
- -- services provided in the Prj.* package hierarchy.
- --
- -- If parsing is successful, Project is the project ID of the root project
- -- file; otherwise, Project_Id is set to No_Project. Project_Node_Tree is
- -- set to the tree (unprocessed) representation of the project file. This
- -- tree is permanently correct, whereas Project will need to be recomputed
- -- if the external references change.
- --
- -- Packages_To_Check indicates the packages where any unknown attribute
- -- produces an error. For other packages, an unknown attribute produces a
- -- warning.
- --
- -- When Reset_Tree is True, all the project data are removed from the
- -- project table before processing.
- --
- -- In_Node_Tree (if given) must have been Initialized. The main reason to
- -- pass an existing tree, is to pass the external references that will then
- -- be used to process the tree.
-
-end Prj.Pars;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P A R T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Atree; use Atree;
-with Err_Vars; use Err_Vars;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Com; use Prj.Com;
-with Prj.Dect;
-with Prj.Env; use Prj.Env;
-with Prj.Err; use Prj.Err;
-with Sinput; use Sinput;
-with Sinput.P; use Sinput.P;
-with Snames;
-with Table;
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Exceptions; use Ada.Exceptions;
-
-with GNAT.HTable; use GNAT.HTable;
-
-package body Prj.Part is
-
- Buffer : String_Access;
- Buffer_Last : Natural := 0;
-
- Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
-
- ------------------------------------
- -- Local Packages and Subprograms --
- ------------------------------------
-
- type With_Id is new Nat;
- No_With : constant With_Id := 0;
-
- type With_Record is record
- Path : Path_Name_Type;
- Location : Source_Ptr;
- Limited_With : Boolean;
- Node : Project_Node_Id;
- Next : With_Id;
- end record;
- -- Information about an imported project, to be put in table Withs below
-
- package Withs is new Table.Table
- (Table_Component_Type => With_Record,
- Table_Index_Type => With_Id,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Part.Withs");
- -- Table used to store temporarily paths and locations of imported
- -- projects. These imported projects will be effectively parsed later: just
- -- before parsing the current project for the non limited withed projects,
- -- after getting its name; after complete parsing of the current project
- -- for the limited withed projects.
-
- type Names_And_Id is record
- Path_Name : Path_Name_Type;
- Canonical_Path_Name : Path_Name_Type;
- Id : Project_Node_Id;
- Limited_With : Boolean;
- end record;
-
- package Project_Stack is new Table.Table
- (Table_Component_Type => Names_And_Id,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Part.Project_Stack");
- -- This table is used to detect circular dependencies
- -- for imported and extended projects and to get the project ids of
- -- limited imported projects when there is a circularity with at least
- -- one limited imported project file.
-
- package Virtual_Hash is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Project_Node_Id,
- No_Element => Project_Node_High_Bound,
- Key => Project_Node_Id,
- Hash => Prj.Tree.Hash,
- Equal => "=");
- -- Hash table to store the node ids of projects for which a virtual
- -- extending project need to be created. The corresponding value is the
- -- head of a list of WITH clauses corresponding to the context of the
- -- enclosing EXTEND ALL projects. Note: Default_Element is Project_Node_
- -- High_Bound because we want Empty_Node to be a possible value.
-
- package Processed_Hash is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => Project_Node_Id,
- Hash => Prj.Tree.Hash,
- Equal => "=");
- -- Hash table to store the project process when looking for project that
- -- need to have a virtual extending project, to avoid processing the same
- -- project twice.
-
- function Has_Circular_Dependencies
- (Flags : Processing_Flags;
- Normed_Path_Name : Path_Name_Type;
- Canonical_Path_Name : Path_Name_Type) return Boolean;
- -- Check for a circular dependency in the loaded project.
- -- Generates an error message in such a case.
-
- procedure Read_Project_Qualifier
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Is_Config_File : Boolean;
- Qualifier_Location : out Source_Ptr;
- Project : Project_Node_Id);
- -- Check if there is a qualifier before the reserved word "project"
-
- -- Hash table to cache project path to avoid looking for them on the path
-
- procedure Check_Extending_All_Imports
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id);
- -- Check that a non extending-all project does not import an
- -- extending-all project.
-
- procedure Check_Aggregate_Imports
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id);
- -- Check that an aggregate project only imports abstract projects
-
- procedure Check_Import_Aggregate
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id);
- -- Check that a non aggregate project does not import an aggregate project
-
- procedure Create_Virtual_Extending_Project
- (For_Project : Project_Node_Id;
- Main_Project : Project_Node_Id;
- Extension_Withs : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref);
- -- Create a virtual extending project of For_Project. Main_Project is
- -- the extending all project. Extension_Withs is the head of a WITH clause
- -- list to be added to the created virtual project.
- --
- -- The String_Value_Of is not set for the automatically added with
- -- clause and keeps the default value of No_Name. This enables Prj.PP
- -- to skip these automatically added with clauses to be processed.
-
- procedure Look_For_Virtual_Projects_For
- (Proj : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Potentially_Virtual : Boolean);
- -- Look for projects that need to have a virtual extending project.
- -- This procedure is recursive. If called with Potentially_Virtual set to
- -- True, then Proj may need an virtual extending project; otherwise it
- -- does not (because it is already extended), but other projects that it
- -- imports may need to be virtually extended.
-
- type Extension_Origin is (None, Extending_Simple, Extending_All);
- -- Type of parameter From_Extended for procedures Parse_Single_Project and
- -- Post_Parse_Context_Clause. Extending_All means that we are parsing the
- -- tree rooted at an extending all project.
-
- procedure Parse_Single_Project
- (In_Tree : Project_Node_Tree_Ref;
- Project : out Project_Node_Id;
- Extends_All : out Boolean;
- Path_Name_Id : Path_Name_Type;
- Extended : Boolean;
- From_Extended : Extension_Origin;
- In_Limited : Boolean;
- Packages_To_Check : String_List_Access;
- Depth : Natural;
- Current_Dir : String;
- Is_Config_File : Boolean;
- Env : in out Environment;
- Implicit_Project : Boolean := False);
- -- Parse a project file. This is a recursive procedure: it calls itself for
- -- imported and extended projects. When From_Extended is not None, if the
- -- project has already been parsed and is an extended project A, return the
- -- ultimate (not extended) project that extends A. When In_Limited is True,
- -- the importing path includes at least one "limited with". When parsing
- -- configuration projects, do not allow a depth > 1.
- --
- -- Is_Config_File should be set to True if the project represents a config
- -- file (.cgpr) since some specific checks apply.
- --
- -- If Implicit_Project is True, change the Directory of the project node
- -- to be the Current_Dir. Recursive calls to Parse_Single_Project are
- -- always done with the default False value for Implicit_Project.
-
- procedure Pre_Parse_Context_Clause
- (In_Tree : Project_Node_Tree_Ref;
- Context_Clause : out With_Id;
- Is_Config_File : Boolean;
- Flags : Processing_Flags);
- -- Parse the context clause of a project. Store the paths and locations of
- -- the imported projects in table Withs. Does nothing if there is no
- -- context clause (if the current token is not "with" or "limited" followed
- -- by "with").
- -- Is_Config_File should be set to True if the project represents a config
- -- file (.cgpr) since some specific checks apply.
-
- procedure Post_Parse_Context_Clause
- (Context_Clause : With_Id;
- In_Tree : Project_Node_Tree_Ref;
- In_Limited : Boolean;
- Limited_Withs : Boolean;
- Imported_Projects : in out Project_Node_Id;
- Project_Directory : Path_Name_Type;
- From_Extended : Extension_Origin;
- Packages_To_Check : String_List_Access;
- Depth : Natural;
- Current_Dir : String;
- Is_Config_File : Boolean;
- Env : in out Environment);
- -- Parse the imported projects that have been stored in table Withs, if
- -- any. From_Extended is used for the call to Parse_Single_Project below.
- --
- -- When In_Limited is True, the importing path includes at least one
- -- "limited with". When Limited_Withs is False, only non limited withed
- -- projects are parsed. When Limited_Withs is True, only limited withed
- -- projects are parsed.
- --
- -- Is_Config_File should be set to True if the project represents a config
- -- file (.cgpr) since some specific checks apply.
-
- function Project_Name_From
- (Path_Name : String;
- Is_Config_File : Boolean) return Name_Id;
- -- Returns the name of the project that corresponds to its path name.
- -- Returns No_Name if the path name is invalid, because the corresponding
- -- project name does not have the syntax of an ada identifier.
-
- function Copy_With_Clause
- (With_Clause : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Next_Clause : Project_Node_Id) return Project_Node_Id;
- -- Return a copy of With_Clause in In_Tree, whose Next_With_Clause is the
- -- indicated one.
-
- ----------------------
- -- Copy_With_Clause --
- ----------------------
-
- function Copy_With_Clause
- (With_Clause : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Next_Clause : Project_Node_Id) return Project_Node_Id
- is
- New_With_Clause : constant Project_Node_Id :=
- Default_Project_Node (In_Tree, N_With_Clause);
- begin
- Set_Name_Of (New_With_Clause, In_Tree,
- Name_Of (With_Clause, In_Tree));
- Set_Path_Name_Of (New_With_Clause, In_Tree,
- Path_Name_Of (With_Clause, In_Tree));
- Set_Project_Node_Of (New_With_Clause, In_Tree,
- Project_Node_Of (With_Clause, In_Tree));
- Set_Next_With_Clause_Of (New_With_Clause, In_Tree, Next_Clause);
-
- return New_With_Clause;
- end Copy_With_Clause;
-
- --------------------------------------
- -- Create_Virtual_Extending_Project --
- --------------------------------------
-
- procedure Create_Virtual_Extending_Project
- (For_Project : Project_Node_Id;
- Main_Project : Project_Node_Id;
- Extension_Withs : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- is
-
- Virtual_Name : constant String :=
- Virtual_Prefix &
- Get_Name_String (Name_Of (For_Project, In_Tree));
- -- The name of the virtual extending project
-
- Virtual_Name_Id : Name_Id;
- -- Virtual extending project name id
-
- Virtual_Path_Id : Path_Name_Type;
- -- Fake path name of the virtual extending project. The directory is
- -- the same directory as the extending all project.
-
- -- The source of the virtual extending project is something like:
-
- -- project V$<project name> extends <project path> is
-
- -- for Source_Dirs use ();
-
- -- end V$<project name>;
-
- -- The project directory cannot be specified during parsing; it will be
- -- put directly in the virtual extending project data during processing.
-
- -- Nodes that made up the virtual extending project
-
- Virtual_Project : Project_Node_Id;
- With_Clause : constant Project_Node_Id :=
- Default_Project_Node
- (In_Tree, N_With_Clause);
- Project_Declaration : Project_Node_Id;
- Source_Dirs_Declaration : constant Project_Node_Id :=
- Default_Project_Node
- (In_Tree, N_Declarative_Item);
- Source_Dirs_Attribute : constant Project_Node_Id :=
- Default_Project_Node
- (In_Tree, N_Attribute_Declaration, List);
- Source_Dirs_Expression : constant Project_Node_Id :=
- Default_Project_Node
- (In_Tree, N_Expression, List);
- Source_Dirs_Term : constant Project_Node_Id :=
- Default_Project_Node
- (In_Tree, N_Term, List);
- Source_Dirs_List : constant Project_Node_Id :=
- Default_Project_Node
- (In_Tree, N_Literal_String_List, List);
-
- begin
- -- Get the virtual path name
-
- Get_Name_String (Path_Name_Of (Main_Project, In_Tree));
-
- while Name_Len > 0
- and then not Is_Directory_Separator (Name_Buffer (Name_Len))
- loop
- Name_Len := Name_Len - 1;
- end loop;
-
- Name_Buffer (Name_Len + 1 .. Name_Len + Virtual_Name'Length) :=
- Virtual_Name;
- Name_Len := Name_Len + Virtual_Name'Length;
- Virtual_Path_Id := Name_Find;
-
- -- Get the virtual name id
-
- Name_Len := Virtual_Name'Length;
- Name_Buffer (1 .. Name_Len) := Virtual_Name;
- Virtual_Name_Id := Name_Find;
-
- Virtual_Project := Create_Project
- (In_Tree => In_Tree,
- Name => Virtual_Name_Id,
- Full_Path => Virtual_Path_Id,
- Is_Config_File => False);
-
- Project_Declaration := Project_Declaration_Of (Virtual_Project, In_Tree);
-
- -- Add a WITH clause to the main project to import the newly created
- -- virtual extending project.
-
- Set_Name_Of (With_Clause, In_Tree, Virtual_Name_Id);
- Set_Path_Name_Of (With_Clause, In_Tree, Virtual_Path_Id);
- Set_Project_Node_Of (With_Clause, In_Tree, Virtual_Project);
- Set_Next_With_Clause_Of
- (With_Clause, In_Tree, First_With_Clause_Of (Main_Project, In_Tree));
- Set_First_With_Clause_Of (Main_Project, In_Tree, With_Clause);
-
- -- Copy with clauses for projects imported by the extending-all project
-
- declare
- Org_With_Clause : Project_Node_Id := Extension_Withs;
- New_With_Clause : Project_Node_Id := Empty_Node;
-
- begin
- while Present (Org_With_Clause) loop
- New_With_Clause :=
- Copy_With_Clause (Org_With_Clause, In_Tree, New_With_Clause);
-
- Org_With_Clause := Next_With_Clause_Of (Org_With_Clause, In_Tree);
- end loop;
-
- Set_First_With_Clause_Of (Virtual_Project, In_Tree, New_With_Clause);
- end;
-
- -- Virtual project node
-
- Set_Location_Of
- (Virtual_Project, In_Tree, Location_Of (Main_Project, In_Tree));
- Set_Extended_Project_Path_Of
- (Virtual_Project, In_Tree, Path_Name_Of (For_Project, In_Tree));
-
- -- Project declaration
-
- Set_First_Declarative_Item_Of
- (Project_Declaration, In_Tree, Source_Dirs_Declaration);
- Set_Extended_Project_Of (Project_Declaration, In_Tree, For_Project);
-
- -- Source_Dirs declaration
-
- Set_Current_Item_Node
- (Source_Dirs_Declaration, In_Tree, Source_Dirs_Attribute);
-
- -- Source_Dirs attribute
-
- Set_Name_Of (Source_Dirs_Attribute, In_Tree, Snames.Name_Source_Dirs);
- Set_Expression_Of
- (Source_Dirs_Attribute, In_Tree, Source_Dirs_Expression);
-
- -- Source_Dirs expression
-
- Set_First_Term (Source_Dirs_Expression, In_Tree, Source_Dirs_Term);
-
- -- Source_Dirs term
-
- Set_Current_Term (Source_Dirs_Term, In_Tree, Source_Dirs_List);
-
- -- Source_Dirs empty list: nothing to do
- end Create_Virtual_Extending_Project;
-
- -----------------------------------
- -- Look_For_Virtual_Projects_For --
- -----------------------------------
-
- Extension_Withs : Project_Node_Id;
- -- Head of the current EXTENDS ALL imports list. When creating virtual
- -- projects for an EXTENDS ALL, we import in each virtual project all
- -- of the projects that appear in WITH clauses of the extending projects.
- -- This ensures that virtual projects share a consistent environment (in
- -- particular if a project imported by one of the extending projects
- -- replaces some runtime units).
-
- procedure Look_For_Virtual_Projects_For
- (Proj : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Potentially_Virtual : Boolean)
- is
- Declaration : Project_Node_Id := Empty_Node;
- -- Node for the project declaration of Proj
-
- With_Clause : Project_Node_Id := Empty_Node;
- -- Node for a with clause of Proj
-
- Imported : Project_Node_Id := Empty_Node;
- -- Node for a project imported by Proj
-
- Extended : Project_Node_Id := Empty_Node;
- -- Node for the eventual project extended by Proj
-
- Extends_All : Boolean := False;
- -- Set True if Proj is an EXTENDS ALL project
-
- Saved_Extension_Withs : constant Project_Node_Id := Extension_Withs;
-
- begin
- -- Nothing to do if Proj is undefined or has already been processed
-
- if Present (Proj) and then not Processed_Hash.Get (Proj) then
-
- -- Make sure the project will not be processed again
-
- Processed_Hash.Set (Proj, True);
-
- Declaration := Project_Declaration_Of (Proj, In_Tree);
-
- if Present (Declaration) then
- Extended := Extended_Project_Of (Declaration, In_Tree);
- Extends_All := Is_Extending_All (Proj, In_Tree);
- end if;
-
- -- If this is a project that may need a virtual extending project
- -- and it is not itself an extending project, put it in the list.
-
- if Potentially_Virtual and then No (Extended) then
- Virtual_Hash.Set (Proj, Extension_Withs);
- end if;
-
- -- Now check the projects it imports
-
- With_Clause := First_With_Clause_Of (Proj, In_Tree);
- while Present (With_Clause) loop
- Imported := Project_Node_Of (With_Clause, In_Tree);
-
- if Present (Imported) then
- Look_For_Virtual_Projects_For
- (Imported, In_Tree, Potentially_Virtual => True);
- end if;
-
- if Extends_All then
-
- -- This is an EXTENDS ALL project: prepend each of its WITH
- -- clauses to the currently active list of extension deps.
-
- Extension_Withs :=
- Copy_With_Clause (With_Clause, In_Tree, Extension_Withs);
- end if;
-
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop;
-
- -- Check also the eventual project extended by Proj. As this project
- -- is already extended, call recursively with Potentially_Virtual
- -- being False.
-
- Look_For_Virtual_Projects_For
- (Extended, In_Tree, Potentially_Virtual => False);
-
- Extension_Withs := Saved_Extension_Withs;
- end if;
- end Look_For_Virtual_Projects_For;
-
- -----------
- -- Parse --
- -----------
-
- procedure Parse
- (In_Tree : Project_Node_Tree_Ref;
- Project : out Project_Node_Id;
- Project_File_Name : String;
- Errout_Handling : Errout_Mode := Always_Finalize;
- Packages_To_Check : String_List_Access;
- Store_Comments : Boolean := False;
- Current_Directory : String := "";
- Is_Config_File : Boolean;
- Env : in out Prj.Tree.Environment;
- Target_Name : String := "";
- Implicit_Project : Boolean := False)
- is
- Dummy : Boolean;
- pragma Warnings (Off, Dummy);
-
- Path_Name_Id : Path_Name_Type;
-
- begin
- In_Tree.Incomplete_With := False;
- Project_Stack.Init;
- Tree_Private_Part.Projects_Htable.Reset (In_Tree.Projects_HT);
-
- if not Is_Initialized (Env.Project_Path) then
- Prj.Env.Initialize_Default_Project_Path
- (Env.Project_Path, Target_Name);
- end if;
-
- Project := Empty_Node;
-
- Find_Project (Env.Project_Path,
- Project_File_Name => Project_File_Name,
- Directory => Current_Directory,
- Path => Path_Name_Id);
-
- if Errout_Handling /= Never_Finalize then
- Prj.Err.Initialize;
- end if;
-
- Prj.Err.Scanner.Set_Comment_As_Token (Store_Comments);
- Prj.Err.Scanner.Set_End_Of_Line_As_Token (Store_Comments);
-
- if Path_Name_Id = No_Path then
- declare
- P : String_Access;
- begin
- Get_Path (Env.Project_Path, Path => P);
-
- Prj.Com.Fail
- ("project file """
- & Project_File_Name
- & """ not found in "
- & P.all);
- Project := Empty_Node;
- return;
- end;
- end if;
-
- -- Parse the main project file
-
- begin
- Parse_Single_Project
- (In_Tree => In_Tree,
- Project => Project,
- Extends_All => Dummy,
- Path_Name_Id => Path_Name_Id,
- Extended => False,
- From_Extended => None,
- In_Limited => False,
- Packages_To_Check => Packages_To_Check,
- Depth => 0,
- Current_Dir => Current_Directory,
- Is_Config_File => Is_Config_File,
- Env => Env,
- Implicit_Project => Implicit_Project);
-
- exception
- when Types.Unrecoverable_Error =>
-
- -- Unrecoverable_Error is raised when a line is too long.
- -- A meaningful error message will be displayed later.
-
- Project := Empty_Node;
- end;
-
- -- If Project is an extending-all project, create the eventual
- -- virtual extending projects and check that there are no illegally
- -- imported projects.
-
- if Present (Project)
- and then Is_Extending_All (Project, In_Tree)
- then
- -- First look for projects that potentially need a virtual
- -- extending project.
-
- Virtual_Hash.Reset;
- Processed_Hash.Reset;
-
- -- Mark the extending all project as processed, to avoid checking
- -- the imported projects in case of a "limited with" on this
- -- extending all project.
-
- Processed_Hash.Set (Project, True);
-
- declare
- Declaration : constant Project_Node_Id :=
- Project_Declaration_Of (Project, In_Tree);
- begin
- Extension_Withs := First_With_Clause_Of (Project, In_Tree);
- Look_For_Virtual_Projects_For
- (Extended_Project_Of (Declaration, In_Tree), In_Tree,
- Potentially_Virtual => False);
- end;
-
- -- Now, check the projects directly imported by the main project.
- -- Remove from the potentially virtual any project extended by one
- -- of these imported projects.
-
- declare
- With_Clause : Project_Node_Id;
- Imported : Project_Node_Id := Empty_Node;
- Declaration : Project_Node_Id := Empty_Node;
-
- begin
- With_Clause := First_With_Clause_Of (Project, In_Tree);
- while Present (With_Clause) loop
- Imported := Project_Node_Of (With_Clause, In_Tree);
-
- if Present (Imported) then
- Declaration := Project_Declaration_Of (Imported, In_Tree);
-
- if Extended_Project_Of (Declaration, In_Tree) /=
- Empty_Node
- then
- loop
- Imported :=
- Extended_Project_Of (Declaration, In_Tree);
- exit when No (Imported);
- Virtual_Hash.Remove (Imported);
- Declaration :=
- Project_Declaration_Of (Imported, In_Tree);
- end loop;
- end if;
- end if;
-
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop;
- end;
-
- -- Now create all the virtual extending projects
-
- declare
- Proj : Project_Node_Id := Empty_Node;
- Withs : Project_Node_Id;
- begin
- Virtual_Hash.Get_First (Proj, Withs);
- while Withs /= Project_Node_High_Bound loop
- Create_Virtual_Extending_Project
- (Proj, Project, Withs, In_Tree);
- Virtual_Hash.Get_Next (Proj, Withs);
- end loop;
- end;
- end if;
-
- -- If there were any kind of error during the parsing, serious
- -- or not, then the parsing fails.
-
- if Total_Errors_Detected > 0 then
- Project := Empty_Node;
- end if;
-
- case Errout_Handling is
- when Always_Finalize =>
- Prj.Err.Finalize;
-
- -- Reinitialize to avoid duplicate warnings later on
- Prj.Err.Initialize;
-
- when Finalize_If_Error =>
- if No (Project) then
- Prj.Err.Finalize;
- Prj.Err.Initialize;
- end if;
-
- when Never_Finalize =>
- null;
- end case;
-
- exception
- when X : others =>
-
- -- Internal error
-
- Write_Line (Exception_Information (X));
- Write_Str ("Exception ");
- Write_Str (Exception_Name (X));
- Write_Line (" raised, while processing project file");
- Project := Empty_Node;
- end Parse;
-
- ------------------------------
- -- Pre_Parse_Context_Clause --
- ------------------------------
-
- procedure Pre_Parse_Context_Clause
- (In_Tree : Project_Node_Tree_Ref;
- Context_Clause : out With_Id;
- Is_Config_File : Boolean;
- Flags : Processing_Flags)
- is
- Current_With_Clause : With_Id := No_With;
- Limited_With : Boolean := False;
- Current_With : With_Record;
- Current_With_Node : Project_Node_Id := Empty_Node;
-
- begin
- -- Assume no context clause
-
- Context_Clause := No_With;
- With_Loop :
-
- -- If Token is not WITH or LIMITED, there is no context clause, or we
- -- have exhausted the with clauses.
-
- while Token = Tok_With or else Token = Tok_Limited loop
- Current_With_Node :=
- Default_Project_Node (Of_Kind => N_With_Clause, In_Tree => In_Tree);
- Limited_With := Token = Tok_Limited;
-
- if Is_Config_File then
- Error_Msg
- (Flags,
- "configuration project cannot import " &
- "other configuration projects",
- Token_Ptr);
- end if;
-
- if Limited_With then
- Scan (In_Tree); -- past LIMITED
- Expect (Tok_With, "WITH");
- exit With_Loop when Token /= Tok_With;
- end if;
-
- Comma_Loop :
- loop
- Scan (In_Tree); -- past WITH or ","
-
- Expect (Tok_String_Literal, "literal string");
-
- if Token /= Tok_String_Literal then
- return;
- end if;
-
- -- Store path and location in table Withs
-
- Current_With :=
- (Path => Path_Name_Type (Token_Name),
- Location => Token_Ptr,
- Limited_With => Limited_With,
- Node => Current_With_Node,
- Next => No_With);
-
- Withs.Increment_Last;
- Withs.Table (Withs.Last) := Current_With;
-
- if Current_With_Clause = No_With then
- Context_Clause := Withs.Last;
-
- else
- Withs.Table (Current_With_Clause).Next := Withs.Last;
- end if;
-
- Current_With_Clause := Withs.Last;
-
- Scan (In_Tree);
-
- if Token = Tok_Semicolon then
- Set_End_Of_Line (Current_With_Node);
- Set_Previous_Line_Node (Current_With_Node);
-
- -- End of (possibly multiple) with clause;
-
- Scan (In_Tree); -- past semicolon
- exit Comma_Loop;
-
- elsif Token = Tok_Comma then
- Set_Is_Not_Last_In_List (Current_With_Node, In_Tree);
-
- else
- Error_Msg (Flags, "expected comma or semi colon", Token_Ptr);
- exit Comma_Loop;
- end if;
-
- Current_With_Node :=
- Default_Project_Node
- (Of_Kind => N_With_Clause, In_Tree => In_Tree);
- end loop Comma_Loop;
- end loop With_Loop;
- end Pre_Parse_Context_Clause;
-
- -------------------------------
- -- Post_Parse_Context_Clause --
- -------------------------------
-
- procedure Post_Parse_Context_Clause
- (Context_Clause : With_Id;
- In_Tree : Project_Node_Tree_Ref;
- In_Limited : Boolean;
- Limited_Withs : Boolean;
- Imported_Projects : in out Project_Node_Id;
- Project_Directory : Path_Name_Type;
- From_Extended : Extension_Origin;
- Packages_To_Check : String_List_Access;
- Depth : Natural;
- Current_Dir : String;
- Is_Config_File : Boolean;
- Env : in out Environment)
- is
- Current_With_Clause : With_Id := Context_Clause;
-
- Current_Project : Project_Node_Id := Imported_Projects;
- Previous_Project : Project_Node_Id := Empty_Node;
- Next_Project : Project_Node_Id := Empty_Node;
-
- Project_Directory_Path : constant String :=
- Get_Name_String (Project_Directory);
-
- Current_With : With_Record;
- Extends_All : Boolean := False;
- Imported_Path_Name_Id : Path_Name_Type;
-
- begin
- -- Set Current_Project to the last project in the current list, if the
- -- list is not empty.
-
- if Present (Current_Project) then
- while
- Present (Next_With_Clause_Of (Current_Project, In_Tree))
- loop
- Current_Project := Next_With_Clause_Of (Current_Project, In_Tree);
- end loop;
- end if;
-
- while Current_With_Clause /= No_With loop
- Current_With := Withs.Table (Current_With_Clause);
- Current_With_Clause := Current_With.Next;
-
- if Limited_Withs = Current_With.Limited_With then
- Find_Project
- (Env.Project_Path,
- Project_File_Name => Get_Name_String (Current_With.Path),
- Directory => Project_Directory_Path,
- Path => Imported_Path_Name_Id);
-
- if Imported_Path_Name_Id = No_Path then
- if Env.Flags.Ignore_Missing_With then
- In_Tree.Incomplete_With := True;
- Env.Flags.Incomplete_Withs := True;
-
- else
- -- The project file cannot be found
-
- Error_Msg_File_1 := File_Name_Type (Current_With.Path);
- Error_Msg
- (Env.Flags, "unknown project file: {",
- Current_With.Location);
-
- -- If this is not imported by the main project file, display
- -- the import path.
-
- if Project_Stack.Last > 1 then
- for Index in reverse 1 .. Project_Stack.Last loop
- Error_Msg_File_1 :=
- File_Name_Type
- (Project_Stack.Table (Index).Path_Name);
- Error_Msg
- (Env.Flags, "\imported by {", Current_With.Location);
- end loop;
- end if;
- end if;
-
- else
- -- New with clause
-
- declare
- Resolved_Path : constant String :=
- Normalize_Pathname
- (Get_Name_String (Imported_Path_Name_Id),
- Directory => Current_Dir,
- Resolve_Links =>
- Opt.Follow_Links_For_Files,
- Case_Sensitive => True);
-
- Withed_Project : Project_Node_Id := Empty_Node;
-
- begin
- Previous_Project := Current_Project;
-
- if No (Current_Project) then
-
- -- First with clause of the context clause
-
- Current_Project := Current_With.Node;
- Imported_Projects := Current_Project;
-
- else
- Next_Project := Current_With.Node;
- Set_Next_With_Clause_Of
- (Current_Project, In_Tree, Next_Project);
- Current_Project := Next_Project;
- end if;
-
- Set_String_Value_Of
- (Current_Project,
- In_Tree,
- Name_Id (Current_With.Path));
- Set_Location_Of
- (Current_Project, In_Tree, Current_With.Location);
-
- -- If it is a limited with, check if we have a circularity.
- -- If we have one, get the project id of the limited
- -- imported project file, and do not parse it.
-
- if (In_Limited or Limited_Withs)
- and then Project_Stack.Last > 1
- then
- declare
- Canonical_Path_Name : Path_Name_Type;
-
- begin
- Name_Len := Resolved_Path'Length;
- Name_Buffer (1 .. Name_Len) := Resolved_Path;
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Canonical_Path_Name := Name_Find;
-
- for Index in 1 .. Project_Stack.Last loop
- if Project_Stack.Table (Index).Canonical_Path_Name =
- Canonical_Path_Name
- then
- -- We have found the limited imported project,
- -- get its project id, and do not parse it.
-
- Withed_Project := Project_Stack.Table (Index).Id;
- exit;
- end if;
- end loop;
- end;
- end if;
-
- -- Parse the imported project if its project id is unknown
-
- if No (Withed_Project) then
- Parse_Single_Project
- (In_Tree => In_Tree,
- Project => Withed_Project,
- Extends_All => Extends_All,
- Path_Name_Id => Imported_Path_Name_Id,
- Extended => False,
- From_Extended => From_Extended,
- In_Limited => In_Limited or Limited_Withs,
- Packages_To_Check => Packages_To_Check,
- Depth => Depth,
- Current_Dir => Current_Dir,
- Is_Config_File => Is_Config_File,
- Env => Env);
-
- else
- Extends_All := Is_Extending_All (Withed_Project, In_Tree);
- end if;
-
- if No (Withed_Project) then
-
- -- If parsing unsuccessful, remove the context clause
-
- Current_Project := Previous_Project;
-
- if No (Current_Project) then
- Imported_Projects := Empty_Node;
-
- else
- Set_Next_With_Clause_Of
- (Current_Project, In_Tree, Empty_Node);
- end if;
- else
- -- If parsing was successful, record project name and
- -- path name in with clause
-
- Set_Project_Node_Of
- (Node => Current_Project,
- In_Tree => In_Tree,
- To => Withed_Project,
- Limited_With => Current_With.Limited_With);
- Set_Name_Of
- (Current_Project,
- In_Tree,
- Name_Of (Withed_Project, In_Tree));
-
- Name_Len := Resolved_Path'Length;
- Name_Buffer (1 .. Name_Len) := Resolved_Path;
- Set_Path_Name_Of (Current_Project, In_Tree, Name_Find);
-
- if Extends_All then
- Set_Is_Extending_All (Current_Project, In_Tree);
- end if;
- end if;
- end;
- end if;
- end if;
- end loop;
- end Post_Parse_Context_Clause;
-
- ---------------------------------
- -- Check_Extending_All_Imports --
- ---------------------------------
-
- procedure Check_Extending_All_Imports
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id)
- is
- With_Clause : Project_Node_Id;
- Imported : Project_Node_Id;
-
- begin
- if not Is_Extending_All (Project, In_Tree) then
- With_Clause := First_With_Clause_Of (Project, In_Tree);
- while Present (With_Clause) loop
- Imported := Project_Node_Of (With_Clause, In_Tree);
-
- if Is_Extending_All (With_Clause, In_Tree) then
- Error_Msg_Name_1 := Name_Of (Imported, In_Tree);
- Error_Msg (Flags, "cannot import extending-all project %%",
- Token_Ptr);
- exit;
- end if;
-
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop;
- end if;
- end Check_Extending_All_Imports;
-
- -----------------------------
- -- Check_Aggregate_Imports --
- -----------------------------
-
- procedure Check_Aggregate_Imports
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id)
- is
- With_Clause, Imported : Project_Node_Id;
- begin
- if Project_Qualifier_Of (Project, In_Tree) = Aggregate then
- With_Clause := First_With_Clause_Of (Project, In_Tree);
-
- while Present (With_Clause) loop
- Imported := Project_Node_Of (With_Clause, In_Tree);
-
- if Project_Qualifier_Of (Imported, In_Tree) /= Abstract_Project
- then
- Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree));
- Error_Msg (Flags, "can only import abstract projects, not %%",
- Token_Ptr);
- exit;
- end if;
-
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop;
- end if;
- end Check_Aggregate_Imports;
-
- ----------------------------
- -- Check_Import_Aggregate --
- ----------------------------
-
- procedure Check_Import_Aggregate
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id)
- is
- With_Clause : Project_Node_Id;
- Imported : Project_Node_Id;
-
- begin
- if Project_Qualifier_Of (Project, In_Tree) /= Aggregate then
- With_Clause := First_With_Clause_Of (Project, In_Tree);
- while Present (With_Clause) loop
- Imported := Project_Node_Of (With_Clause, In_Tree);
-
- if Project_Qualifier_Of (Imported, In_Tree) = Aggregate then
- Error_Msg_Name_1 := Name_Id (Path_Name_Of (Imported, In_Tree));
- Error_Msg
- (Flags, "cannot import aggregate project %%", Token_Ptr);
- exit;
- end if;
-
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop;
- end if;
- end Check_Import_Aggregate;
-
- ----------------------------
- -- Read_Project_Qualifier --
- ----------------------------
-
- procedure Read_Project_Qualifier
- (Flags : Processing_Flags;
- In_Tree : Project_Node_Tree_Ref;
- Is_Config_File : Boolean;
- Qualifier_Location : out Source_Ptr;
- Project : Project_Node_Id)
- is
- Proj_Qualifier : Project_Qualifier := Unspecified;
- begin
- Qualifier_Location := Token_Ptr;
-
- if Token = Tok_Abstract then
- Proj_Qualifier := Abstract_Project;
- Scan (In_Tree);
-
- elsif Token = Tok_Identifier then
- case Token_Name is
- when Snames.Name_Standard =>
- Proj_Qualifier := Standard;
- Scan (In_Tree);
-
- when Snames.Name_Aggregate =>
- Proj_Qualifier := Aggregate;
- Scan (In_Tree);
-
- if Token = Tok_Identifier
- and then Token_Name = Snames.Name_Library
- then
- Proj_Qualifier := Aggregate_Library;
- Scan (In_Tree);
- end if;
-
- when Snames.Name_Library =>
- Proj_Qualifier := Library;
- Scan (In_Tree);
-
- when Snames.Name_Configuration =>
- if not Is_Config_File then
- Error_Msg
- (Flags,
- "configuration projects cannot belong to a user" &
- " project tree",
- Token_Ptr);
- end if;
-
- Proj_Qualifier := Configuration;
- Scan (In_Tree);
-
- when others =>
- null;
- end case;
- end if;
-
- if Is_Config_File and then Proj_Qualifier = Unspecified then
-
- -- Set the qualifier to Configuration, even if the token doesn't
- -- exist in the source file itself, so that we can differentiate
- -- project files and configuration files later on.
-
- Proj_Qualifier := Configuration;
- end if;
-
- if Proj_Qualifier /= Unspecified then
- if Is_Config_File
- and then Proj_Qualifier /= Configuration
- then
- Error_Msg (Flags,
- "a configuration project cannot be qualified except " &
- "as configuration project",
- Qualifier_Location);
- end if;
-
- Set_Project_Qualifier_Of (Project, In_Tree, Proj_Qualifier);
- end if;
- end Read_Project_Qualifier;
-
- -------------------------------
- -- Has_Circular_Dependencies --
- -------------------------------
-
- function Has_Circular_Dependencies
- (Flags : Processing_Flags;
- Normed_Path_Name : Path_Name_Type;
- Canonical_Path_Name : Path_Name_Type) return Boolean is
- begin
- for Index in reverse 1 .. Project_Stack.Last loop
- exit when Project_Stack.Table (Index).Limited_With;
-
- if Canonical_Path_Name =
- Project_Stack.Table (Index).Canonical_Path_Name
- then
- Error_Msg (Flags, "circular dependency detected", Token_Ptr);
- Error_Msg_Name_1 := Name_Id (Normed_Path_Name);
- Error_Msg (Flags, "\ %% is imported by", Token_Ptr);
-
- for Current in reverse 1 .. Project_Stack.Last loop
- Error_Msg_Name_1 :=
- Name_Id (Project_Stack.Table (Current).Path_Name);
-
- if Project_Stack.Table (Current).Canonical_Path_Name /=
- Canonical_Path_Name
- then
- Error_Msg
- (Flags, "\ %% which itself is imported by", Token_Ptr);
-
- else
- Error_Msg (Flags, "\ %%", Token_Ptr);
- exit;
- end if;
- end loop;
-
- return True;
- end if;
- end loop;
- return False;
- end Has_Circular_Dependencies;
-
- --------------------------
- -- Parse_Single_Project --
- --------------------------
-
- procedure Parse_Single_Project
- (In_Tree : Project_Node_Tree_Ref;
- Project : out Project_Node_Id;
- Extends_All : out Boolean;
- Path_Name_Id : Path_Name_Type;
- Extended : Boolean;
- From_Extended : Extension_Origin;
- In_Limited : Boolean;
- Packages_To_Check : String_List_Access;
- Depth : Natural;
- Current_Dir : String;
- Is_Config_File : Boolean;
- Env : in out Environment;
- Implicit_Project : Boolean := False)
- is
- Path_Name : constant String := Get_Name_String (Path_Name_Id);
-
- Normed_Path_Name : Path_Name_Type;
- Canonical_Path_Name : Path_Name_Type;
- Resolved_Path_Name : Path_Name_Type;
- Project_Directory : Path_Name_Type;
- Project_Scan_State : Saved_Project_Scan_State;
- Source_Index : Source_File_Index;
-
- Extending : Boolean := False;
-
- Extended_Project : Project_Node_Id := Empty_Node;
-
- A_Project_Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get_First
- (In_Tree.Projects_HT);
-
- Name_From_Path : constant Name_Id :=
- Project_Name_From (Path_Name, Is_Config_File => Is_Config_File);
- Name_Of_Project : Name_Id := No_Name;
-
- Duplicated : Boolean := False;
-
- First_With : With_Id;
- Imported_Projects : Project_Node_Id := Empty_Node;
-
- use Tree_Private_Part;
-
- Project_Comment_State : Tree.Comment_State;
-
- Qualifier_Location : Source_Ptr;
-
- begin
- Extends_All := False;
-
- declare
- Normed_Path : constant String := Normalize_Pathname
- (Path_Name,
- Directory => Current_Dir,
- Resolve_Links => False,
- Case_Sensitive => True);
- Canonical_Path : constant String := Normalize_Pathname
- (Normed_Path,
- Directory => Current_Dir,
- Resolve_Links => Opt.Follow_Links_For_Files,
- Case_Sensitive => False);
- begin
- Name_Len := Normed_Path'Length;
- Name_Buffer (1 .. Name_Len) := Normed_Path;
- Normed_Path_Name := Name_Find;
- Name_Len := Canonical_Path'Length;
- Name_Buffer (1 .. Name_Len) := Canonical_Path;
- Canonical_Path_Name := Name_Find;
-
- if Opt.Follow_Links_For_Files then
- Resolved_Path_Name := Canonical_Path_Name;
-
- else
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (Normalize_Pathname
- (Canonical_Path,
- Resolve_Links => True,
- Case_Sensitive => False));
- Resolved_Path_Name := Name_Find;
- end if;
-
- end;
-
- if Has_Circular_Dependencies
- (Env.Flags, Normed_Path_Name, Canonical_Path_Name)
- then
- Project := Empty_Node;
- return;
- end if;
-
- -- Put the new path name on the stack
-
- Project_Stack.Append
- ((Path_Name => Normed_Path_Name,
- Canonical_Path_Name => Canonical_Path_Name,
- Id => Empty_Node,
- Limited_With => In_Limited));
-
- -- Check if the project file has already been parsed
-
- while
- A_Project_Name_And_Node /= Tree_Private_Part.No_Project_Name_And_Node
- loop
- if A_Project_Name_And_Node.Resolved_Path = Resolved_Path_Name then
- if Extended then
-
- if A_Project_Name_And_Node.Extended then
- if A_Project_Name_And_Node.Proj_Qualifier /= Abstract_Project
- then
- Error_Msg
- (Env.Flags,
- "cannot extend the same project file several times",
- Token_Ptr);
- end if;
- elsif not A_Project_Name_And_Node.From_Extended then
- Error_Msg
- (Env.Flags,
- "cannot extend an already imported project file",
- Token_Ptr);
-
- else
- -- Register this project as being extended
-
- A_Project_Name_And_Node.Extended := True;
- Tree_Private_Part.Projects_Htable.Set
- (In_Tree.Projects_HT,
- A_Project_Name_And_Node.Name,
- A_Project_Name_And_Node);
- end if;
-
- elsif A_Project_Name_And_Node.Extended then
- Extends_All :=
- Is_Extending_All (A_Project_Name_And_Node.Node, In_Tree);
-
- -- If the imported project is an extended project A, and we are
- -- in an extended project, replace A with the ultimate project
- -- extending A.
-
- if From_Extended /= None then
- declare
- Decl : Project_Node_Id :=
- Project_Declaration_Of
- (A_Project_Name_And_Node.Node, In_Tree);
-
- Prj : Project_Node_Id :=
- A_Project_Name_And_Node.Node;
-
- begin
- -- Loop through extending projects to find the ultimate
- -- extending project, that is the one that is not
- -- extended. For an abstract project, as it can be
- -- extended several times, there is no extending project
- -- registered, so the loop does not execute and the
- -- resulting project is the abstract project.
-
- while
- Extending_Project_Of (Decl, In_Tree) /= Empty_Node
- loop
- Prj := Extending_Project_Of (Decl, In_Tree);
- Decl := Project_Declaration_Of (Prj, In_Tree);
- end loop;
-
- A_Project_Name_And_Node.Node := Prj;
- end;
- else
- Error_Msg
- (Env.Flags,
- "cannot import an already extended project file",
- Token_Ptr);
- end if;
-
- elsif A_Project_Name_And_Node.From_Extended then
- -- This project is now imported from a non extending project.
- -- Indicate this in has table Projects.HT.
-
- A_Project_Name_And_Node.From_Extended := False;
- Tree_Private_Part.Projects_Htable.Set
- (In_Tree.Projects_HT,
- A_Project_Name_And_Node.Name,
- A_Project_Name_And_Node);
- end if;
-
- Project := A_Project_Name_And_Node.Node;
- Project_Stack.Decrement_Last;
- return;
- end if;
-
- A_Project_Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get_Next (In_Tree.Projects_HT);
- end loop;
-
- -- We never encountered this project file. Save the scan state, load the
- -- project file and start to scan it.
-
- Save_Project_Scan_State (Project_Scan_State);
- Source_Index := Load_Project_File (Path_Name);
- Tree.Save (Project_Comment_State);
-
- -- If we cannot find it, we stop
-
- if Source_Index = No_Source_File then
- Project := Empty_Node;
- Project_Stack.Decrement_Last;
- return;
- end if;
-
- Prj.Err.Scanner.Initialize_Scanner (Source_Index);
- Tree.Reset_State;
- Scan (In_Tree);
-
- if not Is_Config_File
- and then Name_From_Path = No_Name
- and then not Implicit_Project
- then
-
- -- The project file name is not correct (no or bad extension, or not
- -- following Ada identifier's syntax).
-
- Error_Msg_File_1 := File_Name_Type (Canonical_Path_Name);
- Error_Msg (Env.Flags,
- "?{ is not a valid path name for a project file",
- Token_Ptr);
- end if;
-
- if Current_Verbosity >= Medium then
- Debug_Increase_Indent ("Parsing """ & Path_Name & '"');
- end if;
-
- Project_Directory :=
- Path_Name_Type (Get_Directory (File_Name_Type (Normed_Path_Name)));
-
- -- Is there any imported project?
-
- Pre_Parse_Context_Clause
- (In_Tree => In_Tree,
- Is_Config_File => Is_Config_File,
- Context_Clause => First_With,
- Flags => Env.Flags);
-
- Project := Default_Project_Node
- (Of_Kind => N_Project, In_Tree => In_Tree);
- Project_Stack.Table (Project_Stack.Last).Id := Project;
- Set_Directory_Of (Project, In_Tree, Project_Directory);
- Set_Path_Name_Of (Project, In_Tree, Normed_Path_Name);
-
- Read_Project_Qualifier
- (Env.Flags, In_Tree, Is_Config_File, Qualifier_Location, Project);
-
- Set_Location_Of (Project, In_Tree, Token_Ptr);
-
- Expect (Tok_Project, "PROJECT");
-
- -- Mark location of PROJECT token if present
-
- if Token = Tok_Project then
- Scan (In_Tree); -- past PROJECT
- Set_Location_Of (Project, In_Tree, Token_Ptr);
- end if;
-
- -- Clear the Buffer
-
- Buffer_Last := 0;
- loop
- Expect (Tok_Identifier, "identifier");
-
- -- If the token is not an identifier, clear the buffer before
- -- exiting to indicate that the name of the project is ill-formed.
-
- if Token /= Tok_Identifier then
- Buffer_Last := 0;
- exit;
- end if;
-
- -- Add the identifier name to the buffer
-
- Get_Name_String (Token_Name);
- Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
-
- -- Scan past the identifier
-
- Scan (In_Tree);
-
- -- If we have a dot, add a dot to the Buffer and look for the next
- -- identifier.
-
- exit when Token /= Tok_Dot;
- Add_To_Buffer (".", Buffer, Buffer_Last);
-
- -- Scan past the dot
-
- Scan (In_Tree);
- end loop;
-
- -- See if this is an extending project
-
- if Token = Tok_Extends then
-
- if Is_Config_File then
- Error_Msg
- (Env.Flags,
- "extending configuration project not allowed", Token_Ptr);
- end if;
-
- -- Make sure that gnatmake will use mapping files
-
- Opt.Create_Mapping_File := True;
-
- -- We are extending another project
-
- Extending := True;
-
- Scan (In_Tree); -- past EXTENDS
-
- if Token = Tok_All then
- Extends_All := True;
- Set_Is_Extending_All (Project, In_Tree);
- Scan (In_Tree); -- scan past ALL
- end if;
- end if;
-
- -- If the name is well formed, Buffer_Last is > 0
-
- if Buffer_Last > 0 then
-
- -- The Buffer contains the name of the project
-
- Name_Len := Buffer_Last;
- Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
- Name_Of_Project := Name_Find;
- Set_Name_Of (Project, In_Tree, Name_Of_Project);
-
- -- To get expected name of the project file, replace dots by dashes
-
- for Index in 1 .. Name_Len loop
- if Name_Buffer (Index) = '.' then
- Name_Buffer (Index) := '-';
- end if;
- end loop;
-
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
-
- declare
- Expected_Name : constant Name_Id := Name_Find;
- Extension : String_Access;
-
- begin
- -- Output a warning if the actual name is not the expected name
-
- if not Is_Config_File
- and then (Name_From_Path /= No_Name)
- and then Expected_Name /= Name_From_Path
- then
- Error_Msg_Name_1 := Expected_Name;
-
- if Is_Config_File then
- Extension := new String'(Config_Project_File_Extension);
-
- else
- Extension := new String'(Project_File_Extension);
- end if;
-
- Error_Msg
- (Env.Flags,
- "?file name does not match project name, should be `%%"
- & Extension.all & "`",
- Token_Ptr);
- end if;
- end;
-
- -- Read the original casing of the project name and put it in the
- -- project node.
-
- declare
- Loc : Source_Ptr;
- begin
- Loc := Location_Of (Project, In_Tree);
- for J in 1 .. Name_Len loop
- Name_Buffer (J) := Sinput.Source (Loc);
- Loc := Loc + 1;
- end loop;
-
- Set_Display_Name_Of (Project, In_Tree, Name_Find);
- end;
-
- declare
- From_Ext : Extension_Origin := None;
-
- begin
- -- Extending_All is always propagated
-
- if From_Extended = Extending_All or else Extends_All then
- From_Ext := Extending_All;
-
- -- Otherwise, From_Extended is set to Extending_Single if the
- -- current project is an extending project.
-
- elsif Extended then
- From_Ext := Extending_Simple;
- end if;
-
- Post_Parse_Context_Clause
- (In_Tree => In_Tree,
- Context_Clause => First_With,
- In_Limited => In_Limited,
- Limited_Withs => False,
- Imported_Projects => Imported_Projects,
- Project_Directory => Project_Directory,
- From_Extended => From_Ext,
- Packages_To_Check => Packages_To_Check,
- Depth => Depth + 1,
- Current_Dir => Current_Dir,
- Is_Config_File => Is_Config_File,
- Env => Env);
- Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
- end;
-
- if not Is_Config_File then
- declare
- Name_And_Node : Tree_Private_Part.Project_Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get_First
- (In_Tree.Projects_HT);
- Project_Name : Name_Id := Name_And_Node.Name;
-
- begin
- -- Check if we already have a project with this name
-
- while Project_Name /= No_Name
- and then Project_Name /= Name_Of_Project
- loop
- Name_And_Node :=
- Tree_Private_Part.Projects_Htable.Get_Next
- (In_Tree.Projects_HT);
- Project_Name := Name_And_Node.Name;
- end loop;
-
- -- Report an error if we already have a project with this name
-
- if Project_Name /= No_Name then
- Duplicated := True;
- Error_Msg_Name_1 := Project_Name;
- Error_Msg
- (Env.Flags, "duplicate project name %%",
- Location_Of (Project, In_Tree));
- Error_Msg_Name_1 :=
- Name_Id (Path_Name_Of (Name_And_Node.Node, In_Tree));
- Error_Msg
- (Env.Flags,
- "\already in %%", Location_Of (Project, In_Tree));
- end if;
- end;
- end if;
-
- end if;
-
- if Extending then
- Expect (Tok_String_Literal, "literal string");
-
- if Token = Tok_String_Literal then
- Set_Extended_Project_Path_Of
- (Project,
- In_Tree,
- Path_Name_Type (Token_Name));
-
- declare
- Original_Path_Name : constant String :=
- Get_Name_String (Token_Name);
-
- Extended_Project_Path_Name_Id : Path_Name_Type;
-
- begin
- Find_Project
- (Env.Project_Path,
- Project_File_Name => Original_Path_Name,
- Directory => Get_Name_String (Project_Directory),
- Path => Extended_Project_Path_Name_Id);
-
- if Extended_Project_Path_Name_Id = No_Path then
-
- -- We could not find the project file to extend
-
- Error_Msg_Name_1 := Token_Name;
-
- Error_Msg (Env.Flags, "unknown project file: %%", Token_Ptr);
-
- -- If not in the main project file, display the import path
-
- if Project_Stack.Last > 1 then
- Error_Msg_Name_1 :=
- Name_Id
- (Project_Stack.Table (Project_Stack.Last).Path_Name);
- Error_Msg (Env.Flags, "\extended by %%", Token_Ptr);
-
- for Index in reverse 1 .. Project_Stack.Last - 1 loop
- Error_Msg_Name_1 :=
- Name_Id
- (Project_Stack.Table (Index).Path_Name);
- Error_Msg (Env.Flags, "\imported by %%", Token_Ptr);
- end loop;
- end if;
-
- else
- declare
- From_Ext : Extension_Origin := None;
-
- begin
- if From_Extended = Extending_All or else Extends_All then
- From_Ext := Extending_All;
- end if;
-
- Parse_Single_Project
- (In_Tree => In_Tree,
- Project => Extended_Project,
- Extends_All => Extends_All,
- Path_Name_Id => Extended_Project_Path_Name_Id,
- Extended => True,
- From_Extended => From_Ext,
- In_Limited => In_Limited,
- Packages_To_Check => Packages_To_Check,
- Depth => Depth + 1,
- Current_Dir => Current_Dir,
- Is_Config_File => Is_Config_File,
- Env => Env);
- end;
-
- if Present (Extended_Project) then
-
- if Project_Qualifier_Of (Extended_Project, In_Tree) =
- Aggregate
- then
- Error_Msg_Name_1 :=
- Name_Id (Path_Name_Of (Extended_Project, In_Tree));
- Error_Msg
- (Env.Flags,
- "cannot extend aggregate project %%",
- Location_Of (Project, In_Tree));
- end if;
-
- -- A project that extends an extending-all project is
- -- also an extending-all project.
-
- if Is_Extending_All (Extended_Project, In_Tree) then
- Set_Is_Extending_All (Project, In_Tree);
- end if;
-
- -- An abstract project can only extend an abstract
- -- project. Otherwise we may have an abstract project
- -- with sources if it inherits sources from the project
- -- it extends.
-
- if Project_Qualifier_Of (Project, In_Tree) =
- Abstract_Project
- and then
- Project_Qualifier_Of (Extended_Project, In_Tree) /=
- Abstract_Project
- then
- Error_Msg
- (Env.Flags, "an abstract project can only extend " &
- "another abstract project",
- Qualifier_Location);
- end if;
- end if;
- end if;
- end;
-
- Scan (In_Tree); -- past the extended project path
- end if;
- end if;
-
- Check_Extending_All_Imports (Env.Flags, In_Tree, Project);
- Check_Aggregate_Imports (Env.Flags, In_Tree, Project);
- Check_Import_Aggregate (Env.Flags, In_Tree, Project);
-
- -- Check that a project with a name including a dot either imports
- -- or extends the project whose name precedes the last dot.
-
- if Name_Of_Project /= No_Name then
- Get_Name_String (Name_Of_Project);
-
- else
- Name_Len := 0;
- end if;
-
- -- Look for the last dot
-
- while Name_Len > 0 and then Name_Buffer (Name_Len) /= '.' loop
- Name_Len := Name_Len - 1;
- end loop;
-
- -- If a dot was found, check if parent project is imported or extended
-
- if Name_Len > 0 then
- Name_Len := Name_Len - 1;
-
- declare
- Parent_Name : constant Name_Id := Name_Find;
- Parent_Found : Boolean := False;
- Parent_Node : Project_Node_Id := Empty_Node;
- With_Clause : Project_Node_Id :=
- First_With_Clause_Of (Project, In_Tree);
- Imp_Proj_Name : Name_Id;
-
- begin
- -- If there is an extended project, check its name
-
- if Present (Extended_Project) then
- Parent_Node := Extended_Project;
- Parent_Found :=
- Name_Of (Extended_Project, In_Tree) = Parent_Name;
- end if;
-
- -- If the parent project is not the extended project,
- -- check each imported project until we find the parent project.
-
- Imported_Loop :
- while not Parent_Found and then Present (With_Clause) loop
- Parent_Node := Project_Node_Of (With_Clause, In_Tree);
- Extension_Loop : while Present (Parent_Node) loop
- Imp_Proj_Name := Name_Of (Parent_Node, In_Tree);
- Parent_Found := Imp_Proj_Name = Parent_Name;
- exit Imported_Loop when Parent_Found;
- Parent_Node :=
- Extended_Project_Of
- (Project_Declaration_Of (Parent_Node, In_Tree),
- In_Tree);
- end loop Extension_Loop;
-
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop Imported_Loop;
-
- if Parent_Found then
- Set_Parent_Project_Of (Project, In_Tree, To => Parent_Node);
-
- else
- -- If the parent project was not found, report an error
-
- Error_Msg_Name_1 := Name_Of_Project;
- Error_Msg_Name_2 := Parent_Name;
- Error_Msg (Env.Flags,
- "project %% does not import or extend project %%",
- Location_Of (Project, In_Tree));
- end if;
- end;
- end if;
-
- Expect (Tok_Is, "IS");
- Set_End_Of_Line (Project);
- Set_Previous_Line_Node (Project);
- Set_Next_End_Node (Project);
-
- declare
- Project_Declaration : Project_Node_Id := Empty_Node;
-
- begin
- -- No need to Scan past "is", Prj.Dect.Parse will do it
-
- Prj.Dect.Parse
- (In_Tree => In_Tree,
- Declarations => Project_Declaration,
- Current_Project => Project,
- Extends => Extended_Project,
- Packages_To_Check => Packages_To_Check,
- Is_Config_File => Is_Config_File,
- Flags => Env.Flags);
- Set_Project_Declaration_Of (Project, In_Tree, Project_Declaration);
-
- if Present (Extended_Project)
- and then Project_Qualifier_Of (Extended_Project, In_Tree) /=
- Abstract_Project
- then
- Set_Extending_Project_Of
- (Project_Declaration_Of (Extended_Project, In_Tree), In_Tree,
- To => Project);
- end if;
- end;
-
- Expect (Tok_End, "END");
- Remove_Next_End_Node;
-
- -- Skip "end" if present
-
- if Token = Tok_End then
- Scan (In_Tree);
- end if;
-
- -- Clear the Buffer
-
- Buffer_Last := 0;
-
- -- Store the name following "end" in the Buffer. The name may be made of
- -- several simple names.
-
- loop
- Expect (Tok_Identifier, "identifier");
-
- -- If we don't have an identifier, clear the buffer before exiting to
- -- avoid checking the name.
-
- if Token /= Tok_Identifier then
- Buffer_Last := 0;
- exit;
- end if;
-
- -- Add the identifier to the Buffer
- Get_Name_String (Token_Name);
- Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
-
- -- Scan past the identifier
-
- Scan (In_Tree);
- exit when Token /= Tok_Dot;
- Add_To_Buffer (".", Buffer, Buffer_Last);
- Scan (In_Tree);
- end loop;
-
- -- If we have a valid name, check if it is the name of the project
-
- if Name_Of_Project /= No_Name and then Buffer_Last > 0 then
- if To_Lower (Buffer (1 .. Buffer_Last)) /=
- Get_Name_String (Name_Of (Project, In_Tree))
- then
- -- Invalid name: report an error
-
- Error_Msg (Env.Flags, "expected """ &
- Get_Name_String (Name_Of (Project, In_Tree)) & """",
- Token_Ptr);
- end if;
- end if;
-
- Expect (Tok_Semicolon, "`;`");
-
- -- Check that there is no more text following the end of the project
- -- source.
-
- if Token = Tok_Semicolon then
- Set_Previous_End_Node (Project);
- Scan (In_Tree);
-
- if Token /= Tok_EOF then
- Error_Msg
- (Env.Flags,
- "unexpected text following end of project", Token_Ptr);
- end if;
- end if;
-
- if not Duplicated and then Name_Of_Project /= No_Name then
-
- -- Add the name of the project to the hash table, so that we can
- -- check that no other subsequent project will have the same name.
-
- Tree_Private_Part.Projects_Htable.Set
- (T => In_Tree.Projects_HT,
- K => Name_Of_Project,
- E => (Name => Name_Of_Project,
- Node => Project,
- Resolved_Path => Resolved_Path_Name,
- Extended => Extended,
- From_Extended => From_Extended /= None,
- Proj_Qualifier => Project_Qualifier_Of (Project, In_Tree)));
- end if;
-
- declare
- From_Ext : Extension_Origin := None;
-
- begin
- -- Extending_All is always propagated
-
- if From_Extended = Extending_All or else Extends_All then
- From_Ext := Extending_All;
-
- -- Otherwise, From_Extended is set to Extending_Single if the
- -- current project is an extending project.
-
- elsif Extended then
- From_Ext := Extending_Simple;
- end if;
-
- Post_Parse_Context_Clause
- (In_Tree => In_Tree,
- Context_Clause => First_With,
- In_Limited => In_Limited,
- Limited_Withs => True,
- Imported_Projects => Imported_Projects,
- Project_Directory => Project_Directory,
- From_Extended => From_Ext,
- Packages_To_Check => Packages_To_Check,
- Depth => Depth + 1,
- Current_Dir => Current_Dir,
- Is_Config_File => Is_Config_File,
- Env => Env);
- Set_First_With_Clause_Of (Project, In_Tree, Imported_Projects);
- end;
-
- -- Restore the scan state, in case we are not the main project
-
- Restore_Project_Scan_State (Project_Scan_State);
-
- -- And remove the project from the project stack
-
- Project_Stack.Decrement_Last;
-
- -- Indicate if there are unkept comments
-
- Tree.Set_Project_File_Includes_Unkept_Comments
- (Node => Project,
- In_Tree => In_Tree,
- To => Tree.There_Are_Unkept_Comments);
-
- -- And restore the comment state that was saved
-
- Tree.Restore_And_Free (Project_Comment_State);
-
- Debug_Decrease_Indent;
-
- if Project /= Empty_Node and then Implicit_Project then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Current_Dir);
- Add_Char_To_Name_Buffer (Dir_Sep);
- In_Tree.Project_Nodes.Table (Project).Directory := Name_Find;
- end if;
- end Parse_Single_Project;
-
- -----------------------
- -- Project_Name_From --
- -----------------------
-
- function Project_Name_From
- (Path_Name : String;
- Is_Config_File : Boolean) return Name_Id
- is
- Canonical : String (1 .. Path_Name'Length) := Path_Name;
- First : Natural := Canonical'Last;
- Last : Natural := First;
- Index : Positive;
-
- begin
- if Current_Verbosity = High then
- Debug_Output ("Project_Name_From (""" & Canonical & """)");
- end if;
-
- -- If the path name is empty, return No_Name to indicate failure
-
- if First = 0 then
- return No_Name;
- end if;
-
- Canonical_Case_File_Name (Canonical);
-
- -- Look for the last dot in the path name
-
- while First > 0
- and then
- Canonical (First) /= '.'
- loop
- First := First - 1;
- end loop;
-
- -- If we have a dot, check that it is followed by the correct extension
-
- if First > 0 and then Canonical (First) = '.' then
- if (not Is_Config_File
- and then Canonical (First .. Last) = Project_File_Extension
- and then First /= 1)
- or else
- (Is_Config_File
- and then
- Canonical (First .. Last) = Config_Project_File_Extension
- and then First /= 1)
- then
- -- Look for the last directory separator, if any
-
- First := First - 1;
- Last := First;
- while First > 0
- and then Canonical (First) /= '/'
- and then Canonical (First) /= Dir_Sep
- loop
- First := First - 1;
- end loop;
-
- else
- -- Not the correct extension, return No_Name to indicate failure
-
- return No_Name;
- end if;
-
- -- If no dot in the path name, return No_Name to indicate failure
-
- else
- return No_Name;
- end if;
-
- First := First + 1;
-
- -- If the extension is the file name, return No_Name to indicate failure
-
- if First > Last then
- return No_Name;
- end if;
-
- -- Put the name in lower case into Name_Buffer
-
- Name_Len := Last - First + 1;
- Name_Buffer (1 .. Name_Len) := To_Lower (Canonical (First .. Last));
-
- Index := 1;
-
- -- Check if it is a well formed project name. Return No_Name if it is
- -- ill formed.
-
- loop
- if not Is_Letter (Name_Buffer (Index)) then
- return No_Name;
-
- else
- loop
- Index := Index + 1;
-
- exit when Index >= Name_Len;
-
- if Name_Buffer (Index) = '_' then
- if Name_Buffer (Index + 1) = '_' then
- return No_Name;
- end if;
- end if;
-
- exit when Name_Buffer (Index) = '-';
-
- if Name_Buffer (Index) /= '_'
- and then not Is_Alphanumeric (Name_Buffer (Index))
- then
- return No_Name;
- end if;
-
- end loop;
- end if;
-
- if Index >= Name_Len then
- if Is_Alphanumeric (Name_Buffer (Name_Len)) then
-
- -- All checks have succeeded. Return name in Name_Buffer
-
- return Name_Find;
-
- else
- return No_Name;
- end if;
-
- elsif Name_Buffer (Index) = '-' then
- Index := Index + 1;
- end if;
- end loop;
- end Project_Name_From;
-
-end Prj.Part;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P A R T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Implements the parsing of project files into a tree
-
-with Prj.Tree; use Prj.Tree;
-
-package Prj.Part is
-
- type Errout_Mode is
- (Always_Finalize,
- Finalize_If_Error,
- Never_Finalize);
- -- Whether Parse should call Errout.Finalize (which prints the error
- -- messages on stdout). When Never_Finalize is used, Errout is not reset
- -- either at the beginning of Parse.
-
- procedure Parse
- (In_Tree : Project_Node_Tree_Ref;
- Project : out Project_Node_Id;
- Project_File_Name : String;
- Errout_Handling : Errout_Mode := Always_Finalize;
- Packages_To_Check : String_List_Access;
- Store_Comments : Boolean := False;
- Current_Directory : String := "";
- Is_Config_File : Boolean;
- Env : in out Prj.Tree.Environment;
- Target_Name : String := "";
- Implicit_Project : Boolean := False);
- -- Parse project file and all its imported project files and create a tree.
- -- Return the node for the project (or Empty_Node if parsing failed). If
- -- Always_Errout_Finalize is True, Errout.Finalize is called in all cases,
- -- Otherwise, Errout.Finalize is only called if there are errors (but not
- -- if there are only warnings). Packages_To_Check indicates the packages
- -- where any unknown attribute produces an error. For other packages, an
- -- unknown attribute produces a warning. When Store_Comments is True,
- -- comments are stored in the parse tree.
- --
- -- Current_Directory is used for optimization purposes only, avoiding extra
- -- system calls.
- --
- -- Is_Config_File should be set to True if the project represents a config
- -- file (.cgpr) since some specific checks apply.
- --
- -- Target_Name will be used to initialize the default project path, unless
- -- In_Tree.Project_Path has already been initialized (which is the
- -- recommended use).
- --
- -- If Implicit_Project is True, the main project file being parsed is
- -- deemed to be in the current working directory, even if it is not the
- -- case. Implicit_Project is set to True when a tool such as gprbuild is
- -- invoked without a project file and is using an implicit project file
- -- that is virtually in the current working directory, but is physically
- -- in another directory.
-
-end Prj.Part;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P P --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-
-with Output; use Output;
-with Snames;
-
-package body Prj.PP is
-
- use Prj.Tree;
-
- Not_Tested : array (Project_Node_Kind) of Boolean := (others => True);
-
- procedure Indicate_Tested (Kind : Project_Node_Kind);
- -- Set the corresponding component of array Not_Tested to False. Only
- -- called by Debug pragmas.
-
- ---------------------
- -- Indicate_Tested --
- ---------------------
-
- procedure Indicate_Tested (Kind : Project_Node_Kind) is
- begin
- Not_Tested (Kind) := False;
- end Indicate_Tested;
-
- ------------------
- -- Pretty_Print --
- ------------------
-
- procedure Pretty_Print
- (Project : Prj.Tree.Project_Node_Id;
- In_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Increment : Positive := 3;
- Eliminate_Empty_Case_Constructions : Boolean := False;
- Minimize_Empty_Lines : Boolean := False;
- W_Char : Write_Char_Ap := null;
- W_Eol : Write_Eol_Ap := null;
- W_Str : Write_Str_Ap := null;
- Backward_Compatibility : Boolean;
- Id : Prj.Project_Id := Prj.No_Project;
- Max_Line_Length : Max_Length_Of_Line :=
- Max_Length_Of_Line'Last)
- is
- procedure Print (Node : Project_Node_Id; Indent : Natural);
- -- A recursive procedure that traverses a project file tree and outputs
- -- its source. Current_Prj is the project that we are printing. This
- -- is used when printing attributes, since in nested packages they
- -- need to use a fully qualified name.
-
- procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural);
- -- Outputs an attribute name, taking into account the value of
- -- Backward_Compatibility.
-
- procedure Output_Name
- (Name : Name_Id;
- Indent : Natural;
- Capitalize : Boolean := True);
- -- Outputs a name
-
- procedure Start_Line (Indent : Natural);
- -- Outputs the indentation at the beginning of the line
-
- procedure Output_Project_File (S : Name_Id);
- -- Output a project file name in one single string literal
-
- procedure Output_String (S : Name_Id; Indent : Natural);
- -- Outputs a string using the default output procedures
-
- procedure Write_Empty_Line (Always : Boolean := False);
- -- Outputs an empty line, only if the previous line was not empty
- -- already and either Always is True or Minimize_Empty_Lines is False.
-
- procedure Write_Line (S : String);
- -- Outputs S followed by a new line
-
- procedure Write_String
- (S : String;
- Indent : Natural;
- Truncated : Boolean := False);
- -- Outputs S using Write_Str, starting a new line if line would become
- -- too long, when Truncated = False. When Truncated = True, only the
- -- part of the string that can fit on the line is output.
-
- procedure Write_End_Of_Line_Comment (Node : Project_Node_Id);
- -- Needs comment???
-
- Write_Char : Write_Char_Ap := Output.Write_Char'Access;
- Write_Eol : Write_Eol_Ap := Output.Write_Eol'Access;
- Write_Str : Write_Str_Ap := Output.Write_Str'Access;
- -- These three access to procedure values are used for the output
-
- Last_Line_Is_Empty : Boolean := False;
- -- Used to avoid two consecutive empty lines
-
- Column : Natural := 0;
- -- Column number of the last character in the line. Used to avoid
- -- outputting lines longer than Max_Line_Length.
-
- First_With_In_List : Boolean := True;
- -- Indicate that the next with clause is first in a list such as
- -- with "A", "B";
- -- First_With_In_List will be True for "A", but not for "B".
-
- ---------------------------
- -- Output_Attribute_Name --
- ---------------------------
-
- procedure Output_Attribute_Name (Name : Name_Id; Indent : Natural) is
- begin
- if Backward_Compatibility then
- case Name is
- when Snames.Name_Spec =>
- Output_Name (Snames.Name_Specification, Indent);
-
- when Snames.Name_Spec_Suffix =>
- Output_Name (Snames.Name_Specification_Suffix, Indent);
-
- when Snames.Name_Body =>
- Output_Name (Snames.Name_Implementation, Indent);
-
- when Snames.Name_Body_Suffix =>
- Output_Name (Snames.Name_Implementation_Suffix, Indent);
-
- when others =>
- Output_Name (Name, Indent);
- end case;
-
- else
- Output_Name (Name, Indent);
- end if;
- end Output_Attribute_Name;
-
- -----------------
- -- Output_Name --
- -----------------
-
- procedure Output_Name
- (Name : Name_Id;
- Indent : Natural;
- Capitalize : Boolean := True)
- is
- Capital : Boolean := Capitalize;
-
- begin
- if Column = 0 and then Indent /= 0 then
- Start_Line (Indent + Increment);
- end if;
-
- Get_Name_String (Name);
-
- -- If line would become too long, create new line
-
- if Column + Name_Len > Max_Line_Length then
- Write_Eol.all;
- Column := 0;
-
- if Indent /= 0 then
- Start_Line (Indent + Increment);
- end if;
- end if;
-
- for J in 1 .. Name_Len loop
- if Capital then
- Write_Char (To_Upper (Name_Buffer (J)));
- else
- Write_Char (Name_Buffer (J));
- end if;
-
- if Capitalize then
- Capital :=
- Name_Buffer (J) = '_'
- or else Is_Digit (Name_Buffer (J));
- end if;
- end loop;
-
- Column := Column + Name_Len;
- end Output_Name;
-
- -------------------------
- -- Output_Project_File --
- -------------------------
-
- procedure Output_Project_File (S : Name_Id) is
- File_Name : constant String := Get_Name_String (S);
-
- begin
- Write_Char ('"');
-
- for J in File_Name'Range loop
- if File_Name (J) = '"' then
- Write_Char ('"');
- Write_Char ('"');
- else
- Write_Char (File_Name (J));
- end if;
- end loop;
-
- Write_Char ('"');
- end Output_Project_File;
-
- -------------------
- -- Output_String --
- -------------------
-
- procedure Output_String (S : Name_Id; Indent : Natural) is
- begin
- if Column = 0 and then Indent /= 0 then
- Start_Line (Indent + Increment);
- end if;
-
- Get_Name_String (S);
-
- -- If line could become too long, create new line. Note that the
- -- number of characters on the line could be twice the number of
- -- character in the string (if every character is a '"') plus two
- -- (the initial and final '"').
-
- if Column + Name_Len + Name_Len + 2 > Max_Line_Length then
- Write_Eol.all;
- Column := 0;
-
- if Indent /= 0 then
- Start_Line (Indent + Increment);
- end if;
- end if;
-
- Write_Char ('"');
- Column := Column + 1;
- Get_Name_String (S);
-
- for J in 1 .. Name_Len loop
- if Name_Buffer (J) = '"' then
- Write_Char ('"');
- Write_Char ('"');
- Column := Column + 2;
- else
- Write_Char (Name_Buffer (J));
- Column := Column + 1;
- end if;
-
- -- If the string does not fit on one line, cut it in parts and
- -- concatenate.
-
- if J < Name_Len and then Column >= Max_Line_Length then
- Write_Str (""" &");
- Write_Eol.all;
- Column := 0;
- Start_Line (Indent + Increment);
- Write_Char ('"');
- Column := Column + 1;
- end if;
- end loop;
-
- Write_Char ('"');
- Column := Column + 1;
- end Output_String;
-
- ----------------
- -- Start_Line --
- ----------------
-
- procedure Start_Line (Indent : Natural) is
- begin
- if not Minimize_Empty_Lines then
- Write_Str ((1 .. Indent => ' '));
- Column := Column + Indent;
- end if;
- end Start_Line;
-
- ----------------------
- -- Write_Empty_Line --
- ----------------------
-
- procedure Write_Empty_Line (Always : Boolean := False) is
- begin
- if (Always or else not Minimize_Empty_Lines)
- and then not Last_Line_Is_Empty
- then
- Write_Eol.all;
- Column := 0;
- Last_Line_Is_Empty := True;
- end if;
- end Write_Empty_Line;
-
- -------------------------------
- -- Write_End_Of_Line_Comment --
- -------------------------------
-
- procedure Write_End_Of_Line_Comment (Node : Project_Node_Id) is
- Value : constant Name_Id := End_Of_Line_Comment (Node, In_Tree);
-
- begin
- if Value /= No_Name then
- Write_String (" --", 0);
- Write_String (Get_Name_String (Value), 0, Truncated => True);
- end if;
-
- Write_Line ("");
- end Write_End_Of_Line_Comment;
-
- ----------------
- -- Write_Line --
- ----------------
-
- procedure Write_Line (S : String) is
- begin
- Write_String (S, 0);
- Last_Line_Is_Empty := False;
- Write_Eol.all;
- Column := 0;
- end Write_Line;
-
- ------------------
- -- Write_String --
- ------------------
-
- procedure Write_String
- (S : String;
- Indent : Natural;
- Truncated : Boolean := False)
- is
- Length : Natural := S'Length;
-
- begin
- if Column = 0 and then Indent /= 0 then
- Start_Line (Indent + Increment);
- end if;
-
- -- If the string would not fit on the line, start a new line
-
- if Column + Length > Max_Line_Length then
- if Truncated then
- Length := Max_Line_Length - Column;
-
- else
- Write_Eol.all;
- Column := 0;
-
- if Indent /= 0 then
- Start_Line (Indent + Increment);
- end if;
- end if;
- end if;
-
- Write_Str (S (S'First .. S'First + Length - 1));
- Column := Column + Length;
- end Write_String;
-
- -----------
- -- Print --
- -----------
-
- procedure Print (Node : Project_Node_Id; Indent : Natural) is
- begin
- if Present (Node) then
- case Kind_Of (Node, In_Tree) is
- when N_Project =>
- pragma Debug (Indicate_Tested (N_Project));
- if Present (First_With_Clause_Of (Node, In_Tree)) then
-
- -- with clause(s)
-
- First_With_In_List := True;
- Print (First_With_Clause_Of (Node, In_Tree), Indent);
- Write_Empty_Line (Always => True);
- end if;
-
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
-
- case Project_Qualifier_Of (Node, In_Tree) is
- when Standard
- | Unspecified
- =>
- null;
- when Aggregate =>
- Write_String ("aggregate ", Indent);
-
- when Aggregate_Library =>
- Write_String ("aggregate library ", Indent);
- when Library =>
- Write_String ("library ", Indent);
-
- when Configuration =>
- Write_String ("configuration ", Indent);
-
- when Abstract_Project =>
- Write_String ("abstract ", Indent);
- end case;
-
- Write_String ("project ", Indent);
-
- if Id /= Prj.No_Project then
- Output_Name (Id.Display_Name, Indent);
- else
- Output_Name (Name_Of (Node, In_Tree), Indent);
- end if;
-
- -- Check if this project extends another project
-
- if Extended_Project_Path_Of (Node, In_Tree) /= No_Path then
- Write_String (" extends ", Indent);
-
- if Is_Extending_All (Node, In_Tree) then
- Write_String ("all ", Indent);
- end if;
-
- Output_Project_File
- (Name_Id (Extended_Project_Path_Of (Node, In_Tree)));
- end if;
-
- Write_String (" is", Indent);
- Write_End_Of_Line_Comment (Node);
- Print
- (First_Comment_After (Node, In_Tree), Indent + Increment);
- Write_Empty_Line (Always => True);
-
- -- Output all of the declarations in the project
-
- Print (Project_Declaration_Of (Node, In_Tree), Indent);
- Print
- (First_Comment_Before_End (Node, In_Tree),
- Indent + Increment);
- Start_Line (Indent);
- Write_String ("end ", Indent);
-
- if Id /= Prj.No_Project then
- Output_Name (Id.Display_Name, Indent);
- else
- Output_Name (Name_Of (Node, In_Tree), Indent);
- end if;
-
- Write_Line (";");
- Print (First_Comment_After_End (Node, In_Tree), Indent);
-
- when N_With_Clause =>
- pragma Debug (Indicate_Tested (N_With_Clause));
-
- -- The with clause will sometimes contain an invalid name
- -- when we are importing a virtual project from an extending
- -- all project. Do not output anything in this case.
-
- if Name_Of (Node, In_Tree) /= No_Name
- and then String_Value_Of (Node, In_Tree) /= No_Name
- then
- if First_With_In_List then
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
-
- if Non_Limited_Project_Node_Of (Node, In_Tree) =
- Empty_Node
- then
- Write_String ("limited ", Indent);
- end if;
-
- Write_String ("with ", Indent);
- end if;
-
- -- Output the project name without concatenation, even if
- -- the line is too long.
-
- Output_Project_File (String_Value_Of (Node, In_Tree));
-
- if Is_Not_Last_In_List (Node, In_Tree) then
- Write_String (", ", Indent);
- First_With_In_List := False;
-
- else
- Write_String (";", Indent);
- Write_End_Of_Line_Comment (Node);
- Print (First_Comment_After (Node, In_Tree), Indent);
- First_With_In_List := True;
- end if;
- end if;
-
- Print (Next_With_Clause_Of (Node, In_Tree), Indent);
-
- when N_Project_Declaration =>
- pragma Debug (Indicate_Tested (N_Project_Declaration));
-
- if
- Present (First_Declarative_Item_Of (Node, In_Tree))
- then
- Print
- (First_Declarative_Item_Of (Node, In_Tree),
- Indent + Increment);
- Write_Empty_Line (Always => True);
- end if;
-
- when N_Declarative_Item =>
- pragma Debug (Indicate_Tested (N_Declarative_Item));
- Print (Current_Item_Node (Node, In_Tree), Indent);
- Print (Next_Declarative_Item (Node, In_Tree), Indent);
-
- when N_Package_Declaration =>
- pragma Debug (Indicate_Tested (N_Package_Declaration));
- Write_Empty_Line (Always => True);
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
- Write_String ("package ", Indent);
- Output_Name (Name_Of (Node, In_Tree), Indent);
-
- if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
- Empty_Node
- then
- if First_Declarative_Item_Of (Node, In_Tree) = Empty_Node
- then
- Write_String (" renames ", Indent);
- else
- Write_String (" extends ", Indent);
- end if;
-
- Output_Name
- (Name_Of
- (Project_Of_Renamed_Package_Of (Node, In_Tree),
- In_Tree),
- Indent);
- Write_String (".", Indent);
- Output_Name (Name_Of (Node, In_Tree), Indent);
- end if;
-
- if Project_Of_Renamed_Package_Of (Node, In_Tree) /=
- Empty_Node
- and then
- First_Declarative_Item_Of (Node, In_Tree) = Empty_Node
- then
- Write_String (";", Indent);
- Write_End_Of_Line_Comment (Node);
- Print (First_Comment_After_End (Node, In_Tree), Indent);
-
- else
- Write_String (" is", Indent);
- Write_End_Of_Line_Comment (Node);
- Print (First_Comment_After (Node, In_Tree),
- Indent + Increment);
-
- if First_Declarative_Item_Of (Node, In_Tree) /= Empty_Node
- then
- Print
- (First_Declarative_Item_Of (Node, In_Tree),
- Indent + Increment);
- end if;
-
- Print (First_Comment_Before_End (Node, In_Tree),
- Indent + Increment);
- Start_Line (Indent);
- Write_String ("end ", Indent);
- Output_Name (Name_Of (Node, In_Tree), Indent);
- Write_Line (";");
- Print (First_Comment_After_End (Node, In_Tree), Indent);
- Write_Empty_Line;
- end if;
-
- when N_String_Type_Declaration =>
- pragma Debug (Indicate_Tested (N_String_Type_Declaration));
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
- Write_String ("type ", Indent);
- Output_Name (Name_Of (Node, In_Tree), Indent);
- Write_Line (" is");
- Start_Line (Indent + Increment);
- Write_String ("(", Indent);
-
- declare
- String_Node : Project_Node_Id :=
- First_Literal_String (Node, In_Tree);
-
- begin
- while Present (String_Node) loop
- Output_String
- (String_Value_Of (String_Node, In_Tree), Indent);
- String_Node :=
- Next_Literal_String (String_Node, In_Tree);
-
- if Present (String_Node) then
- Write_String (", ", Indent);
- end if;
- end loop;
- end;
-
- Write_String (");", Indent);
- Write_End_Of_Line_Comment (Node);
- Print (First_Comment_After (Node, In_Tree), Indent);
-
- when N_Literal_String =>
- pragma Debug (Indicate_Tested (N_Literal_String));
- Output_String (String_Value_Of (Node, In_Tree), Indent);
-
- if Source_Index_Of (Node, In_Tree) /= 0 then
- Write_String (" at", Indent);
- Write_String
- (Source_Index_Of (Node, In_Tree)'Img, Indent);
- end if;
-
- when N_Attribute_Declaration =>
- pragma Debug (Indicate_Tested (N_Attribute_Declaration));
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
- Write_String ("for ", Indent);
- Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
-
- if Associative_Array_Index_Of (Node, In_Tree) /= No_Name then
- Write_String (" (", Indent);
- Output_String
- (Associative_Array_Index_Of (Node, In_Tree), Indent);
-
- if Source_Index_Of (Node, In_Tree) /= 0 then
- Write_String (" at", Indent);
- Write_String
- (Source_Index_Of (Node, In_Tree)'Img, Indent);
- end if;
-
- Write_String (")", Indent);
- end if;
-
- Write_String (" use ", Indent);
-
- if Present (Expression_Of (Node, In_Tree)) then
- Print (Expression_Of (Node, In_Tree), Indent);
-
- else
- -- Full associative array declaration
-
- if Present (Associative_Project_Of (Node, In_Tree)) then
- Output_Name
- (Name_Of
- (Associative_Project_Of (Node, In_Tree),
- In_Tree),
- Indent);
-
- if Present (Associative_Package_Of (Node, In_Tree))
- then
- Write_String (".", Indent);
- Output_Name
- (Name_Of
- (Associative_Package_Of (Node, In_Tree),
- In_Tree),
- Indent);
- end if;
-
- elsif Present (Associative_Package_Of (Node, In_Tree))
- then
- Output_Name
- (Name_Of
- (Associative_Package_Of (Node, In_Tree),
- In_Tree),
- Indent);
- end if;
-
- Write_String ("'", Indent);
- Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
- end if;
-
- Write_String (";", Indent);
- Write_End_Of_Line_Comment (Node);
- Print (First_Comment_After (Node, In_Tree), Indent);
-
- when N_Typed_Variable_Declaration =>
- pragma Debug
- (Indicate_Tested (N_Typed_Variable_Declaration));
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
- Output_Name (Name_Of (Node, In_Tree), Indent);
- Write_String (" : ", Indent);
- Output_Name
- (Name_Of (String_Type_Of (Node, In_Tree), In_Tree),
- Indent);
- Write_String (" := ", Indent);
- Print (Expression_Of (Node, In_Tree), Indent);
- Write_String (";", Indent);
- Write_End_Of_Line_Comment (Node);
- Print (First_Comment_After (Node, In_Tree), Indent);
-
- when N_Variable_Declaration =>
- pragma Debug (Indicate_Tested (N_Variable_Declaration));
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
- Output_Name (Name_Of (Node, In_Tree), Indent);
- Write_String (" := ", Indent);
- Print (Expression_Of (Node, In_Tree), Indent);
- Write_String (";", Indent);
- Write_End_Of_Line_Comment (Node);
- Print (First_Comment_After (Node, In_Tree), Indent);
-
- when N_Expression =>
- pragma Debug (Indicate_Tested (N_Expression));
- declare
- Term : Project_Node_Id := First_Term (Node, In_Tree);
-
- begin
- while Present (Term) loop
- Print (Term, Indent);
- Term := Next_Term (Term, In_Tree);
-
- if Present (Term) then
- Write_String (" & ", Indent);
- end if;
- end loop;
- end;
-
- when N_Term =>
- pragma Debug (Indicate_Tested (N_Term));
- Print (Current_Term (Node, In_Tree), Indent);
-
- when N_Literal_String_List =>
- pragma Debug (Indicate_Tested (N_Literal_String_List));
- Write_String ("(", Indent);
-
- declare
- Expression : Project_Node_Id :=
- First_Expression_In_List (Node, In_Tree);
-
- begin
- while Present (Expression) loop
- Print (Expression, Indent);
- Expression :=
- Next_Expression_In_List (Expression, In_Tree);
-
- if Present (Expression) then
- Write_String (", ", Indent);
- end if;
- end loop;
- end;
-
- Write_String (")", Indent);
-
- when N_Variable_Reference =>
- pragma Debug (Indicate_Tested (N_Variable_Reference));
- if Present (Project_Node_Of (Node, In_Tree)) then
- Output_Name
- (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree),
- Indent);
- Write_String (".", Indent);
- end if;
-
- if Present (Package_Node_Of (Node, In_Tree)) then
- Output_Name
- (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
- Indent);
- Write_String (".", Indent);
- end if;
-
- Output_Name (Name_Of (Node, In_Tree), Indent);
-
- when N_External_Value =>
- pragma Debug (Indicate_Tested (N_External_Value));
- Write_String ("external (", Indent);
- Print (External_Reference_Of (Node, In_Tree), Indent);
-
- if Present (External_Default_Of (Node, In_Tree)) then
- Write_String (", ", Indent);
- Print (External_Default_Of (Node, In_Tree), Indent);
- end if;
-
- Write_String (")", Indent);
-
- when N_Attribute_Reference =>
- pragma Debug (Indicate_Tested (N_Attribute_Reference));
-
- if Present (Project_Node_Of (Node, In_Tree))
- and then Project_Node_Of (Node, In_Tree) /= Project
- then
- Output_Name
- (Name_Of (Project_Node_Of (Node, In_Tree), In_Tree),
- Indent);
-
- if Present (Package_Node_Of (Node, In_Tree)) then
- Write_String (".", Indent);
- Output_Name
- (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
- Indent);
- end if;
-
- elsif Present (Package_Node_Of (Node, In_Tree)) then
- Output_Name
- (Name_Of (Package_Node_Of (Node, In_Tree), In_Tree),
- Indent);
-
- else
- Write_String ("project", Indent);
- end if;
-
- Write_String ("'", Indent);
- Output_Attribute_Name (Name_Of (Node, In_Tree), Indent);
-
- declare
- Index : constant Name_Id :=
- Associative_Array_Index_Of (Node, In_Tree);
- begin
- if Index /= No_Name then
- Write_String (" (", Indent);
- Output_String (Index, Indent);
- Write_String (")", Indent);
- end if;
- end;
-
- when N_Case_Construction =>
- pragma Debug (Indicate_Tested (N_Case_Construction));
-
- declare
- Case_Item : Project_Node_Id;
- Is_Non_Empty : Boolean := False;
-
- begin
- Case_Item := First_Case_Item_Of (Node, In_Tree);
- while Present (Case_Item) loop
- if Present
- (First_Declarative_Item_Of (Case_Item, In_Tree))
- or else not Eliminate_Empty_Case_Constructions
- then
- Is_Non_Empty := True;
- exit;
- end if;
-
- Case_Item := Next_Case_Item (Case_Item, In_Tree);
- end loop;
-
- if Is_Non_Empty then
- Write_Empty_Line;
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
- Write_String ("case ", Indent);
- Print
- (Case_Variable_Reference_Of (Node, In_Tree), Indent);
- Write_String (" is", Indent);
- Write_End_Of_Line_Comment (Node);
- Print
- (First_Comment_After (Node, In_Tree),
- Indent + Increment);
-
- declare
- Case_Item : Project_Node_Id :=
- First_Case_Item_Of (Node, In_Tree);
- begin
- while Present (Case_Item) loop
- pragma Assert
- (Kind_Of (Case_Item, In_Tree) = N_Case_Item);
- Print (Case_Item, Indent + Increment);
- Case_Item :=
- Next_Case_Item (Case_Item, In_Tree);
- end loop;
- end;
-
- Print (First_Comment_Before_End (Node, In_Tree),
- Indent + Increment);
- Start_Line (Indent);
- Write_Line ("end case;");
- Print
- (First_Comment_After_End (Node, In_Tree), Indent);
- end if;
- end;
-
- when N_Case_Item =>
- pragma Debug (Indicate_Tested (N_Case_Item));
-
- if Present (First_Declarative_Item_Of (Node, In_Tree))
- or else not Eliminate_Empty_Case_Constructions
- then
- Write_Empty_Line;
- Print (First_Comment_Before (Node, In_Tree), Indent);
- Start_Line (Indent);
- Write_String ("when ", Indent);
-
- if No (First_Choice_Of (Node, In_Tree)) then
- Write_String ("others", Indent);
-
- else
- declare
- Label : Project_Node_Id :=
- First_Choice_Of (Node, In_Tree);
-
- begin
- while Present (Label) loop
- Print (Label, Indent);
- Label := Next_Literal_String (Label, In_Tree);
-
- if Present (Label) then
- Write_String (" | ", Indent);
- end if;
- end loop;
- end;
- end if;
-
- Write_String (" =>", Indent);
- Write_End_Of_Line_Comment (Node);
- Print
- (First_Comment_After (Node, In_Tree),
- Indent + Increment);
-
- declare
- First : constant Project_Node_Id :=
- First_Declarative_Item_Of (Node, In_Tree);
- begin
- if No (First) then
- Write_Empty_Line;
- else
- Print (First, Indent + Increment);
- end if;
- end;
- end if;
-
- when N_Comment_Zones =>
-
- -- Nothing to do, because it will not be processed directly
-
- null;
-
- when N_Comment =>
- pragma Debug (Indicate_Tested (N_Comment));
-
- if Follows_Empty_Line (Node, In_Tree) then
- Write_Empty_Line;
- end if;
-
- Start_Line (Indent);
- Write_String ("--", Indent);
- Write_String
- (Get_Name_String (String_Value_Of (Node, In_Tree)),
- Indent,
- Truncated => True);
- Write_Line ("");
-
- if Is_Followed_By_Empty_Line (Node, In_Tree) then
- Write_Empty_Line;
- end if;
-
- Print (Next_Comment (Node, In_Tree), Indent);
- end case;
- end if;
- end Print;
-
- -- Start of processing for Pretty_Print
-
- begin
- if W_Char = null then
- Write_Char := Output.Write_Char'Access;
- else
- Write_Char := W_Char;
- end if;
-
- if W_Eol = null then
- Write_Eol := Output.Write_Eol'Access;
- else
- Write_Eol := W_Eol;
- end if;
-
- if W_Str = null then
- Write_Str := Output.Write_Str'Access;
- else
- Write_Str := W_Str;
- end if;
-
- Print (Project, 0);
- end Pretty_Print;
-
- -----------------------
- -- Output_Statistics --
- -----------------------
-
- procedure Output_Statistics is
- begin
- Output.Write_Line ("Project_Node_Kinds not tested:");
-
- for Kind in Project_Node_Kind loop
- if Kind /= N_Comment_Zones and then Not_Tested (Kind) then
- Output.Write_Str (" ");
- Output.Write_Line (Project_Node_Kind'Image (Kind));
- end if;
- end loop;
-
- Output.Write_Eol;
- end Output_Statistics;
-
- ---------
- -- wpr --
- ---------
-
- procedure wpr
- (Project : Prj.Tree.Project_Node_Id;
- In_Tree : Prj.Tree.Project_Node_Tree_Ref)
- is
- begin
- Pretty_Print (Project, In_Tree, Backward_Compatibility => False);
- end wpr;
-
-end Prj.PP;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P P --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2011, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is the Project File Pretty Printer
-
--- Used to output a project file from a project file tree.
--- Used by gnatname to update or create project files.
--- Also used GPS to display project file trees.
--- Also be used for debugging tools that create project file trees.
-
-with Prj.Tree;
-
-package Prj.PP is
-
- -- The following access to procedure types are used to redirect output when
- -- calling Pretty_Print.
-
- type Write_Char_Ap is access procedure (C : Character);
-
- type Write_Eol_Ap is access procedure;
-
- type Write_Str_Ap is access procedure (S : String);
-
- subtype Max_Length_Of_Line is Positive range 50 .. 255;
-
- procedure Pretty_Print
- (Project : Prj.Tree.Project_Node_Id;
- In_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Increment : Positive := 3;
- Eliminate_Empty_Case_Constructions : Boolean := False;
- Minimize_Empty_Lines : Boolean := False;
- W_Char : Write_Char_Ap := null;
- W_Eol : Write_Eol_Ap := null;
- W_Str : Write_Str_Ap := null;
- Backward_Compatibility : Boolean;
- Id : Prj.Project_Id := Prj.No_Project;
- Max_Line_Length : Max_Length_Of_Line :=
- Max_Length_Of_Line'Last);
- -- Output a project file, using either the default output routines, or the
- -- ones specified by W_Char, W_Eol and W_Str.
- --
- -- Increment is the number of spaces for each indentation level
- --
- -- W_Char, W_Eol and W_Str can be used to change the default output
- -- procedures. The default values force the output to Standard_Output.
- --
- -- If Eliminate_Empty_Case_Constructions is True, then case constructions
- -- and case items that do not include any declarations will not be output.
- --
- -- If Minimize_Empty_Lines is True, empty lines will be output only after
- -- the last with clause, after the line declaring the project name, after
- -- the last declarative item of the project and before each package
- -- declaration. Otherwise, more empty lines are output.
- --
- -- If Backward_Compatibility is True, then new attributes (Spec,
- -- Spec_Suffix, Body, Body_Suffix) will be replaced by obsolete ones
- -- (Specification, Specification_Suffix, Implementation,
- -- Implementation_Suffix).
- --
- -- Id is used to compute the display name of the project including its
- -- proper casing.
- --
- -- Max_Line_Length is the maximum line length in the project file
-
-private
-
- procedure Output_Statistics;
- -- This procedure can be used after one or more calls to Pretty_Print to
- -- display what Project_Node_Kinds have not been exercised by the call(s)
- -- to Pretty_Print. It is used only for testing purposes.
-
- procedure wpr
- (Project : Prj.Tree.Project_Node_Id;
- In_Tree : Prj.Tree.Project_Node_Tree_Ref);
- -- Wrapper for use from gdb: call Pretty_Print with default parameters
-
-end Prj.PP;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P R O C --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Atree; use Atree;
-with Err_Vars; use Err_Vars;
-with Opt; use Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Attr; use Prj.Attr;
-with Prj.Env;
-with Prj.Err; use Prj.Err;
-with Prj.Ext; use Prj.Ext;
-with Prj.Nmsc; use Prj.Nmsc;
-with Prj.Part;
-with Prj.Util;
-with Snames;
-
-with Ada.Containers.Vectors;
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.HTable;
-
-package body Prj.Proc is
-
- package Processed_Projects is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Project_Id,
- No_Element => No_Project,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
- -- This hash table contains all processed projects
-
- package Unit_Htable is new GNAT.HTable.Simple_HTable
- (Header_Num => Header_Num,
- Element => Source_Id,
- No_Element => No_Source,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
- -- This hash table contains all processed projects
-
- package Runtime_Defaults is new GNAT.HTable.Simple_HTable
- (Header_Num => Prj.Header_Num,
- Element => Name_Id,
- No_Element => No_Name,
- Key => Name_Id,
- Hash => Prj.Hash,
- Equal => "=");
- -- Stores the default values of 'Runtime names for the various languages
-
- package Name_Ids is new Ada.Containers.Vectors (Positive, Name_Id);
-
- procedure Add (To_Exp : in out Name_Id; Str : Name_Id);
- -- Concatenate two strings and returns another string if both
- -- arguments are not null string.
-
- -- In the following procedures, we are expected to guess the meaning of
- -- the parameters from their names, this is never a good idea, comments
- -- should be added precisely defining every formal ???
-
- procedure Add_Attributes
- (Project : Project_Id;
- Project_Name : Name_Id;
- Project_Dir : Name_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Decl : in out Declarations;
- First : Attribute_Node_Id;
- Project_Level : Boolean);
- -- Add all attributes, starting with First, with their default values to
- -- the package or project with declarations Decl.
-
- procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- 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.
- -- If Allow_Duplicate_Basenames, then files with the same base names are
- -- authorized within a project for source-based languages (never for unit
- -- based languages)
-
- procedure Copy_Package_Declarations
- (From : Declarations;
- To : in out Declarations;
- New_Loc : Source_Ptr;
- Restricted : Boolean;
- Shared : Shared_Project_Tree_Data_Access);
- -- Copy a package declaration From to To for a renamed package. Change the
- -- locations of all the attributes to New_Loc. When Restricted is
- -- True, do not copy attributes Body, Spec, Implementation, Specification
- -- and Linker_Options.
-
- function Expression
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : Prj.Tree.Environment;
- Pkg : Package_Id;
- First_Term : Project_Node_Id;
- Kind : Variable_Kind) return Variable_Value;
- -- From N_Expression project node From_Project_Node, compute the value
- -- of an expression and return it as a Variable_Value.
-
- function Imported_Or_Extended_Project_From
- (Project : Project_Id;
- With_Name : Name_Id;
- No_Extending : Boolean := False) return Project_Id;
- -- Find an imported or extended project of Project whose name is With_Name.
- -- When No_Extending is True, do not look for extending projects, returns
- -- the exact project whose name is With_Name.
-
- function Package_From
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access;
- With_Name : Name_Id) return Package_Id;
- -- 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;
- Child_Env : in out Prj.Tree.Environment);
- -- 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.
- --
- -- Child_Env is the modified environment after seeing declarations like
- -- "for External(...) use" or "for Project_Path use" in aggregate projects.
- -- It should have been initialized first.
-
- procedure Recursive_Process
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Packages_To_Check : String_List_Access;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Extended_By : Project_Id;
- From_Encapsulated_Lib : Boolean;
- On_New_Tree_Loaded : Tree_Loaded_Callback := null);
- -- Process project with node From_Project_Node in the tree. Do nothing if
- -- From_Project_Node is Empty_Node. If project has already been processed,
- -- simply return its project id. Otherwise create a new project id, mark it
- -- as processed, call itself recursively for all imported projects and a
- -- extended project, if any. Then process the declarative items of the
- -- project.
- --
- -- Is_Root_Project should be true only for the project that the user
- -- explicitly loaded. In the context of aggregate projects, only that
- -- project is allowed to modify the environment that will be used to load
- -- projects (Child_Env).
- --
- -- From_Encapsulated_Lib is true if we are parsing a project from
- -- encapsulated library dependencies.
- --
- -- If specified, On_New_Tree_Loaded is called after each aggregated project
- -- has been processed successfully.
-
- function Get_Attribute_Index
- (Tree : Project_Node_Tree_Ref;
- Attr : Project_Node_Id;
- Index : Name_Id) return Name_Id;
- -- Copy the index of the attribute into Name_Buffer, converting to lower
- -- case if the attribute is case-insensitive.
-
- ---------
- -- Add --
- ---------
-
- procedure Add (To_Exp : in out Name_Id; Str : Name_Id) is
- begin
- if To_Exp = No_Name or else To_Exp = Empty_String then
-
- -- To_Exp is nil or empty. The result is Str
-
- To_Exp := Str;
-
- -- If Str is nil, then do not change To_Ext
-
- elsif Str /= No_Name and then Str /= Empty_String then
- declare
- S : constant String := Get_Name_String (Str);
- begin
- Get_Name_String (To_Exp);
- Add_Str_To_Name_Buffer (S);
- To_Exp := Name_Find;
- end;
- end if;
- end Add;
-
- --------------------
- -- Add_Attributes --
- --------------------
-
- procedure Add_Attributes
- (Project : Project_Id;
- Project_Name : Name_Id;
- Project_Dir : Name_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Decl : in out Declarations;
- First : Attribute_Node_Id;
- Project_Level : Boolean)
- is
- The_Attribute : Attribute_Node_Id := First;
-
- begin
- while The_Attribute /= Empty_Attribute loop
- if Attribute_Kind_Of (The_Attribute) = Single then
- declare
- New_Attribute : Variable_Value;
-
- begin
- case Variable_Kind_Of (The_Attribute) is
-
- -- Undefined should not happen
-
- when Undefined =>
- pragma Assert
- (False, "attribute with an undefined kind");
- raise Program_Error;
-
- -- Single attributes have a default value of empty string
-
- when Single =>
- New_Attribute :=
- (Project => Project,
- Kind => Single,
- Location => No_Location,
- Default => True,
- Value => Empty_String,
- Index => 0);
-
- -- Special cases of <project>'Name and
- -- <project>'Project_Dir.
-
- if Project_Level then
- if Attribute_Name_Of (The_Attribute) =
- Snames.Name_Name
- then
- New_Attribute.Value := Project_Name;
-
- elsif Attribute_Name_Of (The_Attribute) =
- Snames.Name_Project_Dir
- then
- New_Attribute.Value := Project_Dir;
- end if;
- end if;
-
- -- List attributes have a default value of nil list
-
- when List =>
- New_Attribute :=
- (Project => Project,
- Kind => List,
- Location => No_Location,
- Default => True,
- Values => Nil_String);
-
- end case;
-
- Variable_Element_Table.Increment_Last
- (Shared.Variable_Elements);
- Shared.Variable_Elements.Table
- (Variable_Element_Table.Last (Shared.Variable_Elements)) :=
- (Next => Decl.Attributes,
- Name => Attribute_Name_Of (The_Attribute),
- Value => New_Attribute);
- Decl.Attributes :=
- Variable_Element_Table.Last
- (Shared.Variable_Elements);
- end;
- end if;
-
- The_Attribute := Next_Attribute (After => The_Attribute);
- end loop;
- end Add_Attributes;
-
- -----------
- -- Check --
- -----------
-
- procedure Check
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- Node_Tree : Prj.Tree.Project_Node_Tree_Ref;
- Flags : Processing_Flags)
- is
- begin
- Process_Naming_Scheme (In_Tree, Project, Node_Tree, Flags);
-
- -- Set the Other_Part field for the units
-
- declare
- Source1 : Source_Id;
- Name : Name_Id;
- Source2 : Source_Id;
- Iter : Source_Iterator;
-
- begin
- Unit_Htable.Reset;
-
- Iter := For_Each_Source (In_Tree);
- loop
- Source1 := Prj.Element (Iter);
- exit when Source1 = No_Source;
-
- if Source1.Unit /= No_Unit_Index then
- Name := Source1.Unit.Name;
- Source2 := Unit_Htable.Get (Name);
-
- if Source2 = No_Source then
- Unit_Htable.Set (K => Name, E => Source1);
- else
- Unit_Htable.Remove (Name);
- end if;
- end if;
-
- Next (Iter);
- end loop;
- end;
- end Check;
-
- -------------------------------
- -- Copy_Package_Declarations --
- -------------------------------
-
- procedure Copy_Package_Declarations
- (From : Declarations;
- To : in out Declarations;
- New_Loc : Source_Ptr;
- Restricted : Boolean;
- Shared : Shared_Project_Tree_Data_Access)
- is
- V1 : Variable_Id;
- V2 : Variable_Id := No_Variable;
- Var : Variable;
- A1 : Array_Id;
- A2 : Array_Id := No_Array;
- Arr : Array_Data;
- E1 : Array_Element_Id;
- E2 : Array_Element_Id := No_Array_Element;
- Elm : Array_Element;
-
- begin
- -- To avoid references in error messages to attribute declarations in
- -- an original package that has been renamed, copy all the attribute
- -- declarations of the package and change all locations to New_Loc,
- -- the location of the renamed package.
-
- -- First single attributes
-
- V1 := From.Attributes;
- while V1 /= No_Variable loop
-
- -- Copy the attribute
-
- Var := Shared.Variable_Elements.Table (V1);
- V1 := Var.Next;
-
- -- Do not copy the value of attribute Linker_Options if Restricted
-
- if Restricted and then Var.Name = Snames.Name_Linker_Options then
- Var.Value.Values := Nil_String;
- end if;
-
- -- Remove the Next component
-
- Var.Next := No_Variable;
-
- -- Change the location to New_Loc
-
- Var.Value.Location := New_Loc;
- Variable_Element_Table.Increment_Last (Shared.Variable_Elements);
-
- -- Put in new declaration
-
- if To.Attributes = No_Variable then
- To.Attributes :=
- Variable_Element_Table.Last (Shared.Variable_Elements);
- else
- Shared.Variable_Elements.Table (V2).Next :=
- Variable_Element_Table.Last (Shared.Variable_Elements);
- end if;
-
- V2 := Variable_Element_Table.Last (Shared.Variable_Elements);
- Shared.Variable_Elements.Table (V2) := Var;
- end loop;
-
- -- Then the associated array attributes
-
- A1 := From.Arrays;
- while A1 /= No_Array loop
- Arr := Shared.Arrays.Table (A1);
- A1 := Arr.Next;
-
- -- Remove the Next component
-
- Arr.Next := No_Array;
- Array_Table.Increment_Last (Shared.Arrays);
-
- -- Create new Array declaration
-
- if To.Arrays = No_Array then
- To.Arrays := Array_Table.Last (Shared.Arrays);
- else
- Shared.Arrays.Table (A2).Next :=
- Array_Table.Last (Shared.Arrays);
- end if;
-
- A2 := Array_Table.Last (Shared.Arrays);
-
- -- Don't store the array as its first element has not been set yet
-
- -- Copy the array elements of the array
-
- E1 := Arr.Value;
- Arr.Value := No_Array_Element;
- while E1 /= No_Array_Element loop
-
- -- Copy the array element
-
- Elm := Shared.Array_Elements.Table (E1);
- E1 := Elm.Next;
-
- -- Remove the Next component
-
- Elm.Next := No_Array_Element;
-
- Elm.Restricted := Restricted;
-
- -- Change the location
-
- Elm.Value.Location := New_Loc;
- Array_Element_Table.Increment_Last (Shared.Array_Elements);
-
- -- Create new array element
-
- if Arr.Value = No_Array_Element then
- Arr.Value := Array_Element_Table.Last (Shared.Array_Elements);
- else
- Shared.Array_Elements.Table (E2).Next :=
- Array_Element_Table.Last (Shared.Array_Elements);
- end if;
-
- E2 := Array_Element_Table.Last (Shared.Array_Elements);
- Shared.Array_Elements.Table (E2) := Elm;
- end loop;
-
- -- Finally, store the new array
-
- Shared.Arrays.Table (A2) := Arr;
- end loop;
- end Copy_Package_Declarations;
-
- -------------------------
- -- Get_Attribute_Index --
- -------------------------
-
- function Get_Attribute_Index
- (Tree : Project_Node_Tree_Ref;
- Attr : Project_Node_Id;
- Index : Name_Id) return Name_Id
- is
- begin
- if Index = All_Other_Names
- or else not Case_Insensitive (Attr, Tree)
- then
- return Index;
- end if;
-
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- return Name_Find;
- end Get_Attribute_Index;
-
- ----------------
- -- Expression --
- ----------------
-
- function Expression
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : Prj.Tree.Environment;
- Pkg : Package_Id;
- First_Term : Project_Node_Id;
- Kind : Variable_Kind) return Variable_Value
- is
- The_Term : Project_Node_Id;
- -- The term in the expression list
-
- The_Current_Term : Project_Node_Id := Empty_Node;
- -- The current term node id
-
- Result : Variable_Value (Kind => Kind);
- -- The returned result
-
- Last : String_List_Id := Nil_String;
- -- Reference to the last string elements in Result, when Kind is List
-
- Current_Term_Kind : Project_Node_Kind;
-
- begin
- Result.Project := Project;
- Result.Location := Location_Of (First_Term, From_Project_Node_Tree);
-
- -- 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);
-
- if The_Current_Term /= Empty_Node then
- Current_Term_Kind :=
- Kind_Of (The_Current_Term, From_Project_Node_Tree);
-
- case Current_Term_Kind is
- when N_Literal_String =>
- case Kind is
- when Undefined =>
-
- -- Should never happen
-
- pragma Assert (False, "Undefined expression kind");
- raise Program_Error;
-
- when Single =>
- Add (Result.Value,
- String_Value_Of
- (The_Current_Term, From_Project_Node_Tree));
- Result.Index :=
- Source_Index_Of
- (The_Current_Term, From_Project_Node_Tree);
-
- when List =>
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- if Last = Nil_String then
-
- -- This can happen in an expression like () & "toto"
-
- Result.Values := String_Element_Table.Last
- (Shared.String_Elements);
-
- else
- Shared.String_Elements.Table
- (Last).Next := String_Element_Table.Last
- (Shared.String_Elements);
- end if;
-
- Last := String_Element_Table.Last
- (Shared.String_Elements);
-
- Shared.String_Elements.Table (Last) :=
- (Value => String_Value_Of
- (The_Current_Term,
- From_Project_Node_Tree),
- Index => Source_Index_Of
- (The_Current_Term,
- From_Project_Node_Tree),
- Display_Value => No_Name,
- Location => Location_Of
- (The_Current_Term,
- From_Project_Node_Tree),
- Flag => False,
- Next => Nil_String);
- end case;
-
- when N_Literal_String_List =>
- declare
- String_Node : Project_Node_Id :=
- First_Expression_In_List
- (The_Current_Term,
- From_Project_Node_Tree);
-
- Value : Variable_Value;
-
- begin
- if Present (String_Node) then
-
- -- If String_Node is nil, it is an empty list, there is
- -- nothing to do.
-
- Value := Expression
- (Project => Project,
- Shared => Shared,
- From_Project_Node => From_Project_Node,
- From_Project_Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Pkg => Pkg,
- First_Term =>
- Tree.First_Term
- (String_Node, From_Project_Node_Tree),
- Kind => Single);
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- if Result.Values = Nil_String then
-
- -- This literal string list is the first term in a
- -- string list expression
-
- Result.Values :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- else
- Shared.String_Elements.Table (Last).Next :=
- String_Element_Table.Last (Shared.String_Elements);
- end if;
-
- Last :=
- String_Element_Table.Last (Shared.String_Elements);
-
- Shared.String_Elements.Table (Last) :=
- (Value => Value.Value,
- Display_Value => No_Name,
- Location => Value.Location,
- Flag => False,
- Next => Nil_String,
- Index => Value.Index);
-
- loop
- -- Add the other element of the literal string list
- -- one after the other.
-
- String_Node :=
- Next_Expression_In_List
- (String_Node, From_Project_Node_Tree);
-
- exit when No (String_Node);
-
- Value :=
- Expression
- (Project => Project,
- Shared => Shared,
- From_Project_Node => From_Project_Node,
- From_Project_Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Pkg => Pkg,
- First_Term =>
- Tree.First_Term
- (String_Node, From_Project_Node_Tree),
- Kind => Single);
-
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
- Shared.String_Elements.Table (Last).Next :=
- String_Element_Table.Last (Shared.String_Elements);
- Last := String_Element_Table.Last
- (Shared.String_Elements);
- Shared.String_Elements.Table (Last) :=
- (Value => Value.Value,
- Display_Value => No_Name,
- Location => Value.Location,
- Flag => False,
- Next => Nil_String,
- Index => Value.Index);
- end loop;
- end if;
- end;
-
- when N_Attribute_Reference
- | N_Variable_Reference
- =>
- declare
- The_Project : Project_Id := Project;
- The_Package : Package_Id := Pkg;
- The_Name : Name_Id := No_Name;
- The_Variable_Id : Variable_Id := No_Variable;
- The_Variable : Variable_Value;
- Term_Project : constant Project_Node_Id :=
- Project_Node_Of
- (The_Current_Term,
- From_Project_Node_Tree);
- Term_Package : constant Project_Node_Id :=
- Package_Node_Of
- (The_Current_Term,
- From_Project_Node_Tree);
- Index : Name_Id := No_Name;
-
- begin
- <<Object_Dir_Restart>>
- The_Project := Project;
- The_Package := Pkg;
- The_Name := No_Name;
- The_Variable_Id := No_Variable;
- Index := No_Name;
-
- if Present (Term_Project)
- and then Term_Project /= From_Project_Node
- then
- -- This variable or attribute comes from another project
-
- The_Name :=
- Name_Of (Term_Project, From_Project_Node_Tree);
- The_Project := Imported_Or_Extended_Project_From
- (Project => Project,
- With_Name => The_Name,
- No_Extending => True);
- end if;
-
- if Present (Term_Package) then
-
- -- This is an attribute of a package
-
- The_Name :=
- Name_Of (Term_Package, From_Project_Node_Tree);
-
- The_Package := The_Project.Decl.Packages;
- while The_Package /= No_Package
- and then Shared.Packages.Table (The_Package).Name /=
- The_Name
- loop
- The_Package :=
- Shared.Packages.Table (The_Package).Next;
- end loop;
-
- pragma Assert
- (The_Package /= No_Package, "package not found.");
-
- elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =
- N_Attribute_Reference
- then
- The_Package := No_Package;
- end if;
-
- The_Name :=
- Name_Of (The_Current_Term, From_Project_Node_Tree);
-
- if Current_Term_Kind = N_Attribute_Reference then
- Index :=
- Associative_Array_Index_Of
- (The_Current_Term, From_Project_Node_Tree);
- end if;
-
- -- If it is not an associative array attribute
-
- if Index = No_Name then
-
- -- It is not an associative array attribute
-
- if The_Package /= No_Package then
-
- -- First, if there is a package, look into the package
-
- if Current_Term_Kind = N_Variable_Reference then
- The_Variable_Id :=
- Shared.Packages.Table
- (The_Package).Decl.Variables;
- else
- The_Variable_Id :=
- Shared.Packages.Table
- (The_Package).Decl.Attributes;
- end if;
-
- while The_Variable_Id /= No_Variable
- and then Shared.Variable_Elements.Table
- (The_Variable_Id).Name /= The_Name
- loop
- The_Variable_Id :=
- Shared.Variable_Elements.Table
- (The_Variable_Id).Next;
- end loop;
-
- end if;
-
- if The_Variable_Id = No_Variable then
-
- -- If we have not found it, look into the project
-
- if Current_Term_Kind = N_Variable_Reference then
- The_Variable_Id := The_Project.Decl.Variables;
- else
- The_Variable_Id := The_Project.Decl.Attributes;
- end if;
-
- while The_Variable_Id /= No_Variable
- and then Shared.Variable_Elements.Table
- (The_Variable_Id).Name /= The_Name
- loop
- The_Variable_Id :=
- Shared.Variable_Elements.Table
- (The_Variable_Id).Next;
- end loop;
-
- end if;
-
- if From_Project_Node_Tree.Incomplete_With then
- if The_Variable_Id = No_Variable then
- The_Variable := Nil_Variable_Value;
- else
- The_Variable :=
- Shared.Variable_Elements.Table
- (The_Variable_Id).Value;
- end if;
-
- else
- pragma Assert (The_Variable_Id /= No_Variable,
- "variable or attribute not found");
-
- The_Variable :=
- Shared.Variable_Elements.Table
- (The_Variable_Id).Value;
- end if;
-
- else
-
- -- It is an associative array attribute
-
- declare
- The_Array : Array_Id := No_Array;
- The_Element : Array_Element_Id := No_Array_Element;
- Array_Index : Name_Id := No_Name;
-
- begin
- if The_Package /= No_Package then
- The_Array :=
- Shared.Packages.Table (The_Package).Decl.Arrays;
- else
- The_Array := The_Project.Decl.Arrays;
- end if;
-
- while The_Array /= No_Array
- and then Shared.Arrays.Table (The_Array).Name /=
- The_Name
- loop
- The_Array := Shared.Arrays.Table (The_Array).Next;
- end loop;
-
- if The_Array /= No_Array then
- The_Element :=
- Shared.Arrays.Table (The_Array).Value;
- Array_Index :=
- Get_Attribute_Index
- (From_Project_Node_Tree,
- The_Current_Term,
- Index);
-
- while The_Element /= No_Array_Element
- and then Shared.Array_Elements.Table
- (The_Element).Index /= Array_Index
- loop
- The_Element :=
- Shared.Array_Elements.Table (The_Element).Next;
- end loop;
-
- end if;
-
- if The_Element /= No_Array_Element then
- The_Variable :=
- Shared.Array_Elements.Table (The_Element).Value;
-
- else
- if Expression_Kind_Of
- (The_Current_Term, From_Project_Node_Tree) =
- List
- then
- The_Variable :=
- (Project => Project,
- Kind => List,
- Location => No_Location,
- Default => True,
- Values => Nil_String);
- else
- The_Variable :=
- (Project => Project,
- Kind => Single,
- Location => No_Location,
- Default => True,
- Value => Empty_String,
- Index => 0);
- end if;
- end if;
- end;
- end if;
-
- -- Check the defaults
-
- if Current_Term_Kind = N_Attribute_Reference then
- declare
- The_Default : constant Attribute_Default_Value :=
- Default_Of
- (The_Current_Term, From_Project_Node_Tree);
-
- begin
- -- Check the special value for 'Target when specified
-
- if The_Default = Target_Value
- and then Opt.Target_Origin = Specified
- then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Opt.Target_Value.all);
- The_Variable.Value := Name_Find;
-
- -- Check the defaults
-
- elsif The_Variable.Default then
- case The_Variable.Kind is
-
- when Undefined =>
- null;
-
- when Single =>
- case The_Default is
- when Read_Only_Value =>
- null;
-
- when Empty_Value =>
- The_Variable.Value := Empty_String;
-
- when Dot_Value =>
- The_Variable.Value := Dot_String;
-
- when Object_Dir_Value =>
- From_Project_Node_Tree.Project_Nodes.Table
- (The_Current_Term).Name :=
- Snames.Name_Object_Dir;
- From_Project_Node_Tree.Project_Nodes.Table
- (The_Current_Term).Default :=
- Dot_Value;
- goto Object_Dir_Restart;
-
- when Target_Value =>
- if Opt.Target_Value = null then
- The_Variable.Value := Empty_String;
-
- else
- Name_Len := 0;
- Add_Str_To_Name_Buffer
- (Opt.Target_Value.all);
- The_Variable.Value := Name_Find;
- end if;
-
- when Runtime_Value =>
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- The_Variable.Value :=
- Runtime_Defaults.Get (Name_Find);
- if The_Variable.Value = No_Name then
- The_Variable.Value := Empty_String;
- end if;
-
- end case;
-
- when List =>
- case The_Default is
- when Read_Only_Value =>
- null;
-
- when Empty_Value =>
- The_Variable.Values := Nil_String;
-
- when Dot_Value =>
- The_Variable.Values :=
- Shared.Dot_String_List;
-
- when Object_Dir_Value
- | Runtime_Value
- | Target_Value
- =>
- null;
- end case;
- end case;
- end if;
- end;
- end if;
-
- case Kind is
- when Undefined =>
-
- -- Should never happen
-
- pragma Assert (False, "undefined expression kind");
- null;
-
- when Single =>
- case The_Variable.Kind is
- when Undefined =>
- null;
-
- when Single =>
- Add (Result.Value, The_Variable.Value);
-
- when List =>
-
- -- Should never happen
-
- pragma Assert
- (False,
- "list cannot appear in single " &
- "string expression");
- null;
- end case;
-
- when List =>
- case The_Variable.Kind is
- when Undefined =>
- null;
-
- when Single =>
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- if Last = Nil_String then
-
- -- This can happen in an expression such as
- -- () & Var
-
- Result.Values :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- else
- Shared.String_Elements.Table (Last).Next :=
- String_Element_Table.Last
- (Shared.String_Elements);
- end if;
-
- Last :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- Shared.String_Elements.Table (Last) :=
- (Value => The_Variable.Value,
- Display_Value => No_Name,
- Location => Location_Of
- (The_Current_Term,
- From_Project_Node_Tree),
- Flag => False,
- Next => Nil_String,
- Index => 0);
-
- when List =>
- declare
- The_List : String_List_Id :=
- The_Variable.Values;
-
- begin
- while The_List /= Nil_String loop
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- if Last = Nil_String then
- Result.Values :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- else
- Shared.
- String_Elements.Table (Last).Next :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- end if;
-
- Last :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- Shared.String_Elements.Table
- (Last) :=
- (Value =>
- Shared.String_Elements.Table
- (The_List).Value,
- Display_Value => No_Name,
- Location =>
- Location_Of
- (The_Current_Term,
- From_Project_Node_Tree),
- Flag => False,
- Next => Nil_String,
- Index => 0);
-
- The_List := Shared.String_Elements.Table
- (The_List).Next;
- end loop;
- end;
- end case;
- end case;
- end;
-
- when N_External_Value =>
- Get_Name_String
- (String_Value_Of
- (External_Reference_Of
- (The_Current_Term, From_Project_Node_Tree),
- From_Project_Node_Tree));
-
- declare
- Name : constant Name_Id := Name_Find;
- Default : Name_Id := No_Name;
- Value : Name_Id := No_Name;
- Ext_List : Boolean := False;
- Str_List : String_List_Access := null;
- Def_Var : Variable_Value;
-
- Default_Node : constant Project_Node_Id :=
- External_Default_Of
- (The_Current_Term,
- From_Project_Node_Tree);
-
- begin
- -- If there is a default value for the external reference,
- -- get its value.
-
- if Present (Default_Node) then
- Def_Var := Expression
- (Project => Project,
- Shared => Shared,
- From_Project_Node => From_Project_Node,
- From_Project_Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Pkg => Pkg,
- First_Term =>
- Tree.First_Term
- (Default_Node, From_Project_Node_Tree),
- Kind => Single);
-
- if Def_Var /= Nil_Variable_Value then
- Default := Def_Var.Value;
- end if;
- end if;
-
- Ext_List := Expression_Kind_Of
- (The_Current_Term,
- From_Project_Node_Tree) = List;
-
- if Ext_List then
- Value := Prj.Ext.Value_Of (Env.External, Name, No_Name);
-
- if Value /= No_Name then
- declare
- Sep : constant String :=
- Get_Name_String (Default);
- First : Positive := 1;
- Lst : Natural;
- Done : Boolean := False;
- Nmb : Natural;
-
- begin
- Get_Name_String (Value);
-
- if Name_Len = 0
- or else Sep'Length = 0
- or else Name_Buffer (1 .. Name_Len) = Sep
- then
- Done := True;
- end if;
-
- if not Done and then Name_Len < Sep'Length then
- Str_List :=
- new String_List'
- (1 => new String'
- (Name_Buffer (1 .. Name_Len)));
- Done := True;
- end if;
-
- if not Done then
- if Name_Buffer (1 .. Sep'Length) = Sep then
- First := Sep'Length + 1;
- end if;
-
- if Name_Len - First + 1 >= Sep'Length
- and then
- Name_Buffer (Name_Len - Sep'Length + 1 ..
- Name_Len) = Sep
- then
- Name_Len := Name_Len - Sep'Length;
- end if;
-
- if Name_Len = 0 then
- Str_List :=
- new String_List'(1 => new String'(""));
- Done := True;
- end if;
- end if;
-
- if not Done then
-
- -- Count the number of strings
-
- declare
- Saved : constant Positive := First;
-
- begin
- Nmb := 1;
- loop
- Lst :=
- Index
- (Source =>
- Name_Buffer (First .. Name_Len),
- Pattern => Sep);
- exit when Lst = 0;
- Nmb := Nmb + 1;
- First := Lst + Sep'Length;
- end loop;
-
- First := Saved;
- end;
-
- Str_List := new String_List (1 .. Nmb);
-
- -- Populate the string list
-
- Nmb := 1;
- loop
- Lst :=
- Index
- (Source =>
- Name_Buffer (First .. Name_Len),
- Pattern => Sep);
-
- if Lst = 0 then
- Str_List (Nmb) :=
- new String'
- (Name_Buffer (First .. Name_Len));
- exit;
-
- else
- Str_List (Nmb) :=
- new String'
- (Name_Buffer (First .. Lst - 1));
- Nmb := Nmb + 1;
- First := Lst + Sep'Length;
- end if;
- end loop;
- end if;
- end;
- end if;
-
- else
- -- Get the value
-
- Value := Prj.Ext.Value_Of (Env.External, Name, Default);
-
- if Value = No_Name then
- if not Quiet_Output then
- Error_Msg
- (Env.Flags, "?undefined external reference",
- Location_Of
- (The_Current_Term, From_Project_Node_Tree),
- Project);
- end if;
-
- Value := Empty_String;
- end if;
- end if;
-
- case Kind is
- when Undefined =>
- null;
-
- when Single =>
- if Ext_List then
- null; -- error
-
- else
- Add (Result.Value, Value);
- end if;
-
- when List =>
- if not Ext_List or else Str_List /= null then
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
-
- if Last = Nil_String then
- Result.Values :=
- String_Element_Table.Last
- (Shared.String_Elements);
-
- else
- Shared.String_Elements.Table (Last).Next
- := String_Element_Table.Last
- (Shared.String_Elements);
- end if;
-
- Last := String_Element_Table.Last
- (Shared.String_Elements);
-
- if Ext_List then
- for Ind in Str_List'Range loop
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Str_List (Ind).all);
- Value := Name_Find;
- Shared.String_Elements.Table (Last) :=
- (Value => Value,
- Display_Value => No_Name,
- Location =>
- Location_Of
- (The_Current_Term,
- From_Project_Node_Tree),
- Flag => False,
- Next => Nil_String,
- Index => 0);
-
- if Ind /= Str_List'Last then
- String_Element_Table.Increment_Last
- (Shared.String_Elements);
- Shared.String_Elements.Table (Last).Next :=
- String_Element_Table.Last
- (Shared.String_Elements);
- Last := String_Element_Table.Last
- (Shared.String_Elements);
- end if;
- end loop;
-
- else
- Shared.String_Elements.Table (Last) :=
- (Value => Value,
- Display_Value => No_Name,
- Location =>
- Location_Of
- (The_Current_Term,
- From_Project_Node_Tree),
- Flag => False,
- Next => Nil_String,
- Index => 0);
- end if;
- end if;
- end case;
- end;
-
- when others =>
-
- -- Should never happen
-
- pragma Assert
- (False,
- "illegal node kind in an expression");
- raise Program_Error;
- end case;
- end if;
-
- The_Term := Next_Term (The_Term, From_Project_Node_Tree);
- end loop;
-
- return Result;
- end Expression;
-
- ---------------------------------------
- -- Imported_Or_Extended_Project_From --
- ---------------------------------------
-
- function Imported_Or_Extended_Project_From
- (Project : Project_Id;
- With_Name : Name_Id;
- No_Extending : Boolean := False) return Project_Id
- is
- List : Project_List;
- Result : Project_Id;
- Temp_Result : Project_Id;
-
- begin
- -- First check if it is the name of an extended project
-
- Result := Project.Extends;
- while Result /= No_Project loop
- if Result.Name = With_Name then
- return Result;
- else
- Result := Result.Extends;
- end if;
- end loop;
-
- -- Then check the name of each imported project
-
- Temp_Result := No_Project;
- List := Project.Imported_Projects;
- while List /= null loop
- Result := List.Project;
-
- -- If the project is directly imported, then returns its ID
-
- if Result.Name = With_Name then
- return Result;
- end if;
-
- -- If a project extending the project is imported, then keep this
- -- extending project as a possibility. It will be the returned ID
- -- if the project is not imported directly.
-
- declare
- Proj : Project_Id;
-
- begin
- Proj := Result.Extends;
- while Proj /= No_Project loop
- if Proj.Name = With_Name then
- if No_Extending then
- Temp_Result := Proj;
- else
- Temp_Result := Result;
- end if;
-
- exit;
- end if;
-
- Proj := Proj.Extends;
- end loop;
- end;
-
- List := List.Next;
- end loop;
-
- pragma Assert (Temp_Result /= No_Project, "project not found");
- return Temp_Result;
- end Imported_Or_Extended_Project_From;
-
- ------------------
- -- Package_From --
- ------------------
-
- function Package_From
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access;
- With_Name : Name_Id) return Package_Id
- is
- Result : Package_Id := Project.Decl.Packages;
-
- begin
- -- Check the name of each existing package of Project
-
- while Result /= No_Package
- and then Shared.Packages.Table (Result).Name /= With_Name
- loop
- Result := Shared.Packages.Table (Result).Next;
- end loop;
-
- if Result = No_Package then
-
- -- Should never happen
-
- Write_Line
- ("package """ & Get_Name_String (With_Name) & """ not found");
- raise Program_Error;
-
- else
- return Result;
- end if;
- end Package_From;
-
- -------------
- -- Process --
- -------------
-
- procedure Process
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Packages_To_Check : String_List_Access;
- Success : out Boolean;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Reset_Tree : Boolean := True;
- On_New_Tree_Loaded : Tree_Loaded_Callback := null)
- is
- begin
- Process_Project_Tree_Phase_1
- (In_Tree => In_Tree,
- Project => Project,
- Success => Success,
- From_Project_Node => From_Project_Node,
- From_Project_Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Packages_To_Check => Packages_To_Check,
- Reset_Tree => Reset_Tree,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
-
- if Project_Qualifier_Of
- (From_Project_Node, 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,
- Env => Env);
- end if;
- end Process;
-
- -------------------------------
- -- Process_Declarative_Items --
- -------------------------------
-
- 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;
- Child_Env : in out Prj.Tree.Environment)
- is
- Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
-
- procedure Check_Or_Set_Typed_Variable
- (Value : in out Variable_Value;
- Declaration : Project_Node_Id);
- -- Check whether Value is valid for this typed variable declaration. If
- -- it is an error, the behavior depends on the flags: either an error 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 : 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 --
- ---------------------------------
-
- procedure Check_Or_Set_Typed_Variable
- (Value : in out Variable_Value;
- Declaration : Project_Node_Id)
- is
- Loc : constant Source_Ptr := Location_Of (Declaration, Node_Tree);
-
- Reset_Value : Boolean := False;
- Current_String : Project_Node_Id;
-
- begin
- -- Report an error for an empty string
-
- if Value.Value = Empty_String then
- Error_Msg_Name_1 := Name_Of (Declaration, Node_Tree);
-
- case Env.Flags.Allow_Invalid_External is
- when Error =>
- Error_Msg
- (Env.Flags, "no value defined for %%", Loc, Project);
- when Warning =>
- Reset_Value := True;
- Error_Msg
- (Env.Flags, "?no value defined for %%", Loc, Project);
- when Silent =>
- Reset_Value := True;
- end case;
-
- else
- -- 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);
-
- while Present (Current_String)
- and then
- String_Value_Of (Current_String, Node_Tree) /= Value.Value
- loop
- Current_String :=
- 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, Node_Tree);
-
- case Env.Flags.Allow_Invalid_External is
- when Error =>
- Error_Msg
- (Env.Flags, "value %% is illegal for typed string %%",
- Loc, Project);
-
- when Warning =>
- Error_Msg
- (Env.Flags, "?value %% is illegal for typed string %%",
- Loc, Project);
- Reset_Value := True;
-
- when Silent =>
- Reset_Value := True;
- end case;
- end if;
- end if;
-
- if Reset_Value then
- Current_String :=
- First_Literal_String
- (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;
-
- ---------------------------------
- -- Process_Package_Declaration --
- ---------------------------------
-
- procedure Process_Package_Declaration
- (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 (Shared.Packages);
-
- declare
- New_Pkg : constant Package_Id :=
- Package_Table.Last (Shared.Packages);
- The_New_Package : Package_Element;
-
- 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, Node_Tree);
-
- -- Insert the new package in the appropriate list
-
- if Pkg /= No_Package then
- The_New_Package.Next :=
- Shared.Packages.Table (Pkg).Decl.Packages;
- Shared.Packages.Table (Pkg).Decl.Packages := New_Pkg;
-
- else
- The_New_Package.Next := Project.Decl.Packages;
- Project.Decl.Packages := New_Pkg;
- end if;
-
- Shared.Packages.Table (New_Pkg) := The_New_Package;
-
- if Present (Project_Of_Renamed_Package) then
-
- -- Renamed or extending package
-
- declare
- Project_Name : constant Name_Id :=
- Name_Of (Project_Of_Renamed_Package,
- Node_Tree);
-
- Renamed_Project : constant Project_Id :=
- Imported_Or_Extended_Project_From
- (Project, Project_Name);
-
- Renamed_Package : constant Package_Id :=
- Package_From
- (Renamed_Project, Shared,
- 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.
-
- Copy_Package_Declarations
- (From => Shared.Packages.Table
- (Renamed_Package).Decl,
- To => Shared.Packages.Table (New_Pkg).Decl,
- New_Loc => Location_Of (Current_Item, Node_Tree),
- Restricted => False,
- Shared => Shared);
- end;
-
- else
- -- Set the default values of the attributes
-
- Add_Attributes
- (Project,
- Project.Name,
- Name_Id (Project.Directory.Display_Name),
- Shared,
- Shared.Packages.Table (New_Pkg).Decl,
- First_Attribute_Of
- (Package_Id_Of (Current_Item, Node_Tree)),
- 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
- (Project => Project,
- In_Tree => In_Tree,
- From_Project_Node => From_Project_Node,
- Node_Tree => Node_Tree,
- Env => Env,
- Pkg => New_Pkg,
- Item =>
- First_Declarative_Item_Of (Current_Item, Node_Tree),
- Child_Env => Child_Env);
- end;
- end if;
- end Process_Package_Declaration;
-
- -------------------------------
- -- Process_Associative_Array --
- -------------------------------
-
- procedure Process_Associative_Array
- (Current_Item : Project_Node_Id)
- is
- Current_Item_Name : constant Name_Id :=
- Name_Of (Current_Item, Node_Tree);
- -- The name of the attribute
-
- Current_Location : constant Source_Ptr :=
- Location_Of (Current_Item, Node_Tree);
-
- New_Array : Array_Id;
- -- The new associative array created
-
- Orig_Array : Array_Id;
- -- The associative array value
-
- Orig_Project_Name : Name_Id := No_Name;
- -- The name of the project where the associative array
- -- value is.
-
- Orig_Project : Project_Id := No_Project;
- -- The id of the project where the associative array
- -- value is.
-
- Orig_Package_Name : Name_Id := No_Name;
- -- 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 located.
-
- New_Element : Array_Element_Id := No_Array_Element;
- -- Id of a new array element created
-
- Prev_Element : Array_Element_Id := No_Array_Element;
- -- Last new element id created
-
- Orig_Element : Array_Element_Id := No_Array_Element;
- -- 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.
-
- Prj : Project_List;
-
- begin
- -- First find if the associative array attribute already has elements
- -- declared.
-
- if Pkg /= No_Package then
- New_Array := Shared.Packages.Table (Pkg).Decl.Arrays;
- else
- New_Array := Project.Decl.Arrays;
- end if;
-
- while New_Array /= No_Array
- and then Shared.Arrays.Table (New_Array).Name /= Current_Item_Name
- loop
- New_Array := Shared.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 New_Array = No_Array then
- Array_Table.Increment_Last (Shared.Arrays);
- New_Array := Array_Table.Last (Shared.Arrays);
-
- if Pkg /= No_Package then
- Shared.Arrays.Table (New_Array) :=
- (Name => Current_Item_Name,
- Location => Current_Location,
- Value => No_Array_Element,
- Next => Shared.Packages.Table (Pkg).Decl.Arrays);
-
- Shared.Packages.Table (Pkg).Decl.Arrays := New_Array;
-
- else
- Shared.Arrays.Table (New_Array) :=
- (Name => Current_Item_Name,
- Location => Current_Location,
- Value => No_Array_Element,
- Next => Project.Decl.Arrays);
-
- Project.Decl.Arrays := New_Array;
- end if;
- end if;
-
- -- Find the project where the value is declared
-
- Orig_Project_Name :=
- Name_Of
- (Associative_Project_Of (Current_Item, Node_Tree), Node_Tree);
-
- Prj := In_Tree.Projects;
- while Prj /= null loop
- if Prj.Project.Name = Orig_Project_Name then
- Orig_Project := Prj.Project;
- exit;
- end if;
- Prj := Prj.Next;
- end loop;
-
- pragma Assert (Orig_Project /= No_Project,
- "original project not found");
-
- if No (Associative_Package_Of (Current_Item, Node_Tree)) then
- Orig_Array := Orig_Project.Decl.Arrays;
-
- else
- -- If in a package, find the package where the value is declared
-
- Orig_Package_Name :=
- Name_Of
- (Associative_Package_Of (Current_Item, Node_Tree), Node_Tree);
-
- Orig_Package := Orig_Project.Decl.Packages;
- pragma Assert (Orig_Package /= No_Package,
- "original package not found");
-
- while Shared.Packages.Table
- (Orig_Package).Name /= Orig_Package_Name
- loop
- Orig_Package := Shared.Packages.Table (Orig_Package).Next;
- pragma Assert (Orig_Package /= No_Package,
- "original package not found");
- end loop;
-
- Orig_Array := Shared.Packages.Table (Orig_Package).Decl.Arrays;
- end if;
-
- -- Now look for the array
-
- while Orig_Array /= No_Array
- and then Shared.Arrays.Table (Orig_Array).Name /= Current_Item_Name
- loop
- Orig_Array := Shared.Arrays.Table (Orig_Array).Next;
- end loop;
-
- if Orig_Array = No_Array then
- Error_Msg
- (Env.Flags,
- "associative array value not found",
- Location_Of (Current_Item, Node_Tree),
- Project);
-
- else
- Orig_Element := Shared.Arrays.Table (Orig_Array).Value;
-
- -- Copy each array element
-
- while Orig_Element /= No_Array_Element loop
-
- -- Case of first element
-
- if Prev_Element = No_Array_Element then
-
- -- And there is no array element declared yet, create a new
- -- first array element.
-
- if Shared.Arrays.Table (New_Array).Value =
- No_Array_Element
- then
- Array_Element_Table.Increment_Last
- (Shared.Array_Elements);
- New_Element := Array_Element_Table.Last
- (Shared.Array_Elements);
- Shared.Arrays.Table (New_Array).Value := New_Element;
- Next_Element := No_Array_Element;
-
- -- Otherwise, the new element is the first
-
- else
- New_Element := Shared.Arrays.Table (New_Array).Value;
- Next_Element :=
- Shared.Array_Elements.Table (New_Element).Next;
- end if;
-
- -- Otherwise, reuse an existing element, or create
- -- one if necessary.
-
- else
- Next_Element :=
- Shared.Array_Elements.Table (Prev_Element).Next;
-
- if Next_Element = No_Array_Element then
- Array_Element_Table.Increment_Last
- (Shared.Array_Elements);
- New_Element := Array_Element_Table.Last
- (Shared.Array_Elements);
- Shared.Array_Elements.Table (Prev_Element).Next :=
- New_Element;
-
- else
- New_Element := Next_Element;
- Next_Element :=
- Shared.Array_Elements.Table (New_Element).Next;
- end if;
- end if;
-
- -- Copy the value of the element
-
- Shared.Array_Elements.Table (New_Element) :=
- Shared.Array_Elements.Table (Orig_Element);
- Shared.Array_Elements.Table (New_Element).Value.Project
- := Project;
-
- -- Adjust the Next link
-
- Shared.Array_Elements.Table (New_Element).Next := Next_Element;
-
- -- Adjust the previous id for the next element
-
- Prev_Element := New_Element;
-
- -- Go to the next element in the original array
-
- Orig_Element := Shared.Array_Elements.Table (Orig_Element).Next;
- end loop;
-
- -- Make sure that the array ends here, in case there previously a
- -- greater number of elements.
-
- Shared.Array_Elements.Table (New_Element).Next := No_Array_Element;
- end if;
- end Process_Associative_Array;
-
- ----------------------------------------------
- -- Process_Expression_For_Associative_Array --
- ----------------------------------------------
-
- procedure Process_Expression_For_Associative_Array
- (Current : Project_Node_Id;
- New_Value : Variable_Value)
- is
- Name : constant Name_Id := Name_Of (Current, Node_Tree);
- Current_Location : constant Source_Ptr :=
- Location_Of (Current, Node_Tree);
-
- Index_Name : Name_Id :=
- Associative_Array_Index_Of (Current, Node_Tree);
-
- Source_Index : constant Int :=
- Source_Index_Of (Current, Node_Tree);
-
- The_Array : Array_Id;
- Elem : Array_Element_Id := No_Array_Element;
-
- begin
- if Index_Name /= All_Other_Names then
- Index_Name := Get_Attribute_Index (Node_Tree, Current, Index_Name);
- end if;
-
- -- Look for the array in the appropriate list
-
- if Pkg /= No_Package then
- The_Array := Shared.Packages.Table (Pkg).Decl.Arrays;
- else
- The_Array := Project.Decl.Arrays;
- end if;
-
- while The_Array /= No_Array
- and then Shared.Arrays.Table (The_Array).Name /= Name
- loop
- The_Array := Shared.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 = No_Array then
- Array_Table.Increment_Last (Shared.Arrays);
- The_Array := Array_Table.Last (Shared.Arrays);
-
- if Pkg /= No_Package then
- Shared.Arrays.Table (The_Array) :=
- (Name => Name,
- Location => Current_Location,
- Value => No_Array_Element,
- Next => Shared.Packages.Table (Pkg).Decl.Arrays);
-
- Shared.Packages.Table (Pkg).Decl.Arrays := The_Array;
-
- else
- Shared.Arrays.Table (The_Array) :=
- (Name => Name,
- Location => Current_Location,
- Value => No_Array_Element,
- Next => Project.Decl.Arrays);
-
- Project.Decl.Arrays := The_Array;
- end if;
-
- else
- Elem := Shared.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.
-
- while Elem /= No_Array_Element
- and then
- (Shared.Array_Elements.Table (Elem).Index /= Index_Name
- or else
- Shared.Array_Elements.Table (Elem).Src_Index /= Source_Index)
- loop
- Elem := Shared.Array_Elements.Table (Elem).Next;
- end loop;
-
- -- If no such element were found, create a new one
- -- and insert it in the element list, with the
- -- proper value.
-
- if Elem = No_Array_Element then
- Array_Element_Table.Increment_Last (Shared.Array_Elements);
- Elem := Array_Element_Table.Last (Shared.Array_Elements);
-
- Shared.Array_Elements.Table
- (Elem) :=
- (Index => Index_Name,
- Restricted => False,
- Src_Index => Source_Index,
- Index_Case_Sensitive =>
- not Case_Insensitive (Current, Node_Tree),
- Value => New_Value,
- Next => Shared.Arrays.Table (The_Array).Value);
-
- Shared.Arrays.Table (The_Array).Value := Elem;
-
- else
- -- An element with the same index already exists, just replace its
- -- value with the new one.
-
- Shared.Array_Elements.Table (Elem).Value := New_Value;
- end if;
-
- if Name = Snames.Name_External then
- if In_Tree.Is_Root_Tree then
- Add (Child_Env.External,
- External_Name => Get_Name_String (Index_Name),
- Value => Get_Name_String (New_Value.Value),
- Source => From_External_Attribute);
- Add (Env.External,
- External_Name => Get_Name_String (Index_Name),
- Value => Get_Name_String (New_Value.Value),
- Source => From_External_Attribute,
- Silent => True);
- else
- if Current_Verbosity = High then
- Debug_Output
- ("'for External' has no effect except in root aggregate ("
- & Get_Name_String (Index_Name) & ")", New_Value.Value);
- end if;
- end if;
- end if;
- end Process_Expression_For_Associative_Array;
-
- --------------------------------------
- -- Process_Expression_Variable_Decl --
- --------------------------------------
-
- procedure Process_Expression_Variable_Decl
- (Current_Item : Project_Node_Id;
- New_Value : Variable_Value)
- is
- Name : constant Name_Id := Name_Of (Current_Item, Node_Tree);
-
- Is_Attribute : constant Boolean :=
- Kind_Of (Current_Item, Node_Tree) =
- N_Attribute_Declaration;
-
- Var : Variable_Id := No_Variable;
-
- begin
- -- First, find the list where to find the variable or attribute
-
- if Is_Attribute then
- if Pkg /= No_Package then
- Var := Shared.Packages.Table (Pkg).Decl.Attributes;
- else
- Var := Project.Decl.Attributes;
- end if;
-
- else
- if Pkg /= No_Package then
- Var := Shared.Packages.Table (Pkg).Decl.Variables;
- else
- Var := Project.Decl.Variables;
- end if;
- end if;
-
- -- Loop through the list, to find if it has already been declared
-
- while Var /= No_Variable
- and then Shared.Variable_Elements.Table (Var).Name /= Name
- loop
- Var := Shared.Variable_Elements.Table (Var).Next;
- end loop;
-
- -- 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.
-
- pragma Assert
- (not Is_Attribute,
- "illegal attribute declaration for " & Get_Name_String (Name));
-
- Variable_Element_Table.Increment_Last (Shared.Variable_Elements);
- Var := Variable_Element_Table.Last (Shared.Variable_Elements);
-
- -- Put the new variable in the appropriate list
-
- if Pkg /= No_Package then
- Shared.Variable_Elements.Table (Var) :=
- (Next => Shared.Packages.Table (Pkg).Decl.Variables,
- Name => Name,
- Value => New_Value);
- Shared.Packages.Table (Pkg).Decl.Variables := Var;
-
- else
- Shared.Variable_Elements.Table (Var) :=
- (Next => Project.Decl.Variables,
- Name => Name,
- Value => New_Value);
- Project.Decl.Variables := Var;
- end if;
-
- -- If the variable/attribute has already been declared, just
- -- change the value.
-
- else
- Shared.Variable_Elements.Table (Var).Value := New_Value;
- end if;
-
- if Is_Attribute and then Name = Snames.Name_Project_Path then
- if In_Tree.Is_Root_Tree then
- declare
- Val : String_List_Id := New_Value.Values;
- List : Name_Ids.Vector;
- begin
- -- Get all values
-
- while Val /= Nil_String loop
- List.Prepend
- (Shared.String_Elements.Table (Val).Value);
- Val := Shared.String_Elements.Table (Val).Next;
- end loop;
-
- -- Prepend them in the order found in the attribute
-
- for K in Positive range 1 .. Positive (List.Length) loop
- Prj.Env.Add_Directories
- (Child_Env.Project_Path,
- Normalize_Pathname
- (Name => Get_Name_String
- (List.Element (K)),
- Directory => Get_Name_String
- (Project.Directory.Display_Name)),
- Prepend => True);
- end loop;
- end;
-
- else
- if Current_Verbosity = High then
- Debug_Output
- ("'for Project_Path' has no effect except in"
- & " root aggregate");
- end if;
- end if;
- end if;
- end Process_Expression_Variable_Decl;
-
- ------------------------
- -- Process_Expression --
- ------------------------
-
- procedure Process_Expression (Current : Project_Node_Id) is
- New_Value : Variable_Value :=
- Expression
- (Project => Project,
- Shared => Shared,
- 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
- 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, Node_Tree)) then
- Name :=
- Name_Of
- (Project_Node_Of (Variable_Node, Node_Tree), Node_Tree);
- The_Project :=
- Imported_Or_Extended_Project_From
- (Project, Name, No_Extending => True);
- The_Package := No_Package;
- end if;
-
- -- If a package was specified for the case variable, get its id
-
- if Present (Package_Node_Of (Variable_Node, Node_Tree)) then
- Name :=
- Name_Of
- (Package_Node_Of (Variable_Node, Node_Tree), Node_Tree);
- The_Package := Package_From (The_Project, Shared, Name);
- end if;
-
- Name := Name_Of (Variable_Node, Node_Tree);
-
- -- First, look for the case variable into the package, if any
-
- if The_Package /= No_Package then
- Name := Name_Of (Variable_Node, Node_Tree);
-
- Var_Id := Shared.Packages.Table (The_Package).Decl.Variables;
- while Var_Id /= No_Variable
- and then Shared.Variable_Elements.Table (Var_Id).Name /= Name
- loop
- Var_Id := Shared.Variable_Elements.Table (Var_Id).Next;
- end loop;
- end if;
-
- -- 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))
- then
- Var_Id := The_Project.Decl.Variables;
- while Var_Id /= No_Variable
- and then Shared.Variable_Elements.Table (Var_Id).Name /= Name
- loop
- Var_Id := Shared.Variable_Elements.Table (Var_Id).Next;
- end loop;
- end if;
-
- if Var_Id = No_Variable then
- if Node_Tree.Incomplete_With then
- return;
-
- -- Should never happen, because this has already been checked
- -- during parsing.
-
- else
- Write_Line
- ("variable """ & Get_Name_String (Name) & """ not found");
- raise Program_Error;
- end if;
- end if;
-
- -- Get the case variable
-
- The_Variable := Shared.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) &
- """ is not a single string variable");
- raise Program_Error;
- end if;
-
- -- Get the case variable value
-
- Case_Value := The_Variable.Value;
- end;
-
- -- Now look into all the case items of the case construction
-
- 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, 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, Node_Tree);
- exit Case_Item_Loop;
- end if;
-
- -- Look into all the alternative of this case item
-
- Choice_Loop :
- while Present (Choice_String) loop
- if Case_Value = String_Value_Of (Choice_String, Node_Tree) then
- Decl_Item :=
- First_Declarative_Item_Of (Case_Item, Node_Tree);
- exit Case_Item_Loop;
- end if;
-
- Choice_String := Next_Literal_String (Choice_String, Node_Tree);
- end loop Choice_Loop;
-
- Case_Item := Next_Case_Item (Case_Item, Node_Tree);
- end loop Case_Item_Loop;
-
- -- If there is an alternative, then we process it
-
- if Present (Decl_Item) then
- Process_Declarative_Items
- (Project => Project,
- In_Tree => In_Tree,
- From_Project_Node => From_Project_Node,
- Node_Tree => Node_Tree,
- Env => Env,
- Pkg => Pkg,
- Item => Decl_Item,
- Child_Env => Child_Env);
- end if;
- end Process_Case_Construction;
-
- -- Local variables
-
- 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);
-
- -- Nothing to process for string type declaration
-
- when N_String_Type_Declaration =>
- null;
-
- when N_Attribute_Declaration
- | N_Typed_Variable_Declaration
- | N_Variable_Declaration
- =>
- Process_Attribute_Declaration (Current);
-
- when N_Case_Construction =>
- Process_Case_Construction (Current);
-
- when others =>
- Write_Line ("Illegal declarative item: " & Kind'Img);
- raise Program_Error;
- end case;
- end loop;
- end Process_Declarative_Items;
-
- ----------------------------------
- -- Process_Project_Tree_Phase_1 --
- ----------------------------------
-
- procedure Process_Project_Tree_Phase_1
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Packages_To_Check : String_List_Access;
- Success : out Boolean;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Reset_Tree : Boolean := True;
- On_New_Tree_Loaded : Tree_Loaded_Callback := null)
- is
- begin
- if Reset_Tree then
-
- -- Make sure there are no projects in the data structure
-
- Free_List (In_Tree.Projects, Free_Project => True);
- end if;
-
- Processed_Projects.Reset;
-
- -- 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,
- Packages_To_Check => Packages_To_Check,
- From_Project_Node => From_Project_Node,
- From_Project_Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Extended_By => No_Project,
- From_Encapsulated_Lib => False,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
-
- Success :=
- 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;
-
- ----------------------------------
- -- Process_Project_Tree_Phase_2 --
- ----------------------------------
-
- 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;
- Env : Environment)
- is
- Obj_Dir : Path_Name_Type;
- Extending : Project_Id;
- Extending2 : Project_Id;
- Prj : Project_List;
-
- -- Start of processing for Process_Project_Tree_Phase_2
-
- begin
- Success := True;
-
- Debug_Increase_Indent ("Process tree, phase 2", Project.Name);
-
- if Project /= No_Project then
- Check (In_Tree, Project, From_Project_Node_Tree, Env.Flags);
- end if;
-
- -- If main project is an extending all project, set object directory of
- -- all virtual extending projects to object directory of main project.
-
- if Project /= No_Project
- and then Is_Extending_All (From_Project_Node, From_Project_Node_Tree)
- then
- 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;
- end if;
-
- -- Check that no extending project shares its object directory with
- -- the project(s) it extends.
-
- if Project /= No_Project then
- Prj := In_Tree.Projects;
- while Prj /= null loop
- Extending := Prj.Project.Extended_By;
-
- if Extending /= No_Project then
- Obj_Dir := Prj.Project.Object_Directory.Name;
-
- -- Check that a project being extended does not share its
- -- object directory with any project that extends it, directly
- -- or indirectly, including a virtual extending project.
-
- -- Start with the project directly extending it
-
- Extending2 := Extending;
- while Extending2 /= No_Project loop
- if Has_Ada_Sources (Extending2)
- and then Extending2.Object_Directory.Name = Obj_Dir
- then
- if Extending2.Virtual then
- Error_Msg_Name_1 := Prj.Project.Display_Name;
- Error_Msg
- (Env.Flags,
- "project %% cannot be extended by a virtual" &
- " project with the same object directory",
- Prj.Project.Location, Project);
-
- else
- Error_Msg_Name_1 := Extending2.Display_Name;
- Error_Msg_Name_2 := Prj.Project.Display_Name;
- Error_Msg
- (Env.Flags,
- "project %% cannot extend project %%",
- Extending2.Location, Project);
- Error_Msg
- (Env.Flags,
- "\they share the same object directory",
- Extending2.Location, Project);
- end if;
- end if;
-
- -- Continue with the next extending project, if any
-
- Extending2 := Extending2.Extended_By;
- end loop;
- end if;
-
- Prj := Prj.Next;
- end loop;
- end if;
-
- Debug_Decrease_Indent ("Done Process tree, phase 2");
-
- Success := Total_Errors_Detected = 0
- and then
- (Warning_Mode /= Treat_As_Error or else Warnings_Detected = 0);
- end Process_Project_Tree_Phase_2;
-
- -----------------------
- -- Recursive_Process --
- -----------------------
-
- procedure Recursive_Process
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Packages_To_Check : String_List_Access;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Extended_By : Project_Id;
- From_Encapsulated_Lib : Boolean;
- On_New_Tree_Loaded : Tree_Loaded_Callback := null)
- is
- Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
-
- Child_Env : Prj.Tree.Environment;
- -- Only used for the root aggregate project (if any). This is left
- -- uninitialized otherwise.
-
- procedure Process_Imported_Projects
- (Imported : in out Project_List;
- Limited_With : Boolean);
- -- Process imported projects. If Limited_With is True, then only
- -- projects processed through a "limited with" are processed, otherwise
- -- 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 --
- -------------------------------
-
- procedure Process_Imported_Projects
- (Imported : in out Project_List;
- Limited_With : Boolean)
- is
- With_Clause : Project_Node_Id;
- New_Project : Project_Id;
- Proj_Node : Project_Node_Id;
-
- begin
- 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
- (With_Clause, From_Project_Node_Tree);
- New_Project := No_Project;
-
- if (Limited_With and then No (Proj_Node))
- or else (not Limited_With and then Present (Proj_Node))
- then
- Recursive_Process
- (In_Tree => In_Tree,
- Project => New_Project,
- Packages_To_Check => Packages_To_Check,
- From_Project_Node =>
- Project_Node_Of (With_Clause, From_Project_Node_Tree),
- From_Project_Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Extended_By => No_Project,
- From_Encapsulated_Lib => From_Encapsulated_Lib,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
-
- if Imported = null then
- Project.Imported_Projects := new Project_List_Element'
- (Project => New_Project,
- From_Encapsulated_Lib => False,
- Next => null);
- Imported := Project.Imported_Projects;
- else
- Imported.Next := new Project_List_Element'
- (Project => New_Project,
- From_Encapsulated_Lib => False,
- Next => null);
- Imported := Imported.Next;
- end if;
- end if;
-
- With_Clause :=
- Next_With_Clause_Of (With_Clause, From_Project_Node_Tree);
- end loop;
- end Process_Imported_Projects;
-
- ---------------------------------
- -- Process_Aggregated_Projects --
- ---------------------------------
-
- procedure Process_Aggregated_Projects is
- List : Aggregated_Project_List;
- Loaded_Project : Prj.Tree.Project_Node_Id;
- Success : Boolean := True;
- Tree : Project_Tree_Ref;
- Node_Tree : Project_Node_Tree_Ref;
-
- begin
- if Project.Qualifier not in Aggregate_Project 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 => Env.Flags);
-
- List := Project.Aggregated_Projects;
- while Success and then List /= null loop
- Node_Tree := new Project_Node_Tree_Data;
- Initialize (Node_Tree);
-
- Prj.Part.Parse
- (In_Tree => Node_Tree,
- Project => Loaded_Project,
- Packages_To_Check => Packages_To_Check,
- 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,
- Env => Child_Env);
-
- Success := not Prj.Tree.No (Loaded_Project);
-
- if Success then
- if Node_Tree.Incomplete_With then
- From_Project_Node_Tree.Incomplete_With := True;
- end if;
-
- List.Tree := new Project_Tree_Data (Is_Root_Tree => False);
- Prj.Initialize (List.Tree);
- List.Tree.Shared := In_Tree.Shared;
-
- -- In aggregate library, aggregated projects are parsed using
- -- the aggregate library tree.
-
- if Project.Qualifier = Aggregate_Library then
- Tree := In_Tree;
- else
- Tree := List.Tree;
- end if;
-
- -- We can only do the phase 1 of the processing, since we do
- -- not have access to the configuration file yet (this is
- -- called when doing phase 1 of the processing for the root
- -- aggregate project).
-
- if In_Tree.Is_Root_Tree then
- Process_Project_Tree_Phase_1
- (In_Tree => Tree,
- Project => List.Project,
- Packages_To_Check => Packages_To_Check,
- Success => Success,
- From_Project_Node => Loaded_Project,
- From_Project_Node_Tree => Node_Tree,
- Env => Child_Env,
- Reset_Tree => False,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
- else
- -- use the same environment as the rest of the aggregated
- -- projects, ie the one that was setup by the root aggregate
- Process_Project_Tree_Phase_1
- (In_Tree => Tree,
- Project => List.Project,
- Packages_To_Check => Packages_To_Check,
- Success => Success,
- From_Project_Node => Loaded_Project,
- From_Project_Node_Tree => Node_Tree,
- Env => Env,
- Reset_Tree => False,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
- end if;
-
- if On_New_Tree_Loaded /= null then
- On_New_Tree_Loaded
- (Node_Tree, Tree, Loaded_Project, List.Project);
- end if;
-
- 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 := Shared.Packages.Table (Extended_Pkg);
-
- Current_Pkg := First;
- while Current_Pkg /= No_Package
- and then
- Shared.Packages.Table (Current_Pkg).Name /= Element.Name
- loop
- Current_Pkg := Shared.Packages.Table (Current_Pkg).Next;
- end loop;
-
- if Current_Pkg = No_Package then
- Package_Table.Increment_Last (Shared.Packages);
- Current_Pkg := Package_Table.Last (Shared.Packages);
- Shared.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 => Shared.Packages.Table (Current_Pkg).Decl,
- New_Loc => No_Location,
- Restricted => True,
- Shared => Shared);
- 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 := Shared.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 := Shared.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
- (Shared.Variable_Elements);
- Attribute1 := Variable_Element_Table.Last
- (Shared.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;
- Shared.Variable_Elements.Table (Attribute1) := Attr_Value1;
- end if;
- end if;
- end Process_Extended_Project;
-
- -- Start of processing for Recursive_Process
-
- begin
- if No (From_Project_Node) then
- Project := No_Project;
-
- else
- declare
- Imported, Mark : Project_List;
- Declaration_Node : Project_Node_Id := Empty_Node;
-
- Name : constant Name_Id :=
- Name_Of (From_Project_Node, From_Project_Node_Tree);
-
- Display_Name : constant Name_Id :=
- Display_Name_Of
- (From_Project_Node, From_Project_Node_Tree);
-
- begin
- Project := Processed_Projects.Get (Name);
-
- if Project /= No_Project then
-
- -- Make sure that, when a project is extended, the project id
- -- of the project extending it is recorded in its data, even
- -- when it has already been processed as an imported project.
- -- This is for virtually extended projects.
-
- if Extended_By /= No_Project then
- Project.Extended_By := Extended_By;
- end if;
-
- return;
- end if;
-
- -- Check if the project is already in the tree
-
- Project := No_Project;
-
- declare
- List : Project_List := In_Tree.Projects;
- Path : constant Path_Name_Type :=
- Path_Name_Of (From_Project_Node,
- From_Project_Node_Tree);
-
- begin
- while List /= null loop
- if List.Project.Path.Display_Name = Path then
- Project := List.Project;
- exit;
- end if;
-
- List := List.Next;
- end loop;
- end;
-
- if Project = No_Project then
- Project :=
- new Project_Data'
- (Empty_Project
- (Project_Qualifier_Of
- (From_Project_Node, From_Project_Node_Tree)));
-
- -- Note that at this point we do not know yet if the project
- -- has been withed from an encapsulated library or not.
-
- In_Tree.Projects :=
- new Project_List_Element'
- (Project => Project,
- From_Encapsulated_Lib => False,
- Next => In_Tree.Projects);
- end if;
-
- -- Keep track of this point
-
- Mark := In_Tree.Projects;
-
- Processed_Projects.Set (Name, Project);
-
- Project.Name := Name;
- Project.Display_Name := Display_Name;
-
- Get_Name_String (Name);
-
- -- If name starts with the virtual prefix, flag the project as
- -- being a virtual extending project.
-
- if Name_Len > Virtual_Prefix'Length
- and then
- Name_Buffer (1 .. Virtual_Prefix'Length) = Virtual_Prefix
- then
- Project.Virtual := True;
- end if;
-
- Project.Path.Display_Name :=
- Path_Name_Of (From_Project_Node, From_Project_Node_Tree);
- Get_Name_String (Project.Path.Display_Name);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Project.Path.Name := Name_Find;
-
- Project.Location :=
- Location_Of (From_Project_Node, From_Project_Node_Tree);
-
- Project.Directory.Display_Name :=
- Directory_Of (From_Project_Node, From_Project_Node_Tree);
- Get_Name_String (Project.Directory.Display_Name);
- Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
- Project.Directory.Name := Name_Find;
-
- Project.Extended_By := Extended_By;
-
- Add_Attributes
- (Project,
- Name,
- Name_Id (Project.Directory.Display_Name),
- In_Tree.Shared,
- Project.Decl,
- Prj.Attr.Attribute_First,
- Project_Level => True);
-
- Process_Imported_Projects (Imported, Limited_With => False);
-
- if Project.Qualifier = Aggregate then
- Initialize_And_Copy (Child_Env, Copy_From => Env);
-
- elsif Project.Qualifier = Aggregate_Library then
-
- -- The child environment is the same as the current one
-
- Child_Env := Env;
-
- else
- -- No need to initialize Child_Env, since it will not be
- -- used anyway by Process_Declarative_Items (only the root
- -- aggregate can modify it, and it is never read anyway).
-
- null;
- end if;
-
- Declaration_Node :=
- Project_Declaration_Of
- (From_Project_Node, From_Project_Node_Tree);
-
- Recursive_Process
- (In_Tree => In_Tree,
- Project => Project.Extends,
- Packages_To_Check => Packages_To_Check,
- From_Project_Node =>
- Extended_Project_Of
- (Declaration_Node, From_Project_Node_Tree),
- From_Project_Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Extended_By => Project,
- From_Encapsulated_Lib => From_Encapsulated_Lib,
- On_New_Tree_Loaded => On_New_Tree_Loaded);
-
- Process_Declarative_Items
- (Project => Project,
- In_Tree => In_Tree,
- From_Project_Node => From_Project_Node,
- Node_Tree => From_Project_Node_Tree,
- Env => Env,
- Pkg => No_Package,
- Item => First_Declarative_Item_Of
- (Declaration_Node, From_Project_Node_Tree),
- Child_Env => Child_Env);
-
- if Project.Extends /= No_Project then
- Process_Extended_Project;
- end if;
-
- Process_Imported_Projects (Imported, Limited_With => True);
-
- if Total_Errors_Detected = 0 then
- Process_Aggregated_Projects;
- end if;
-
- -- At this point (after Process_Declarative_Items) we have the
- -- attribute values set, we can backtrace In_Tree.Project and
- -- set the From_Encapsulated_Library status.
-
- declare
- Lib_Standalone : constant Prj.Variable_Value :=
- Prj.Util.Value_Of
- (Snames.Name_Library_Standalone,
- Project.Decl.Attributes,
- Shared);
- List : Project_List := In_Tree.Projects;
- Is_Encapsulated : Boolean;
-
- begin
- Get_Name_String (Lib_Standalone.Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
-
- Is_Encapsulated := Name_Buffer (1 .. Name_Len) = "encapsulated";
-
- if Is_Encapsulated then
- while List /= null and then List /= Mark loop
- List.From_Encapsulated_Lib := Is_Encapsulated;
- List := List.Next;
- end loop;
- end if;
-
- if Total_Errors_Detected = 0 then
-
- -- For an aggregate library we add the aggregated projects
- -- as imported ones. This is necessary to give visibility
- -- to all sources from the aggregates from the aggregated
- -- library projects.
-
- if Project.Qualifier = Aggregate_Library then
- declare
- L : Aggregated_Project_List;
- begin
- L := Project.Aggregated_Projects;
- while L /= null loop
- Project.Imported_Projects :=
- new Project_List_Element'
- (Project => L.Project,
- From_Encapsulated_Lib => Is_Encapsulated,
- Next =>
- Project.Imported_Projects);
- L := L.Next;
- end loop;
- end;
- end if;
- end if;
- end;
-
- if Project.Qualifier = Aggregate and then In_Tree.Is_Root_Tree then
- Free (Child_Env);
- end if;
- end;
- end if;
- end Recursive_Process;
-
- -----------------------------
- -- Set_Default_Runtime_For --
- -----------------------------
-
- procedure Set_Default_Runtime_For (Language : Name_Id; Value : String) is
- begin
- Name_Len := Value'Length;
- Name_Buffer (1 .. Name_Len) := Value;
- Runtime_Defaults.Set (Language, Name_Find);
- end Set_Default_Runtime_For;
-end Prj.Proc;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . P R O C --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package is used to convert a project file tree (see prj-tree.ads) to
--- project file data structures (see prj.ads), taking into account the
--- environment (external references).
-
-with Prj.Tree; use Prj.Tree;
-
-package Prj.Proc is
-
- type Tree_Loaded_Callback is access procedure
- (Node_Tree : Project_Node_Tree_Ref;
- Tree : Project_Tree_Ref;
- Project_Node : Project_Node_Id;
- Project : Project_Id);
- -- Callback used after the phase 1 of the processing of each aggregated
- -- project to get access to project trees of aggregated projects.
-
- procedure Process_Project_Tree_Phase_1
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Packages_To_Check : String_List_Access;
- Success : out Boolean;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Reset_Tree : Boolean := True;
- On_New_Tree_Loaded : Tree_Loaded_Callback := null);
- -- Process a project tree (ie the direct resulting of parsing a .gpr file)
- -- based on the current external references.
- --
- -- The result of this phase_1 is a partial project tree (Project) where
- -- only a few fields have been initialized (in particular the list of
- -- languages). These are the fields that are necessary to run gprconfig if
- -- needed to automatically generate a configuration file. This first phase
- -- of the processing does not require a configuration file.
- --
- -- When Reset_Tree is True, all the project data are removed from the
- -- project table before processing.
- --
- -- If specified, On_New_Tree_Loaded is called after each aggregated project
- -- has been processed succesfully.
-
- 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;
- Env : Prj.Tree.Environment);
- -- 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
- -- we currently assume that the contents of the configuration file has
- -- been included in Project through Confgpr.Apply_Config_File). The
- -- parameters are the same as for phase_1, with the addition of:
-
- procedure Process
- (In_Tree : Project_Tree_Ref;
- Project : out Project_Id;
- Packages_To_Check : String_List_Access;
- Success : out Boolean;
- From_Project_Node : Project_Node_Id;
- From_Project_Node_Tree : Project_Node_Tree_Ref;
- Env : in out Prj.Tree.Environment;
- Reset_Tree : Boolean := True;
- On_New_Tree_Loaded : Tree_Loaded_Callback := null);
- -- Performs the two phases of the processing
-
- procedure Set_Default_Runtime_For (Language : Name_Id; Value : String);
- -- Set the default value for the runtime of Language. To be used for the
- -- value of 'Runtime(<Language>) when Runtime (<language>) is not declared.
-
-end Prj.Proc;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . S T R T --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Err_Vars; use Err_Vars;
-with Prj.Attr; use Prj.Attr;
-with Prj.Err; use Prj.Err;
-with Snames;
-with Table;
-with Uintp; use Uintp;
-
-package body Prj.Strt is
-
- Buffer : String_Access;
- Buffer_Last : Natural := 0;
-
- type Choice_String is record
- The_String : Name_Id;
- Already_Used : Boolean := False;
- end record;
- -- The string of a case label, and an indication that it has already
- -- been used (to avoid duplicate case labels).
-
- Choices_Initial : constant := 10;
- Choices_Increment : constant := 100;
- -- These should be in alloc.ads
-
- Choice_Node_Low_Bound : constant := 0;
- Choice_Node_High_Bound : constant := 099_999_999;
- -- In practice, infinite
-
- type Choice_Node_Id is
- range Choice_Node_Low_Bound .. Choice_Node_High_Bound;
-
- First_Choice_Node_Id : constant Choice_Node_Id :=
- Choice_Node_Low_Bound;
-
- package Choices is
- new Table.Table
- (Table_Component_Type => Choice_String,
- Table_Index_Type => Choice_Node_Id'Base,
- Table_Low_Bound => First_Choice_Node_Id,
- Table_Initial => Choices_Initial,
- Table_Increment => Choices_Increment,
- Table_Name => "Prj.Strt.Choices");
- -- Used to store the case labels and check that there is no duplicate
-
- package Choice_Lasts is
- new Table.Table
- (Table_Component_Type => Choice_Node_Id,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Strt.Choice_Lasts");
- -- Used to store the indexes of the choices in table Choices, to
- -- distinguish nested case constructions.
-
- Choice_First : Choice_Node_Id := 0;
- -- Index in table Choices of the first case label of the current
- -- case construction. Zero means no current case construction.
-
- type Name_Location is record
- Name : Name_Id := No_Name;
- Location : Source_Ptr := No_Location;
- end record;
- -- Store the identifier and the location of a simple name
-
- package Names is
- new Table.Table
- (Table_Component_Type => Name_Location,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Strt.Names");
- -- Used to accumulate the single names of a name
-
- procedure Add (This_String : Name_Id);
- -- Add a string to the case label list, indicating that it has not
- -- yet been used.
-
- procedure Add_To_Names (NL : Name_Location);
- -- Add one single names to table Names
-
- procedure External_Reference
- (In_Tree : Project_Node_Tree_Ref;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- External_Value : out Project_Node_Id;
- Expr_Kind : in out Variable_Kind;
- Flags : Processing_Flags);
- -- Parse an external reference. Current token is "external"
-
- procedure Attribute_Reference
- (In_Tree : Project_Node_Tree_Ref;
- Reference : out Project_Node_Id;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags);
- -- Parse an attribute reference. Current token is an apostrophe
-
- procedure Terms
- (In_Tree : Project_Node_Tree_Ref;
- Term : out Project_Node_Id;
- Expr_Kind : in out Variable_Kind;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Optional_Index : Boolean;
- Flags : Processing_Flags);
- -- Recursive procedure to parse one term or several terms concatenated
- -- using "&".
-
- ---------
- -- Add --
- ---------
-
- procedure Add (This_String : Name_Id) is
- begin
- Choices.Increment_Last;
- Choices.Table (Choices.Last) :=
- (The_String => This_String,
- Already_Used => False);
- end Add;
-
- ------------------
- -- Add_To_Names --
- ------------------
-
- procedure Add_To_Names (NL : Name_Location) is
- begin
- Names.Increment_Last;
- Names.Table (Names.Last) := NL;
- end Add_To_Names;
-
- -------------------------
- -- Attribute_Reference --
- -------------------------
-
- procedure Attribute_Reference
- (In_Tree : Project_Node_Tree_Ref;
- Reference : out Project_Node_Id;
- First_Attribute : Attribute_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags)
- is
- Current_Attribute : Attribute_Node_Id := First_Attribute;
-
- begin
- -- Declare the node of the attribute reference
-
- Reference :=
- Default_Project_Node
- (Of_Kind => N_Attribute_Reference, In_Tree => In_Tree);
- Set_Location_Of (Reference, In_Tree, To => Token_Ptr);
- Scan (In_Tree); -- past apostrophe
-
- -- Body may be an attribute name
-
- if Token = Tok_Body then
- Token := Tok_Identifier;
- Token_Name := Snames.Name_Body;
- end if;
-
- Expect (Tok_Identifier, "identifier");
-
- if Token = Tok_Identifier then
- Set_Name_Of (Reference, In_Tree, To => Token_Name);
-
- -- Check if the identifier is one of the attribute identifiers in the
- -- context (package or project level attributes).
-
- Current_Attribute :=
- Attribute_Node_Id_Of (Token_Name, Starting_At => First_Attribute);
-
- -- If the identifier is not allowed, report an error
-
- if Current_Attribute = Empty_Attribute then
- Error_Msg_Name_1 := Token_Name;
- Error_Msg (Flags, "unknown attribute %%", Token_Ptr);
- Reference := Empty_Node;
-
- -- Scan past the attribute name
-
- Scan (In_Tree);
-
- -- Skip a possible index for an associative array
-
- if Token = Tok_Left_Paren then
- Scan (In_Tree);
-
- if Token = Tok_String_Literal then
- Scan (In_Tree);
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree);
- end if;
- end if;
- end if;
-
- else
- -- Give its characteristics to this attribute reference
-
- Set_Project_Node_Of (Reference, In_Tree, To => Current_Project);
- Set_Package_Node_Of (Reference, In_Tree, To => Current_Package);
- Set_Expression_Kind_Of
- (Reference, In_Tree, To => Variable_Kind_Of (Current_Attribute));
- Set_Case_Insensitive
- (Reference, In_Tree,
- To => Attribute_Kind_Of (Current_Attribute) in
- All_Case_Insensitive_Associative_Array);
- Set_Default_Of
- (Reference, In_Tree,
- To => Attribute_Default_Of (Current_Attribute));
-
- -- Scan past the attribute name
-
- Scan (In_Tree);
-
- -- If the attribute is an associative array, get the index
-
- if Attribute_Kind_Of (Current_Attribute) /= Single then
- Expect (Tok_Left_Paren, "`(`");
-
- if Token = Tok_Left_Paren then
- Scan (In_Tree);
-
- if Others_Allowed_For (Current_Attribute)
- and then Token = Tok_Others
- then
- Set_Associative_Array_Index_Of
- (Reference, In_Tree, To => All_Other_Names);
- Scan (In_Tree);
-
- else
- if Others_Allowed_For (Current_Attribute) then
- Expect
- (Tok_String_Literal, "literal string or others");
- else
- Expect (Tok_String_Literal, "literal string");
- end if;
-
- if Token = Tok_String_Literal then
- Set_Associative_Array_Index_Of
- (Reference, In_Tree, To => Token_Name);
- Scan (In_Tree);
- end if;
- end if;
- end if;
-
- Expect (Tok_Right_Paren, "`)`");
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree);
- end if;
- end if;
- end if;
-
- -- Change name of obsolete attributes
-
- if Present (Reference) then
- case Name_Of (Reference, In_Tree) is
- when Snames.Name_Specification =>
- Set_Name_Of (Reference, In_Tree, To => Snames.Name_Spec);
-
- when Snames.Name_Specification_Suffix =>
- Set_Name_Of
- (Reference, In_Tree, To => Snames.Name_Spec_Suffix);
-
- when Snames.Name_Implementation =>
- Set_Name_Of (Reference, In_Tree, To => Snames.Name_Body);
-
- when Snames.Name_Implementation_Suffix =>
- Set_Name_Of
- (Reference, In_Tree, To => Snames.Name_Body_Suffix);
-
- when others =>
- null;
- end case;
- end if;
- end if;
- end Attribute_Reference;
-
- ---------------------------
- -- End_Case_Construction --
- ---------------------------
-
- procedure End_Case_Construction
- (Check_All_Labels : Boolean;
- Case_Location : Source_Ptr;
- Flags : Processing_Flags;
- String_Type : Boolean)
- is
- Non_Used : Natural := 0;
- First_Non_Used : Choice_Node_Id := First_Choice_Node_Id;
-
- begin
- -- First, if Check_All_Labels is True, check if all values of the string
- -- type have been used.
-
- if Check_All_Labels then
- if String_Type then
- for Choice in Choice_First .. Choices.Last loop
- if not Choices.Table (Choice).Already_Used then
- Non_Used := Non_Used + 1;
-
- if Non_Used = 1 then
- First_Non_Used := Choice;
- end if;
- end if;
- end loop;
-
- -- If only one is not used, report a single warning for this value
-
- if Non_Used = 1 then
- Error_Msg_Name_1 := Choices.Table (First_Non_Used).The_String;
- Error_Msg
- (Flags, "?value %% is not used as label", Case_Location);
-
- -- If several are not used, report a warning for each one of them
-
- elsif Non_Used > 1 then
- Error_Msg
- (Flags, "?the following values are not used as labels:",
- Case_Location);
-
- for Choice in First_Non_Used .. Choices.Last loop
- if not Choices.Table (Choice).Already_Used then
- Error_Msg_Name_1 := Choices.Table (Choice).The_String;
- Error_Msg (Flags, "\?%%", Case_Location);
- end if;
- end loop;
- end if;
- else
- Error_Msg
- (Flags,
- "?no when others for this case construction",
- Case_Location);
- end if;
- end if;
-
- -- If this is the only case construction, empty the tables
-
- if Choice_Lasts.Last = 1 then
- Choice_Lasts.Set_Last (0);
- Choices.Set_Last (First_Choice_Node_Id);
- Choice_First := 0;
-
- -- Second case construction, set the tables to the first
-
- elsif Choice_Lasts.Last = 2 then
- Choice_Lasts.Set_Last (1);
- Choices.Set_Last (Choice_Lasts.Table (1));
- Choice_First := 1;
-
- -- Third or more case construction, set the tables to the previous one
- else
- Choice_Lasts.Decrement_Last;
- Choices.Set_Last (Choice_Lasts.Table (Choice_Lasts.Last));
- Choice_First := Choice_Lasts.Table (Choice_Lasts.Last - 1) + 1;
- end if;
- end End_Case_Construction;
-
- ------------------------
- -- External_Reference --
- ------------------------
-
- procedure External_Reference
- (In_Tree : Project_Node_Tree_Ref;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- External_Value : out Project_Node_Id;
- Expr_Kind : in out Variable_Kind;
- Flags : Processing_Flags)
- is
- Field_Id : Project_Node_Id := Empty_Node;
- Ext_List : Boolean := False;
-
- begin
- External_Value :=
- Default_Project_Node
- (Of_Kind => N_External_Value,
- In_Tree => In_Tree);
- Set_Location_Of (External_Value, In_Tree, To => Token_Ptr);
-
- -- The current token is either external or external_as_list
-
- Ext_List := Token = Tok_External_As_List;
- Scan (In_Tree);
-
- if Ext_List then
- Set_Expression_Kind_Of (External_Value, In_Tree, To => List);
- else
- Set_Expression_Kind_Of (External_Value, In_Tree, To => Single);
- end if;
-
- if Expr_Kind = Undefined then
- if Ext_List then
- Expr_Kind := List;
- else
- Expr_Kind := Single;
- end if;
- end if;
-
- Expect (Tok_Left_Paren, "`(`");
-
- -- Scan past the left parenthesis
-
- if Token = Tok_Left_Paren then
- Scan (In_Tree);
- end if;
-
- -- Get the name of the external reference
-
- Expect (Tok_String_Literal, "literal string");
-
- if Token = Tok_String_Literal then
- Field_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- In_Tree => In_Tree,
- And_Expr_Kind => Single);
- Set_String_Value_Of (Field_Id, In_Tree, To => Token_Name);
- Set_External_Reference_Of (External_Value, In_Tree, To => Field_Id);
-
- -- Scan past the first argument
-
- Scan (In_Tree);
-
- case Token is
- when Tok_Right_Paren =>
- if Ext_List then
- Error_Msg (Flags, "`,` expected", Token_Ptr);
- end if;
-
- Scan (In_Tree); -- scan past right paren
-
- when Tok_Comma =>
- Scan (In_Tree); -- scan past comma
-
- -- Get the string expression for the default
-
- declare
- Loc : constant Source_Ptr := Token_Ptr;
-
- begin
- Parse_Expression
- (In_Tree => In_Tree,
- Expression => Field_Id,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Optional_Index => False);
-
- if Expression_Kind_Of (Field_Id, In_Tree) = List then
- Error_Msg
- (Flags, "expression must be a single string", Loc);
- else
- Set_External_Default_Of
- (External_Value, In_Tree, To => Field_Id);
- end if;
- end;
-
- Expect (Tok_Right_Paren, "`)`");
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree); -- scan past right paren
- end if;
-
- when others =>
- if Ext_List then
- Error_Msg (Flags, "`,` expected", Token_Ptr);
- else
- Error_Msg (Flags, "`,` or `)` expected", Token_Ptr);
- end if;
- end case;
- end if;
- end External_Reference;
-
- -----------------------
- -- Parse_Choice_List --
- -----------------------
-
- procedure Parse_Choice_List
- (In_Tree : Project_Node_Tree_Ref;
- First_Choice : out Project_Node_Id;
- Flags : Processing_Flags;
- String_Type : Boolean := True)
- is
- Current_Choice : Project_Node_Id := Empty_Node;
- Next_Choice : Project_Node_Id := Empty_Node;
- Choice_String : Name_Id := No_Name;
- Found : Boolean := False;
-
- begin
- -- Declare the node of the first choice
-
- First_Choice :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- In_Tree => In_Tree,
- And_Expr_Kind => Single);
-
- -- Initially Current_Choice is the same as First_Choice
-
- Current_Choice := First_Choice;
-
- loop
- Expect (Tok_String_Literal, "literal string");
- exit when Token /= Tok_String_Literal;
- Set_Location_Of (Current_Choice, In_Tree, To => Token_Ptr);
- Choice_String := Token_Name;
-
- -- Give the string value to the current choice
-
- Set_String_Value_Of (Current_Choice, In_Tree, To => Choice_String);
-
- if String_Type then
-
- -- Check if the label is part of the string type and if it has not
- -- been already used.
-
- Found := False;
- for Choice in Choice_First .. Choices.Last loop
- if Choices.Table (Choice).The_String = Choice_String then
-
- -- This label is part of the string type
-
- Found := True;
-
- if Choices.Table (Choice).Already_Used then
-
- -- But it has already appeared in a choice list for this
- -- case construction so report an error.
-
- Error_Msg_Name_1 := Choice_String;
- Error_Msg (Flags, "duplicate case label %%", Token_Ptr);
-
- else
- Choices.Table (Choice).Already_Used := True;
- end if;
-
- exit;
- end if;
- end loop;
-
- -- If the label is not part of the string list, report an error
-
- if not Found then
- Error_Msg_Name_1 := Choice_String;
- Error_Msg (Flags, "illegal case label %%", Token_Ptr);
- end if;
- end if;
-
- -- Scan past the label
-
- Scan (In_Tree);
-
- -- If there is no '|', we are done
-
- if Token = Tok_Vertical_Bar then
-
- -- Otherwise, declare the node of the next choice, link it to
- -- Current_Choice and set Current_Choice to this new node.
-
- Next_Choice :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- In_Tree => In_Tree,
- And_Expr_Kind => Single);
- Set_Next_Literal_String
- (Current_Choice, In_Tree, To => Next_Choice);
- Current_Choice := Next_Choice;
- Scan (In_Tree);
- else
- exit;
- end if;
- end loop;
- end Parse_Choice_List;
-
- ----------------------
- -- Parse_Expression --
- ----------------------
-
- procedure Parse_Expression
- (In_Tree : Project_Node_Tree_Ref;
- Expression : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Optional_Index : Boolean;
- Flags : Processing_Flags)
- is
- First_Term : Project_Node_Id := Empty_Node;
- Expression_Kind : Variable_Kind := Undefined;
-
- begin
- -- Declare the node of the expression
-
- Expression :=
- Default_Project_Node (Of_Kind => N_Expression, In_Tree => In_Tree);
- Set_Location_Of (Expression, In_Tree, To => Token_Ptr);
-
- -- Parse the term or terms of the expression
-
- Terms (In_Tree => In_Tree,
- Term => First_Term,
- Expr_Kind => Expression_Kind,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Optional_Index => Optional_Index);
-
- -- Set the first term and the expression kind
-
- Set_First_Term (Expression, In_Tree, To => First_Term);
- Set_Expression_Kind_Of (Expression, In_Tree, To => Expression_Kind);
- end Parse_Expression;
-
- ----------------------------
- -- Parse_String_Type_List --
- ----------------------------
-
- procedure Parse_String_Type_List
- (In_Tree : Project_Node_Tree_Ref;
- First_String : out Project_Node_Id;
- Flags : Processing_Flags)
- is
- Last_String : Project_Node_Id := Empty_Node;
- Next_String : Project_Node_Id := Empty_Node;
- String_Value : Name_Id := No_Name;
-
- begin
- -- Declare the node of the first string
-
- First_String :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- In_Tree => In_Tree,
- And_Expr_Kind => Single);
-
- -- Initially, Last_String is the same as First_String
-
- Last_String := First_String;
-
- loop
- Expect (Tok_String_Literal, "literal string");
- exit when Token /= Tok_String_Literal;
- String_Value := Token_Name;
-
- -- Give its string value to Last_String
-
- Set_String_Value_Of (Last_String, In_Tree, To => String_Value);
- Set_Location_Of (Last_String, In_Tree, To => Token_Ptr);
-
- -- Now, check if the string is already part of the string type
-
- declare
- Current : Project_Node_Id := First_String;
-
- begin
- while Current /= Last_String loop
- if String_Value_Of (Current, In_Tree) = String_Value then
-
- -- This is a repetition, report an error
-
- Error_Msg_Name_1 := String_Value;
- Error_Msg (Flags, "duplicate value %% in type", Token_Ptr);
- exit;
- end if;
-
- Current := Next_Literal_String (Current, In_Tree);
- end loop;
- end;
-
- -- Scan past the literal string
-
- Scan (In_Tree);
-
- -- If there is no comma following the literal string, we are done
-
- if Token /= Tok_Comma then
- exit;
-
- else
- -- Declare the next string, link it to Last_String and set
- -- Last_String to its node.
-
- Next_String :=
- Default_Project_Node
- (Of_Kind => N_Literal_String,
- In_Tree => In_Tree,
- And_Expr_Kind => Single);
- Set_Next_Literal_String (Last_String, In_Tree, To => Next_String);
- Last_String := Next_String;
- Scan (In_Tree);
- end if;
- end loop;
- end Parse_String_Type_List;
-
- ------------------------------
- -- Parse_Variable_Reference --
- ------------------------------
-
- procedure Parse_Variable_Reference
- (In_Tree : Project_Node_Tree_Ref;
- Variable : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags)
- is
- Current_Variable : Project_Node_Id := Empty_Node;
-
- The_Package : Project_Node_Id := Current_Package;
- The_Project : Project_Node_Id := Current_Project;
-
- Specified_Project : Project_Node_Id := Empty_Node;
- Specified_Package : Project_Node_Id := Empty_Node;
- Look_For_Variable : Boolean := True;
- First_Attribute : Attribute_Node_Id := Empty_Attribute;
- Variable_Name : Name_Id;
-
- begin
- Names.Init;
-
- loop
- Expect (Tok_Identifier, "identifier");
-
- if Token /= Tok_Identifier then
- Look_For_Variable := False;
- exit;
- end if;
-
- Add_To_Names (NL => (Name => Token_Name, Location => Token_Ptr));
- Scan (In_Tree);
- exit when Token /= Tok_Dot;
- Scan (In_Tree);
- end loop;
-
- if Look_For_Variable then
-
- if Token = Tok_Apostrophe then
-
- -- Attribute reference
-
- case Names.Last is
- when 0 =>
-
- -- Cannot happen
-
- null;
-
- when 1 =>
- -- This may be a project name or a package name.
- -- Project name have precedence.
-
- -- First, look if it can be a package name
-
- First_Attribute :=
- First_Attribute_Of
- (Package_Node_Id_Of (Names.Table (1).Name));
-
- -- Now, look if it can be a project name
-
- if Names.Table (1).Name =
- Name_Of (Current_Project, In_Tree)
- then
- The_Project := Current_Project;
-
- else
- The_Project :=
- Imported_Or_Extended_Project_Of
- (Current_Project, In_Tree, Names.Table (1).Name);
- end if;
-
- if No (The_Project) then
-
- -- If it is neither a project name nor a package name,
- -- report an error.
-
- if First_Attribute = Empty_Attribute then
- Error_Msg_Name_1 := Names.Table (1).Name;
- Error_Msg (Flags, "unknown project %",
- Names.Table (1).Location);
- First_Attribute := Attribute_First;
-
- else
- -- If it is a package name, check if the package has
- -- already been declared in the current project.
-
- The_Package :=
- First_Package_Of (Current_Project, In_Tree);
-
- while Present (The_Package)
- and then Name_Of (The_Package, In_Tree) /=
- Names.Table (1).Name
- loop
- The_Package :=
- Next_Package_In_Project (The_Package, In_Tree);
- end loop;
-
- -- If it has not been already declared, report an
- -- error.
-
- if No (The_Package) then
- Error_Msg_Name_1 := Names.Table (1).Name;
- Error_Msg (Flags, "package % not yet defined",
- Names.Table (1).Location);
- end if;
- end if;
-
- else
- -- It is a project name
-
- First_Attribute := Attribute_First;
- The_Package := Empty_Node;
- end if;
-
- when others =>
-
- -- We have either a project name made of several simple
- -- names (long project), or a project name (short project)
- -- followed by a package name. The long project name has
- -- precedence.
-
- declare
- Short_Project : Name_Id;
- Long_Project : Name_Id;
-
- begin
- -- Clear the Buffer
-
- Buffer_Last := 0;
-
- -- Get the name of the short project
-
- for Index in 1 .. Names.Last - 1 loop
- Add_To_Buffer
- (Get_Name_String (Names.Table (Index).Name),
- Buffer, Buffer_Last);
-
- if Index /= Names.Last - 1 then
- Add_To_Buffer (".", Buffer, Buffer_Last);
- end if;
- end loop;
-
- Name_Len := Buffer_Last;
- Name_Buffer (1 .. Buffer_Last) :=
- Buffer (1 .. Buffer_Last);
- Short_Project := Name_Find;
-
- -- Now, add the last simple name to get the name of the
- -- long project.
-
- Add_To_Buffer (".", Buffer, Buffer_Last);
- Add_To_Buffer
- (Get_Name_String (Names.Table (Names.Last).Name),
- Buffer, Buffer_Last);
- Name_Len := Buffer_Last;
- Name_Buffer (1 .. Buffer_Last) :=
- Buffer (1 .. Buffer_Last);
- Long_Project := Name_Find;
-
- -- Check if the long project is imported or extended
-
- if Long_Project = Name_Of (Current_Project, In_Tree) then
- The_Project := Current_Project;
-
- else
- The_Project :=
- Imported_Or_Extended_Project_Of
- (Current_Project,
- In_Tree,
- Long_Project);
- end if;
-
- -- If the long project exists, then this is the prefix
- -- of the attribute.
-
- if Present (The_Project) then
- First_Attribute := Attribute_First;
- The_Package := Empty_Node;
-
- else
- -- Otherwise, check if the short project is imported
- -- or extended.
-
- if Short_Project =
- Name_Of (Current_Project, In_Tree)
- then
- The_Project := Current_Project;
-
- else
- The_Project := Imported_Or_Extended_Project_Of
- (Current_Project, In_Tree,
- Short_Project);
- end if;
-
- -- If short project does not exist, report an error
-
- if No (The_Project) then
- Error_Msg_Name_1 := Long_Project;
- Error_Msg_Name_2 := Short_Project;
- Error_Msg (Flags, "unknown projects % or %",
- Names.Table (1).Location);
- The_Package := Empty_Node;
- First_Attribute := Attribute_First;
-
- else
- -- Now, we check if the package has been declared
- -- in this project.
-
- The_Package :=
- First_Package_Of (The_Project, In_Tree);
- while Present (The_Package)
- and then Name_Of (The_Package, In_Tree) /=
- Names.Table (Names.Last).Name
- loop
- The_Package :=
- Next_Package_In_Project (The_Package, In_Tree);
- end loop;
-
- -- If it has not, then we report an error
-
- if No (The_Package) then
- Error_Msg_Name_1 :=
- Names.Table (Names.Last).Name;
- Error_Msg_Name_2 := Short_Project;
- Error_Msg (Flags,
- "package % not declared in project %",
- Names.Table (Names.Last).Location);
- First_Attribute := Attribute_First;
-
- else
- -- Otherwise, we have the correct project and
- -- package.
-
- First_Attribute :=
- First_Attribute_Of
- (Package_Id_Of (The_Package, In_Tree));
- end if;
- end if;
- end if;
- end;
- end case;
-
- Attribute_Reference
- (In_Tree,
- Variable,
- Flags => Flags,
- Current_Project => The_Project,
- Current_Package => The_Package,
- First_Attribute => First_Attribute);
- return;
- end if;
- end if;
-
- Variable :=
- Default_Project_Node
- (Of_Kind => N_Variable_Reference, In_Tree => In_Tree);
-
- if Look_For_Variable then
- case Names.Last is
- when 0 =>
-
- -- Cannot happen (so why null instead of raise PE???)
-
- null;
-
- when 1 =>
-
- -- Simple variable name
-
- Set_Name_Of (Variable, In_Tree, To => Names.Table (1).Name);
-
- when 2 =>
-
- -- Variable name with a simple name prefix that can be
- -- a project name or a package name. Project names have
- -- priority over package names.
-
- Set_Name_Of (Variable, In_Tree, To => Names.Table (2).Name);
-
- -- Check if it can be a package name
-
- The_Package := First_Package_Of (Current_Project, In_Tree);
-
- while Present (The_Package)
- and then Name_Of (The_Package, In_Tree) /=
- Names.Table (1).Name
- loop
- The_Package :=
- Next_Package_In_Project (The_Package, In_Tree);
- end loop;
-
- -- Now look for a possible project name
-
- The_Project := Imported_Or_Extended_Project_Of
- (Current_Project, In_Tree, Names.Table (1).Name);
-
- if Present (The_Project) then
- Specified_Project := The_Project;
-
- elsif No (The_Package) then
- Error_Msg_Name_1 := Names.Table (1).Name;
- Error_Msg (Flags, "unknown package or project %",
- Names.Table (1).Location);
- Look_For_Variable := False;
-
- else
- Specified_Package := The_Package;
- end if;
-
- when others =>
-
- -- Variable name with a prefix that is either a project name
- -- made of several simple names, or a project name followed
- -- by a package name.
-
- Set_Name_Of
- (Variable, In_Tree, To => Names.Table (Names.Last).Name);
-
- declare
- Short_Project : Name_Id;
- Long_Project : Name_Id;
-
- begin
- -- First, we get the two possible project names
-
- -- Clear the buffer
-
- Buffer_Last := 0;
-
- -- Add all the simple names, except the last two
-
- for Index in 1 .. Names.Last - 2 loop
- Add_To_Buffer
- (Get_Name_String (Names.Table (Index).Name),
- Buffer, Buffer_Last);
-
- if Index /= Names.Last - 2 then
- Add_To_Buffer (".", Buffer, Buffer_Last);
- end if;
- end loop;
-
- Name_Len := Buffer_Last;
- Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
- Short_Project := Name_Find;
-
- -- Add the simple name before the name of the variable
-
- Add_To_Buffer (".", Buffer, Buffer_Last);
- Add_To_Buffer
- (Get_Name_String (Names.Table (Names.Last - 1).Name),
- Buffer, Buffer_Last);
- Name_Len := Buffer_Last;
- Name_Buffer (1 .. Name_Len) := Buffer (1 .. Buffer_Last);
- Long_Project := Name_Find;
-
- -- Check if the prefix is the name of an imported or
- -- extended project.
-
- The_Project := Imported_Or_Extended_Project_Of
- (Current_Project, In_Tree, Long_Project);
-
- if Present (The_Project) then
- Specified_Project := The_Project;
-
- else
- -- Now check if the prefix may be a project name followed
- -- by a package name.
-
- -- First check for a possible project name
-
- The_Project :=
- Imported_Or_Extended_Project_Of
- (Current_Project, In_Tree, Short_Project);
-
- if No (The_Project) then
- -- Unknown prefix, report an error
-
- Error_Msg_Name_1 := Long_Project;
- Error_Msg_Name_2 := Short_Project;
- Error_Msg
- (Flags, "unknown projects % or %",
- Names.Table (1).Location);
- Look_For_Variable := False;
-
- else
- Specified_Project := The_Project;
-
- -- Now look for the package in this project
-
- The_Package := First_Package_Of (The_Project, In_Tree);
-
- while Present (The_Package)
- and then Name_Of (The_Package, In_Tree) /=
- Names.Table (Names.Last - 1).Name
- loop
- The_Package :=
- Next_Package_In_Project (The_Package, In_Tree);
- end loop;
-
- if No (The_Package) then
-
- -- The package does not exist, report an error
-
- Error_Msg_Name_1 := Names.Table (2).Name;
- Error_Msg (Flags, "unknown package %",
- Names.Table (Names.Last - 1).Location);
- Look_For_Variable := False;
-
- else
- Specified_Package := The_Package;
- end if;
- end if;
- end if;
- end;
- end case;
- end if;
-
- if Look_For_Variable then
- Variable_Name := Name_Of (Variable, In_Tree);
- Set_Project_Node_Of (Variable, In_Tree, To => Specified_Project);
- Set_Package_Node_Of (Variable, In_Tree, To => Specified_Package);
-
- if Present (Specified_Project) then
- The_Project := Specified_Project;
- else
- The_Project := Current_Project;
- end if;
-
- Current_Variable := Empty_Node;
-
- -- Look for this variable
-
- -- If a package was specified, check if the variable has been
- -- declared in this package.
-
- if Present (Specified_Package) then
- Current_Variable :=
- First_Variable_Of (Specified_Package, In_Tree);
- while Present (Current_Variable)
- and then
- Name_Of (Current_Variable, In_Tree) /= Variable_Name
- loop
- Current_Variable := Next_Variable (Current_Variable, In_Tree);
- end loop;
-
- else
- -- Otherwise, if no project has been specified and we are in
- -- a package, first check if the variable has been declared in
- -- the package.
-
- if No (Specified_Project)
- and then Present (Current_Package)
- then
- Current_Variable :=
- First_Variable_Of (Current_Package, In_Tree);
- while Present (Current_Variable)
- and then Name_Of (Current_Variable, In_Tree) /= Variable_Name
- loop
- Current_Variable :=
- Next_Variable (Current_Variable, In_Tree);
- end loop;
- end if;
-
- -- If we have not found the variable in the package, check if the
- -- variable has been declared in the project, or in any of its
- -- ancestors, or in any of the project it extends.
-
- if No (Current_Variable) then
- declare
- Proj : Project_Node_Id := The_Project;
-
- begin
- loop
- Current_Variable := First_Variable_Of (Proj, In_Tree);
- while
- Present (Current_Variable)
- and then
- Name_Of (Current_Variable, In_Tree) /= Variable_Name
- loop
- Current_Variable :=
- Next_Variable (Current_Variable, In_Tree);
- end loop;
-
- exit when Present (Current_Variable);
-
- -- If the current project is a child project, check if
- -- the variable is declared in its parent. Otherwise, if
- -- the current project extends another project, check if
- -- the variable is declared in one of the projects the
- -- current project extends.
-
- if No (Parent_Project_Of (Proj, In_Tree)) then
- Proj :=
- Extended_Project_Of
- (Project_Declaration_Of (Proj, In_Tree), In_Tree);
- else
- Proj := Parent_Project_Of (Proj, In_Tree);
- end if;
-
- Set_Project_Node_Of (Variable, In_Tree, To => Proj);
-
- exit when No (Proj);
- end loop;
- end;
- end if;
- end if;
-
- -- If the variable was not found, report an error
-
- if No (Current_Variable) then
- Error_Msg_Name_1 := Variable_Name;
- Error_Msg
- (Flags, "unknown variable %", Names.Table (Names.Last).Location);
- end if;
- end if;
-
- if Present (Current_Variable) then
- Set_Expression_Kind_Of
- (Variable, In_Tree,
- To => Expression_Kind_Of (Current_Variable, In_Tree));
-
- if Kind_Of (Current_Variable, In_Tree) =
- N_Typed_Variable_Declaration
- then
- Set_String_Type_Of
- (Variable, In_Tree,
- To => String_Type_Of (Current_Variable, In_Tree));
- end if;
- end if;
-
- -- If the variable is followed by a left parenthesis, report an error
- -- but attempt to scan the index.
-
- if Token = Tok_Left_Paren then
- Error_Msg
- (Flags, "\variables cannot be associative arrays", Token_Ptr);
- Scan (In_Tree);
- Expect (Tok_String_Literal, "literal string");
-
- if Token = Tok_String_Literal then
- Scan (In_Tree);
- Expect (Tok_Right_Paren, "`)`");
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree);
- end if;
- end if;
- end if;
- end Parse_Variable_Reference;
-
- ---------------------------------
- -- Start_New_Case_Construction --
- ---------------------------------
-
- procedure Start_New_Case_Construction
- (In_Tree : Project_Node_Tree_Ref;
- String_Type : Project_Node_Id)
- is
- Current_String : Project_Node_Id;
-
- begin
- -- Set Choice_First, depending on whether this is the first case
- -- construction or not.
-
- if Choice_First = 0 then
- Choice_First := 1;
- Choices.Set_Last (First_Choice_Node_Id);
- else
- Choice_First := Choices.Last + 1;
- end if;
-
- -- Add the literal of the string type to the Choices table
-
- if Present (String_Type) then
- Current_String := First_Literal_String (String_Type, In_Tree);
- while Present (Current_String) loop
- Add (This_String => String_Value_Of (Current_String, In_Tree));
- Current_String := Next_Literal_String (Current_String, In_Tree);
- end loop;
- end if;
-
- -- Set the value of the last choice in table Choice_Lasts
-
- Choice_Lasts.Increment_Last;
- Choice_Lasts.Table (Choice_Lasts.Last) := Choices.Last;
- end Start_New_Case_Construction;
-
- -----------
- -- Terms --
- -----------
-
- procedure Terms
- (In_Tree : Project_Node_Tree_Ref;
- Term : out Project_Node_Id;
- Expr_Kind : in out Variable_Kind;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Optional_Index : Boolean;
- Flags : Processing_Flags)
- is
- Next_Term : Project_Node_Id := Empty_Node;
- Term_Id : Project_Node_Id := Empty_Node;
- Current_Expression : Project_Node_Id := Empty_Node;
- Next_Expression : Project_Node_Id := Empty_Node;
- Current_Location : Source_Ptr := No_Location;
- Reference : Project_Node_Id := Empty_Node;
-
- begin
- -- Declare a new node for the term
-
- Term := Default_Project_Node (Of_Kind => N_Term, In_Tree => In_Tree);
- Set_Location_Of (Term, In_Tree, To => Token_Ptr);
-
- case Token is
- when Tok_Left_Paren =>
-
- -- If we have a left parenthesis and we don't know the expression
- -- kind, then this is a string list.
-
- case Expr_Kind is
- when Undefined =>
- Expr_Kind := List;
-
- when List =>
- null;
-
- when Single =>
-
- -- If we already know that this is a single string, report
- -- an error, but set the expression kind to string list to
- -- avoid several errors.
-
- Expr_Kind := List;
- Error_Msg
- (Flags, "literal string list cannot appear in a string",
- Token_Ptr);
- end case;
-
- -- Declare a new node for this literal string list
-
- Term_Id := Default_Project_Node
- (Of_Kind => N_Literal_String_List,
- In_Tree => In_Tree,
- And_Expr_Kind => List);
- Set_Current_Term (Term, In_Tree, To => Term_Id);
- Set_Location_Of (Term, In_Tree, To => Token_Ptr);
-
- -- Scan past the left parenthesis
-
- Scan (In_Tree);
-
- -- If the left parenthesis is immediately followed by a right
- -- parenthesis, the literal string list is empty.
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree);
-
- else
- -- Otherwise parse the expression(s) in the literal string list
-
- loop
- Current_Location := Token_Ptr;
- Parse_Expression
- (In_Tree => In_Tree,
- Expression => Next_Expression,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Optional_Index => Optional_Index);
-
- -- The expression kind is String list, report an error
-
- if Expression_Kind_Of (Next_Expression, In_Tree) = List then
- Error_Msg (Flags, "single expression expected",
- Current_Location);
- end if;
-
- -- If Current_Expression is empty, it means that the
- -- expression is the first in the string list.
-
- if No (Current_Expression) then
- Set_First_Expression_In_List
- (Term_Id, In_Tree, To => Next_Expression);
- else
- Set_Next_Expression_In_List
- (Current_Expression, In_Tree, To => Next_Expression);
- end if;
-
- Current_Expression := Next_Expression;
-
- -- If there is a comma, continue with the next expression
-
- exit when Token /= Tok_Comma;
- Scan (In_Tree); -- past the comma
- end loop;
-
- -- We expect a closing right parenthesis
-
- Expect (Tok_Right_Paren, "`)`");
-
- if Token = Tok_Right_Paren then
- Scan (In_Tree);
- end if;
- end if;
-
- when Tok_String_Literal =>
-
- -- If we don't know the expression kind (first term), then it is
- -- a simple string.
-
- if Expr_Kind = Undefined then
- Expr_Kind := Single;
- end if;
-
- -- Declare a new node for the string literal
-
- Term_Id :=
- Default_Project_Node
- (Of_Kind => N_Literal_String, In_Tree => In_Tree);
- Set_Current_Term (Term, In_Tree, To => Term_Id);
- Set_String_Value_Of (Term_Id, In_Tree, To => Token_Name);
-
- -- Scan past the string literal
-
- Scan (In_Tree);
-
- -- Check for possible index expression
-
- if Token = Tok_At then
- if not Optional_Index then
- Error_Msg (Flags, "index not allowed here", Token_Ptr);
- Scan (In_Tree);
-
- if Token = Tok_Integer_Literal then
- Scan (In_Tree);
- end if;
-
- -- Set the index value
-
- else
- Scan (In_Tree);
- Expect (Tok_Integer_Literal, "integer literal");
-
- if Token = Tok_Integer_Literal then
- declare
- Index : constant Int := UI_To_Int (Int_Literal_Value);
- begin
- if Index = 0 then
- Error_Msg
- (Flags, "index cannot be zero", Token_Ptr);
- else
- Set_Source_Index_Of
- (Term_Id, In_Tree, To => Index);
- end if;
- end;
-
- Scan (In_Tree);
- end if;
- end if;
- end if;
-
- when Tok_Identifier =>
- Current_Location := Token_Ptr;
-
- -- Get the variable or attribute reference
-
- Parse_Variable_Reference
- (In_Tree => In_Tree,
- Variable => Reference,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package);
- Set_Current_Term (Term, In_Tree, To => Reference);
-
- if Present (Reference) then
-
- -- If we don't know the expression kind (first term), then it
- -- has the kind of the variable or attribute reference.
-
- if Expr_Kind = Undefined then
- Expr_Kind := Expression_Kind_Of (Reference, In_Tree);
-
- elsif Expr_Kind = Single
- and then Expression_Kind_Of (Reference, In_Tree) = List
- then
- -- If the expression is a single list, and the reference is
- -- a string list, report an error, and set the expression
- -- kind to string list to avoid multiple errors.
-
- Expr_Kind := List;
- Error_Msg
- (Flags,
- "list variable cannot appear in single string expression",
- Current_Location);
- end if;
- end if;
-
- when Tok_Project =>
-
- -- Project can appear in an expression as the prefix of an
- -- attribute reference of the current project.
-
- Current_Location := Token_Ptr;
- Scan (In_Tree);
- Expect (Tok_Apostrophe, "`'`");
-
- if Token = Tok_Apostrophe then
- Attribute_Reference
- (In_Tree => In_Tree,
- Reference => Reference,
- Flags => Flags,
- First_Attribute => Prj.Attr.Attribute_First,
- Current_Project => Current_Project,
- Current_Package => Empty_Node);
- Set_Current_Term (Term, In_Tree, To => Reference);
- end if;
-
- -- Same checks as above for the expression kind
-
- if Present (Reference) then
- if Expr_Kind = Undefined then
- Expr_Kind := Expression_Kind_Of (Reference, In_Tree);
-
- elsif Expr_Kind = Single
- and then Expression_Kind_Of (Reference, In_Tree) = List
- then
- Error_Msg
- (Flags, "lists cannot appear in single string expression",
- Current_Location);
- end if;
- end if;
-
- when Tok_External
- | Tok_External_As_List
- =>
- External_Reference
- (In_Tree => In_Tree,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Expr_Kind => Expr_Kind,
- External_Value => Reference);
- Set_Current_Term (Term, In_Tree, To => Reference);
-
- when others =>
- Error_Msg (Flags, "cannot be part of an expression", Token_Ptr);
- Term := Empty_Node;
- return;
- end case;
-
- -- If there is an '&', call Terms recursively
-
- if Token = Tok_Ampersand then
- Scan (In_Tree); -- scan past ampersand
-
- Terms
- (In_Tree => In_Tree,
- Term => Next_Term,
- Expr_Kind => Expr_Kind,
- Flags => Flags,
- Current_Project => Current_Project,
- Current_Package => Current_Package,
- Optional_Index => Optional_Index);
-
- -- And link the next term to this term
-
- Set_Next_Term (Term, In_Tree, To => Next_Term);
- end if;
- end Terms;
-
-end Prj.Strt;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . S T R T --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package implements parsing of string expressions in project files
-
-with Prj.Tree; use Prj.Tree;
-
-private package Prj.Strt is
-
- procedure Parse_String_Type_List
- (In_Tree : Project_Node_Tree_Ref;
- First_String : out Project_Node_Id;
- Flags : Processing_Flags);
- -- Get the list of literal strings that are allowed for a typed string.
- -- On entry, the current token is the first literal string following
- -- a left parenthesis in a string type declaration such as:
- -- type Toto is ("string_1", "string_2", "string_3");
- --
- -- On exit, the current token is the right parenthesis. The parameter
- -- First_String is a node that contained the first literal string of the
- -- string type, linked with the following literal strings.
- --
- -- Report an error if
- -- - a literal string is not found at the beginning of the list
- -- or after a comma
- -- - two literal strings in the list are equal
-
- procedure Start_New_Case_Construction
- (In_Tree : Project_Node_Tree_Ref;
- String_Type : Project_Node_Id);
- -- This procedure is called at the beginning of a case construction. The
- -- parameter String_Type is the node for the string type of the case label
- -- variable. The different literal strings of the string type are stored
- -- into a table to be checked against the labels of the case construction.
-
- procedure End_Case_Construction
- (Check_All_Labels : Boolean;
- Case_Location : Source_Ptr;
- Flags : Processing_Flags;
- String_Type : Boolean);
- -- This procedure is called at the end of a case construction to remove
- -- the case labels and to restore the previous state. In particular, in the
- -- case of nested case constructions, the case labels of the enclosing case
- -- construction are restored. If When_Others is False and we are not in
- -- quiet output, a warning is emitted for each value of the case variable
- -- string type that has not been specified.
-
- procedure Parse_Choice_List
- (In_Tree : Project_Node_Tree_Ref;
- First_Choice : out Project_Node_Id;
- Flags : Processing_Flags;
- String_Type : Boolean := True);
- -- Get the label for a choice list.
- -- Report an error if
- -- - a case label is not a literal string
- -- - a case label is not in the typed string list
- -- - the same case label is repeated in the same case construction
-
- procedure Parse_Expression
- (In_Tree : Project_Node_Tree_Ref;
- Expression : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Optional_Index : Boolean;
- Flags : Processing_Flags);
- -- Parse a simple string expression or a string list expression
- --
- -- Current_Project is the node of the project file being parsed
- --
- -- Current_Package is the node of the package being parsed, or Empty_Node
- -- when we are at the project level (not in a package). On exit, Expression
- -- is the node of the expression that has been parsed.
-
- procedure Parse_Variable_Reference
- (In_Tree : Project_Node_Tree_Ref;
- Variable : out Project_Node_Id;
- Current_Project : Project_Node_Id;
- Current_Package : Project_Node_Id;
- Flags : Processing_Flags);
- -- Parse variable or attribute reference. Used internally (in expressions)
- -- and for case variables (in Prj.Dect). Current_Package is the node of the
- -- package being parsed, or Empty_Node when we are at the project level
- -- (not in a package). On exit, Variable is the node of the variable or
- -- attribute reference. A variable reference is made of one to three simple
- -- names. An attribute reference is made of one or two simple names,
- -- followed by an apostrophe, followed by the attribute simple name.
-
-end Prj.Strt;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . T R E E --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Osint; use Osint;
-with Prj.Env; use Prj.Env;
-with Prj.Err;
-
-with Ada.Unchecked_Deallocation;
-
-package body Prj.Tree is
-
- Node_With_Comments : constant array (Project_Node_Kind) of Boolean :=
- (N_Project => True,
- N_With_Clause => True,
- N_Project_Declaration => False,
- N_Declarative_Item => False,
- N_Package_Declaration => True,
- N_String_Type_Declaration => True,
- N_Literal_String => False,
- N_Attribute_Declaration => True,
- N_Typed_Variable_Declaration => True,
- N_Variable_Declaration => True,
- N_Expression => False,
- N_Term => False,
- N_Literal_String_List => False,
- N_Variable_Reference => False,
- N_External_Value => False,
- N_Attribute_Reference => False,
- N_Case_Construction => True,
- N_Case_Item => True,
- N_Comment_Zones => True,
- N_Comment => True);
- -- Indicates the kinds of node that may have associated comments
-
- package Next_End_Nodes is new Table.Table
- (Table_Component_Type => Project_Node_Id,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Next_End_Nodes");
- -- A stack of nodes to indicates to what node the next "end" is associated
-
- use Tree_Private_Part;
-
- End_Of_Line_Node : Project_Node_Id := Empty_Node;
- -- The node an end of line comment may be associated with
-
- Previous_Line_Node : Project_Node_Id := Empty_Node;
- -- The node an immediately following comment may be associated with
-
- Previous_End_Node : Project_Node_Id := Empty_Node;
- -- The node comments immediately following an "end" line may be
- -- associated with.
-
- Unkept_Comments : Boolean := False;
- -- Set to True when some comments may not be associated with any node
-
- function Comment_Zones_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Returns the ID of the N_Comment_Zones node associated with node Node.
- -- If there is not already an N_Comment_Zones node, create one and
- -- associate it with node Node.
-
- ------------------
- -- Add_Comments --
- ------------------
-
- procedure Add_Comments
- (To : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Where : Comment_Location) is
- Zone : Project_Node_Id := Empty_Node;
- Previous : Project_Node_Id := Empty_Node;
-
- begin
- pragma Assert
- (Present (To)
- and then In_Tree.Project_Nodes.Table (To).Kind /= N_Comment);
-
- Zone := In_Tree.Project_Nodes.Table (To).Comments;
-
- if No (Zone) then
-
- -- Create new N_Comment_Zones node
-
- Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table
- (Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
- (Kind => N_Comment_Zones,
- Qualifier => Unspecified,
- Expr_Kind => Undefined,
- Location => No_Location,
- Directory => No_Path,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Display_Name => No_Name,
- Src_Index => 0,
- Path_Name => No_Path,
- Value => No_Name,
- Default => Empty_Value,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Field4 => Empty_Node,
- Flag1 => False,
- Flag2 => False,
- Comments => Empty_Node);
-
- Zone := Project_Node_Table.Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table (To).Comments := Zone;
- end if;
-
- if Where = End_Of_Line then
- In_Tree.Project_Nodes.Table (Zone).Value := Comments.Table (1).Value;
-
- else
- -- Get each comments in the Comments table and link them to node To
-
- for J in 1 .. Comments.Last loop
-
- -- Create new N_Comment node
-
- if (Where = After or else Where = After_End)
- and then Token /= Tok_EOF
- and then Comments.Table (J).Follows_Empty_Line
- then
- Comments.Table (1 .. Comments.Last - J + 1) :=
- Comments.Table (J .. Comments.Last);
- Comments.Set_Last (Comments.Last - J + 1);
- return;
- end if;
-
- Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table
- (Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
- (Kind => N_Comment,
- Qualifier => Unspecified,
- Expr_Kind => Undefined,
- Flag1 => Comments.Table (J).Follows_Empty_Line,
- Flag2 =>
- Comments.Table (J).Is_Followed_By_Empty_Line,
- Location => No_Location,
- Directory => No_Path,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Display_Name => No_Name,
- Src_Index => 0,
- Path_Name => No_Path,
- Value => Comments.Table (J).Value,
- Default => Empty_Value,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Field4 => Empty_Node,
- Comments => Empty_Node);
-
- -- If this is the first comment, put it in the right field of
- -- the node Zone.
-
- if No (Previous) then
- case Where is
- when Before =>
- In_Tree.Project_Nodes.Table (Zone).Field1 :=
- Project_Node_Table.Last (In_Tree.Project_Nodes);
-
- when After =>
- In_Tree.Project_Nodes.Table (Zone).Field2 :=
- Project_Node_Table.Last (In_Tree.Project_Nodes);
-
- when Before_End =>
- In_Tree.Project_Nodes.Table (Zone).Field3 :=
- Project_Node_Table.Last (In_Tree.Project_Nodes);
-
- when After_End =>
- In_Tree.Project_Nodes.Table (Zone).Comments :=
- Project_Node_Table.Last (In_Tree.Project_Nodes);
-
- when End_Of_Line =>
- null;
- end case;
-
- else
- -- When it is not the first, link it to the previous one
-
- In_Tree.Project_Nodes.Table (Previous).Comments :=
- Project_Node_Table.Last (In_Tree.Project_Nodes);
- end if;
-
- -- This node becomes the previous one for the next comment, if
- -- there is one.
-
- Previous := Project_Node_Table.Last (In_Tree.Project_Nodes);
- end loop;
- end if;
-
- -- Empty the Comments table, so that there is no risk to link the same
- -- comments to another node.
-
- Comments.Set_Last (0);
- end Add_Comments;
-
- --------------------------------
- -- Associative_Array_Index_Of --
- --------------------------------
-
- function Associative_Array_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- return In_Tree.Project_Nodes.Table (Node).Value;
- end Associative_Array_Index_Of;
-
- ----------------------------
- -- Associative_Package_Of --
- ----------------------------
-
- function Associative_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
- return In_Tree.Project_Nodes.Table (Node).Field3;
- end Associative_Package_Of;
-
- ----------------------------
- -- Associative_Project_Of --
- ----------------------------
-
- function Associative_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration));
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Associative_Project_Of;
-
- ----------------------
- -- Case_Insensitive --
- ----------------------
-
- function Case_Insensitive
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- return In_Tree.Project_Nodes.Table (Node).Flag1;
- end Case_Insensitive;
-
- --------------------------------
- -- Case_Variable_Reference_Of --
- --------------------------------
-
- function Case_Variable_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end Case_Variable_Reference_Of;
-
- ----------------------
- -- Comment_Zones_Of --
- ----------------------
-
- function Comment_Zones_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- Zone : Project_Node_Id;
-
- begin
- pragma Assert (Present (Node));
- Zone := In_Tree.Project_Nodes.Table (Node).Comments;
-
- -- If there is not already an N_Comment_Zones associated, create a new
- -- one and associate it with node Node.
-
- if No (Zone) then
- Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
- Zone := Project_Node_Table.Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table (Zone) :=
- (Kind => N_Comment_Zones,
- Qualifier => Unspecified,
- Location => No_Location,
- Directory => No_Path,
- Expr_Kind => Undefined,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Display_Name => No_Name,
- Src_Index => 0,
- Path_Name => No_Path,
- Value => No_Name,
- Default => Empty_Value,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Field4 => Empty_Node,
- Flag1 => False,
- Flag2 => False,
- Comments => Empty_Node);
- In_Tree.Project_Nodes.Table (Node).Comments := Zone;
- end if;
-
- return Zone;
- end Comment_Zones_Of;
-
- -----------------------
- -- Current_Item_Node --
- -----------------------
-
- function Current_Item_Node
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end Current_Item_Node;
-
- ------------------
- -- Current_Term --
- ------------------
-
- function Current_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end Current_Term;
-
- ----------------
- -- Default_Of --
- ----------------
-
- function Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference);
- return In_Tree.Project_Nodes.Table (Node).Default;
- end Default_Of;
-
- --------------------------
- -- Default_Project_Node --
- --------------------------
-
- function Default_Project_Node
- (In_Tree : Project_Node_Tree_Ref;
- Of_Kind : Project_Node_Kind;
- And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id
- is
- Result : Project_Node_Id;
- Zone : Project_Node_Id;
- Previous : Project_Node_Id;
-
- begin
- -- Create new node with specified kind and expression kind
-
- Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table
- (Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
- (Kind => Of_Kind,
- Qualifier => Unspecified,
- Location => No_Location,
- Directory => No_Path,
- Expr_Kind => And_Expr_Kind,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Display_Name => No_Name,
- Src_Index => 0,
- Path_Name => No_Path,
- Value => No_Name,
- Default => Empty_Value,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Field4 => Empty_Node,
- Flag1 => False,
- Flag2 => False,
- Comments => Empty_Node);
-
- -- Save the new node for the returned value
-
- Result := Project_Node_Table.Last (In_Tree.Project_Nodes);
-
- if Comments.Last > 0 then
-
- -- If this is not a node with comments, then set the flag
-
- if not Node_With_Comments (Of_Kind) then
- Unkept_Comments := True;
-
- elsif Of_Kind /= N_Comment and then Of_Kind /= N_Comment_Zones then
-
- Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table
- (Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
- (Kind => N_Comment_Zones,
- Qualifier => Unspecified,
- Expr_Kind => Undefined,
- Location => No_Location,
- Directory => No_Path,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Display_Name => No_Name,
- Src_Index => 0,
- Path_Name => No_Path,
- Value => No_Name,
- Default => Empty_Value,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Field4 => Empty_Node,
- Flag1 => False,
- Flag2 => False,
- Comments => Empty_Node);
-
- Zone := Project_Node_Table.Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table (Result).Comments := Zone;
- Previous := Empty_Node;
-
- for J in 1 .. Comments.Last loop
-
- -- Create a new N_Comment node
-
- Project_Node_Table.Increment_Last (In_Tree.Project_Nodes);
- In_Tree.Project_Nodes.Table
- (Project_Node_Table.Last (In_Tree.Project_Nodes)) :=
- (Kind => N_Comment,
- Qualifier => Unspecified,
- Expr_Kind => Undefined,
- Flag1 => Comments.Table (J).Follows_Empty_Line,
- Flag2 =>
- Comments.Table (J).Is_Followed_By_Empty_Line,
- Location => No_Location,
- Directory => No_Path,
- Variables => Empty_Node,
- Packages => Empty_Node,
- Pkg_Id => Empty_Package,
- Name => No_Name,
- Display_Name => No_Name,
- Src_Index => 0,
- Path_Name => No_Path,
- Value => Comments.Table (J).Value,
- Default => Empty_Value,
- Field1 => Empty_Node,
- Field2 => Empty_Node,
- Field3 => Empty_Node,
- Field4 => Empty_Node,
- Comments => Empty_Node);
-
- -- Link it to the N_Comment_Zones node, if it is the first,
- -- otherwise to the previous one.
-
- if No (Previous) then
- In_Tree.Project_Nodes.Table (Zone).Field1 :=
- Project_Node_Table.Last (In_Tree.Project_Nodes);
-
- else
- In_Tree.Project_Nodes.Table (Previous).Comments :=
- Project_Node_Table.Last (In_Tree.Project_Nodes);
- end if;
-
- -- This new node will be the previous one for the next
- -- N_Comment node, if there is one.
-
- Previous := Project_Node_Table.Last (In_Tree.Project_Nodes);
- end loop;
-
- -- Empty the Comments table after all comments have been processed
-
- Comments.Set_Last (0);
- end if;
- end if;
-
- return Result;
- end Default_Project_Node;
-
- ------------------
- -- Directory_Of --
- ------------------
-
- function Directory_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Directory;
- end Directory_Of;
-
- -------------------------
- -- End_Of_Line_Comment --
- -------------------------
-
- function End_Of_Line_Comment
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id
- is
- Zone : Project_Node_Id := Empty_Node;
-
- begin
- pragma Assert (Present (Node));
- Zone := In_Tree.Project_Nodes.Table (Node).Comments;
-
- if No (Zone) then
- return No_Name;
- else
- return In_Tree.Project_Nodes.Table (Zone).Value;
- end if;
- end End_Of_Line_Comment;
-
- ------------------------
- -- Expression_Kind_Of --
- ------------------------
-
- function Expression_Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Variable_Kind
- is
- begin
- pragma Assert
- (Present (Node)
- and then -- should use Nkind_In here ??? why not???
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Expression
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Term
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value));
- return In_Tree.Project_Nodes.Table (Node).Expr_Kind;
- end Expression_Kind_Of;
-
- -------------------
- -- Expression_Of --
- -------------------
-
- function Expression_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind =
- N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Variable_Declaration));
-
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end Expression_Of;
-
- -------------------------
- -- Extended_Project_Of --
- -------------------------
-
- function Extended_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Extended_Project_Of;
-
- ------------------------------
- -- Extended_Project_Path_Of --
- ------------------------------
-
- function Extended_Project_Path_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return Path_Name_Type (In_Tree.Project_Nodes.Table (Node).Value);
- end Extended_Project_Path_Of;
-
- --------------------------
- -- Extending_Project_Of --
- --------------------------
- function Extending_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
- return In_Tree.Project_Nodes.Table (Node).Field3;
- end Extending_Project_Of;
-
- ---------------------------
- -- External_Reference_Of --
- ---------------------------
-
- function External_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end External_Reference_Of;
-
- -------------------------
- -- External_Default_Of --
- -------------------------
-
- function External_Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end External_Default_Of;
-
- ------------------------
- -- First_Case_Item_Of --
- ------------------------
-
- function First_Case_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end First_Case_Item_Of;
-
- ---------------------
- -- First_Choice_Of --
- ---------------------
-
- function First_Choice_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end First_Choice_Of;
-
- -------------------------
- -- First_Comment_After --
- -------------------------
-
- function First_Comment_After
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- Zone : Project_Node_Id := Empty_Node;
- begin
- pragma Assert (Present (Node));
- Zone := In_Tree.Project_Nodes.Table (Node).Comments;
-
- if No (Zone) then
- return Empty_Node;
-
- else
- return In_Tree.Project_Nodes.Table (Zone).Field2;
- end if;
- end First_Comment_After;
-
- -----------------------------
- -- First_Comment_After_End --
- -----------------------------
-
- function First_Comment_After_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- return Project_Node_Id
- is
- Zone : Project_Node_Id := Empty_Node;
-
- begin
- pragma Assert (Present (Node));
- Zone := In_Tree.Project_Nodes.Table (Node).Comments;
-
- if No (Zone) then
- return Empty_Node;
-
- else
- return In_Tree.Project_Nodes.Table (Zone).Comments;
- end if;
- end First_Comment_After_End;
-
- --------------------------
- -- First_Comment_Before --
- --------------------------
-
- function First_Comment_Before
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- Zone : Project_Node_Id := Empty_Node;
-
- begin
- pragma Assert (Present (Node));
- Zone := In_Tree.Project_Nodes.Table (Node).Comments;
-
- if No (Zone) then
- return Empty_Node;
-
- else
- return In_Tree.Project_Nodes.Table (Zone).Field1;
- end if;
- end First_Comment_Before;
-
- ------------------------------
- -- First_Comment_Before_End --
- ------------------------------
-
- function First_Comment_Before_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- Zone : Project_Node_Id := Empty_Node;
-
- begin
- pragma Assert (Present (Node));
- Zone := In_Tree.Project_Nodes.Table (Node).Comments;
-
- if No (Zone) then
- return Empty_Node;
-
- else
- return In_Tree.Project_Nodes.Table (Zone).Field3;
- end if;
- end First_Comment_Before_End;
-
- -------------------------------
- -- First_Declarative_Item_Of --
- -------------------------------
-
- function First_Declarative_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
-
- if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then
- return In_Tree.Project_Nodes.Table (Node).Field1;
- else
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end if;
- end First_Declarative_Item_Of;
-
- ------------------------------
- -- First_Expression_In_List --
- ------------------------------
-
- function First_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end First_Expression_In_List;
-
- --------------------------
- -- First_Literal_String --
- --------------------------
-
- function First_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_String_Type_Declaration);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end First_Literal_String;
-
- ----------------------
- -- First_Package_Of --
- ----------------------
-
- function First_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Packages;
- end First_Package_Of;
-
- --------------------------
- -- First_String_Type_Of --
- --------------------------
-
- function First_String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Field3;
- end First_String_Type_Of;
-
- ----------------
- -- First_Term --
- ----------------
-
- function First_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end First_Term;
-
- -----------------------
- -- First_Variable_Of --
- -----------------------
-
- function First_Variable_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
-
- return In_Tree.Project_Nodes.Table (Node).Variables;
- end First_Variable_Of;
-
- --------------------------
- -- First_With_Clause_Of --
- --------------------------
-
- function First_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end First_With_Clause_Of;
-
- ------------------------
- -- Follows_Empty_Line --
- ------------------------
-
- function Follows_Empty_Line
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
- return In_Tree.Project_Nodes.Table (Node).Flag1;
- end Follows_Empty_Line;
-
- ----------
- -- Hash --
- ----------
-
- function Hash (N : Project_Node_Id) return Header_Num is
- begin
- return Header_Num (N mod Project_Node_Id (Header_Num'Last));
- end Hash;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Tree : Project_Node_Tree_Ref) is
- begin
- Project_Node_Table.Init (Tree.Project_Nodes);
- Projects_Htable.Reset (Tree.Projects_HT);
- end Initialize;
-
- --------------------
- -- Override_Flags --
- --------------------
-
- procedure Override_Flags
- (Self : in out Environment;
- Flags : Prj.Processing_Flags)
- is
- begin
- Self.Flags := Flags;
- end Override_Flags;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Self : out Environment;
- Flags : Processing_Flags)
- is
- begin
- -- Do not reset the external references, in case we are reloading a
- -- project, since we want to preserve the current environment. But we
- -- still need to ensure that the external references are properly
- -- initialized.
-
- Prj.Ext.Initialize (Self.External);
-
- Self.Flags := Flags;
- end Initialize;
-
- -------------------------
- -- Initialize_And_Copy --
- -------------------------
-
- procedure Initialize_And_Copy
- (Self : out Environment;
- Copy_From : Environment)
- is
- begin
- Self.Flags := Copy_From.Flags;
- Prj.Ext.Initialize (Self.External, Copy_From => Copy_From.External);
- Prj.Env.Copy (From => Copy_From.Project_Path, To => Self.Project_Path);
- end Initialize_And_Copy;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Self : in out Environment) is
- begin
- Prj.Ext.Free (Self.External);
- Free (Self.Project_Path);
- end Free;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Proj : in out Project_Node_Tree_Ref) is
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Project_Node_Tree_Data, Project_Node_Tree_Ref);
- begin
- if Proj /= null then
- Project_Node_Table.Free (Proj.Project_Nodes);
- Projects_Htable.Reset (Proj.Projects_HT);
- Unchecked_Free (Proj);
- end if;
- end Free;
-
- -------------------------------
- -- Is_Followed_By_Empty_Line --
- -------------------------------
-
- function Is_Followed_By_Empty_Line
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
- return In_Tree.Project_Nodes.Table (Node).Flag2;
- end Is_Followed_By_Empty_Line;
-
- ----------------------
- -- Is_Extending_All --
- ----------------------
-
- function Is_Extending_All
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
- return In_Tree.Project_Nodes.Table (Node).Flag2;
- end Is_Extending_All;
-
- -------------------------
- -- Is_Not_Last_In_List --
- -------------------------
-
- function Is_Not_Last_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
- return In_Tree.Project_Nodes.Table (Node).Flag1;
- end Is_Not_Last_In_List;
-
- -------------------------------------
- -- Imported_Or_Extended_Project_Of --
- -------------------------------------
-
- function Imported_Or_Extended_Project_Of
- (Project : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- With_Name : Name_Id) return Project_Node_Id
- is
- With_Clause : Project_Node_Id;
- Result : Project_Node_Id := Empty_Node;
- Decl : Project_Node_Id;
-
- begin
- -- First check all the imported projects
-
- With_Clause := First_With_Clause_Of (Project, In_Tree);
- while Present (With_Clause) loop
-
- -- Only non limited imported project may be used as prefix of
- -- variables or attributes.
-
- Result := Non_Limited_Project_Node_Of (With_Clause, In_Tree);
- while Present (Result) loop
- if Name_Of (Result, In_Tree) = With_Name then
- return Result;
- end if;
-
- Decl := Project_Declaration_Of (Result, In_Tree);
-
- -- Do not try to check for an extended project, if the project
- -- does not have yet a project declaration.
-
- exit when Decl = Empty_Node;
-
- Result := Extended_Project_Of (Decl, In_Tree);
- end loop;
-
- With_Clause := Next_With_Clause_Of (With_Clause, In_Tree);
- end loop;
-
- -- If it is not an imported project, it might be an extended project
-
- if No (With_Clause) then
- Result := Project;
- loop
- Result :=
- Extended_Project_Of
- (Project_Declaration_Of (Result, In_Tree), In_Tree);
-
- exit when No (Result)
- or else Name_Of (Result, In_Tree) = With_Name;
- end loop;
- end if;
-
- return Result;
- end Imported_Or_Extended_Project_Of;
-
- -------------
- -- Kind_Of --
- -------------
-
- function Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind
- is
- begin
- pragma Assert (Present (Node));
- return In_Tree.Project_Nodes.Table (Node).Kind;
- end Kind_Of;
-
- -----------------
- -- Location_Of --
- -----------------
-
- function Location_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Source_Ptr
- is
- begin
- pragma Assert (Present (Node));
- return In_Tree.Project_Nodes.Table (Node).Location;
- end Location_Of;
-
- -------------
- -- Name_Of --
- -------------
-
- function Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id
- is
- begin
- pragma Assert (Present (Node));
- return In_Tree.Project_Nodes.Table (Node).Name;
- end Name_Of;
-
- ---------------------
- -- Display_Name_Of --
- ---------------------
-
- function Display_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Display_Name;
- end Display_Name_Of;
-
- --------------------
- -- Next_Case_Item --
- --------------------
-
- function Next_Case_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
- return In_Tree.Project_Nodes.Table (Node).Field3;
- end Next_Case_Item;
-
- ------------------
- -- Next_Comment --
- ------------------
-
- function Next_Comment
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
- return In_Tree.Project_Nodes.Table (Node).Comments;
- end Next_Comment;
-
- ---------------------------
- -- Next_Declarative_Item --
- ---------------------------
-
- function Next_Declarative_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Next_Declarative_Item;
-
- -----------------------------
- -- Next_Expression_In_List --
- -----------------------------
-
- function Next_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Next_Expression_In_List;
-
- -------------------------
- -- Next_Literal_String --
- -------------------------
-
- function Next_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end Next_Literal_String;
-
- -----------------------------
- -- Next_Package_In_Project --
- -----------------------------
-
- function Next_Package_In_Project
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
- return In_Tree.Project_Nodes.Table (Node).Field3;
- end Next_Package_In_Project;
-
- ----------------------
- -- Next_String_Type --
- ----------------------
-
- function Next_String_Type
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_String_Type_Declaration);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Next_String_Type;
-
- ---------------
- -- Next_Term --
- ---------------
-
- function Next_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Next_Term;
-
- -------------------
- -- Next_Variable --
- -------------------
-
- function Next_Variable
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Variable_Declaration));
-
- return In_Tree.Project_Nodes.Table (Node).Field3;
- end Next_Variable;
-
- -------------------------
- -- Next_With_Clause_Of --
- -------------------------
-
- function Next_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Next_With_Clause_Of;
-
- --------
- -- No --
- --------
-
- function No (Node : Project_Node_Id) return Boolean is
- begin
- return Node = Empty_Node;
- end No;
-
- ---------------------------------
- -- Non_Limited_Project_Node_Of --
- ---------------------------------
-
- function Non_Limited_Project_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
- return In_Tree.Project_Nodes.Table (Node).Field3;
- end Non_Limited_Project_Node_Of;
-
- -------------------
- -- Package_Id_Of --
- -------------------
-
- function Package_Id_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Package_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
- return In_Tree.Project_Nodes.Table (Node).Pkg_Id;
- end Package_Id_Of;
-
- ---------------------
- -- Package_Node_Of --
- ---------------------
-
- function Package_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Package_Node_Of;
-
- ------------------
- -- Path_Name_Of --
- ------------------
-
- function Path_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Path_Name_Type
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
- return In_Tree.Project_Nodes.Table (Node).Path_Name;
- end Path_Name_Of;
-
- -------------
- -- Present --
- -------------
-
- function Present (Node : Project_Node_Id) return Boolean is
- begin
- return Node /= Empty_Node;
- end Present;
-
- ----------------------------
- -- Project_Declaration_Of --
- ----------------------------
-
- function Project_Declaration_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end Project_Declaration_Of;
-
- --------------------------
- -- Project_Qualifier_Of --
- --------------------------
-
- function Project_Qualifier_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Qualifier
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Qualifier;
- end Project_Qualifier_Of;
-
- -----------------------
- -- Parent_Project_Of --
- -----------------------
-
- function Parent_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- return In_Tree.Project_Nodes.Table (Node).Field4;
- end Parent_Project_Of;
-
- -------------------------------------------
- -- Project_File_Includes_Unkept_Comments --
- -------------------------------------------
-
- function Project_File_Includes_Unkept_Comments
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean
- is
- Declaration : constant Project_Node_Id :=
- Project_Declaration_Of (Node, In_Tree);
- begin
- return In_Tree.Project_Nodes.Table (Declaration).Flag1;
- end Project_File_Includes_Unkept_Comments;
-
- ---------------------
- -- Project_Node_Of --
- ---------------------
-
- function Project_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end Project_Node_Of;
-
- -----------------------------------
- -- Project_Of_Renamed_Package_Of --
- -----------------------------------
-
- function Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
- return In_Tree.Project_Nodes.Table (Node).Field1;
- end Project_Of_Renamed_Package_Of;
-
- --------------------------
- -- Remove_Next_End_Node --
- --------------------------
-
- procedure Remove_Next_End_Node is
- begin
- Next_End_Nodes.Decrement_Last;
- end Remove_Next_End_Node;
-
- -----------------
- -- Reset_State --
- -----------------
-
- procedure Reset_State is
- begin
- End_Of_Line_Node := Empty_Node;
- Previous_Line_Node := Empty_Node;
- Previous_End_Node := Empty_Node;
- Unkept_Comments := False;
- Comments.Set_Last (0);
- end Reset_State;
-
- ----------------------
- -- Restore_And_Free --
- ----------------------
-
- procedure Restore_And_Free (S : in out Comment_State) is
- procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation (Comment_Array, Comments_Ptr);
-
- begin
- End_Of_Line_Node := S.End_Of_Line_Node;
- Previous_Line_Node := S.Previous_Line_Node;
- Previous_End_Node := S.Previous_End_Node;
- Next_End_Nodes.Set_Last (0);
- Unkept_Comments := S.Unkept_Comments;
-
- Comments.Set_Last (0);
-
- for J in S.Comments'Range loop
- Comments.Increment_Last;
- Comments.Table (Comments.Last) := S.Comments (J);
- end loop;
-
- Unchecked_Free (S.Comments);
- end Restore_And_Free;
-
- ----------
- -- Save --
- ----------
-
- procedure Save (S : out Comment_State) is
- Cmts : constant Comments_Ptr := new Comment_Array (1 .. Comments.Last);
-
- begin
- for J in 1 .. Comments.Last loop
- Cmts (J) := Comments.Table (J);
- end loop;
-
- S :=
- (End_Of_Line_Node => End_Of_Line_Node,
- Previous_Line_Node => Previous_Line_Node,
- Previous_End_Node => Previous_End_Node,
- Unkept_Comments => Unkept_Comments,
- Comments => Cmts);
- end Save;
-
- ----------
- -- Scan --
- ----------
-
- procedure Scan (In_Tree : Project_Node_Tree_Ref) is
- Empty_Line : Boolean := False;
-
- begin
- -- If there are comments, then they will not be kept. Set the flag and
- -- clear the comments.
-
- if Comments.Last > 0 then
- Unkept_Comments := True;
- Comments.Set_Last (0);
- end if;
-
- -- Loop until a token other that End_Of_Line or Comment is found
-
- loop
- Prj.Err.Scanner.Scan;
-
- case Token is
- when Tok_End_Of_Line =>
- if Prev_Token = Tok_End_Of_Line then
- Empty_Line := True;
-
- if Comments.Last > 0 then
- Comments.Table (Comments.Last).Is_Followed_By_Empty_Line
- := True;
- end if;
- end if;
-
- when Tok_Comment =>
- -- If this is a line comment, add it to the comment table
-
- if Prev_Token = Tok_End_Of_Line
- or else Prev_Token = No_Token
- then
- Comments.Increment_Last;
- Comments.Table (Comments.Last) :=
- (Value => Comment_Id,
- Follows_Empty_Line => Empty_Line,
- Is_Followed_By_Empty_Line => False);
-
- -- Otherwise, it is an end of line comment. If there is an
- -- end of line node specified, associate the comment with
- -- this node.
-
- elsif Present (End_Of_Line_Node) then
- declare
- Zones : constant Project_Node_Id :=
- Comment_Zones_Of (End_Of_Line_Node, In_Tree);
- begin
- In_Tree.Project_Nodes.Table (Zones).Value := Comment_Id;
- end;
-
- -- Otherwise, this end of line node cannot be kept
-
- else
- Unkept_Comments := True;
- Comments.Set_Last (0);
- end if;
-
- Empty_Line := False;
-
- when others =>
-
- -- If there are comments, where the first comment is not
- -- following an empty line, put the initial uninterrupted
- -- comment zone with the node of the preceding line (either
- -- a Previous_Line or a Previous_End node), if any.
-
- if Comments.Last > 0
- and then not Comments.Table (1).Follows_Empty_Line
- then
- if Present (Previous_Line_Node) then
- Add_Comments
- (To => Previous_Line_Node,
- Where => After,
- In_Tree => In_Tree);
-
- elsif Present (Previous_End_Node) then
- Add_Comments
- (To => Previous_End_Node,
- Where => After_End,
- In_Tree => In_Tree);
- end if;
- end if;
-
- -- If there are still comments and the token is "end", then
- -- put these comments with the Next_End node, if any;
- -- otherwise, these comments cannot be kept. Always clear
- -- the comments.
-
- if Comments.Last > 0 and then Token = Tok_End then
- if Next_End_Nodes.Last > 0 then
- Add_Comments
- (To => Next_End_Nodes.Table (Next_End_Nodes.Last),
- Where => Before_End,
- In_Tree => In_Tree);
-
- else
- Unkept_Comments := True;
- end if;
-
- Comments.Set_Last (0);
- end if;
-
- -- Reset the End_Of_Line, Previous_Line and Previous_End nodes
- -- so that they are not used again.
-
- End_Of_Line_Node := Empty_Node;
- Previous_Line_Node := Empty_Node;
- Previous_End_Node := Empty_Node;
-
- -- And return
-
- exit;
- end case;
- end loop;
- end Scan;
-
- ------------------------------------
- -- Set_Associative_Array_Index_Of --
- ------------------------------------
-
- procedure Set_Associative_Array_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- In_Tree.Project_Nodes.Table (Node).Value := To;
- end Set_Associative_Array_Index_Of;
-
- --------------------------------
- -- Set_Associative_Package_Of --
- --------------------------------
-
- procedure Set_Associative_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration);
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- end Set_Associative_Package_Of;
-
- --------------------------------
- -- Set_Associative_Project_Of --
- --------------------------------
-
- procedure Set_Associative_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind =
- N_Attribute_Declaration));
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Associative_Project_Of;
-
- --------------------------
- -- Set_Case_Insensitive --
- --------------------------
-
- procedure Set_Case_Insensitive
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Boolean)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- In_Tree.Project_Nodes.Table (Node).Flag1 := To;
- end Set_Case_Insensitive;
-
- ------------------------------------
- -- Set_Case_Variable_Reference_Of --
- ------------------------------------
-
- procedure Set_Case_Variable_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_Case_Variable_Reference_Of;
-
- ---------------------------
- -- Set_Current_Item_Node --
- ---------------------------
-
- procedure Set_Current_Item_Node
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_Current_Item_Node;
-
- ----------------------
- -- Set_Current_Term --
- ----------------------
-
- procedure Set_Current_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_Current_Term;
-
- --------------------
- -- Set_Default_Of --
- --------------------
-
- procedure Set_Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Attribute_Default_Value)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference);
- In_Tree.Project_Nodes.Table (Node).Default := To;
- end Set_Default_Of;
-
- ----------------------
- -- Set_Directory_Of --
- ----------------------
-
- procedure Set_Directory_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Path_Name_Type)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Directory := To;
- end Set_Directory_Of;
-
- ---------------------
- -- Set_End_Of_Line --
- ---------------------
-
- procedure Set_End_Of_Line (To : Project_Node_Id) is
- begin
- End_Of_Line_Node := To;
- end Set_End_Of_Line;
-
- ----------------------------
- -- Set_Expression_Kind_Of --
- ----------------------------
-
- procedure Set_Expression_Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Variable_Kind)
- is
- begin
- pragma Assert
- (Present (Node)
- and then -- should use Nkind_In here ??? why not???
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Expression
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Term
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value));
- In_Tree.Project_Nodes.Table (Node).Expr_Kind := To;
- end Set_Expression_Kind_Of;
-
- -----------------------
- -- Set_Expression_Of --
- -----------------------
-
- procedure Set_Expression_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind =
- N_Attribute_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Variable_Declaration));
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_Expression_Of;
-
- -------------------------------
- -- Set_External_Reference_Of --
- -------------------------------
-
- procedure Set_External_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_External_Reference_Of;
-
- -----------------------------
- -- Set_External_Default_Of --
- -----------------------------
-
- procedure Set_External_Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_External_Value);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_External_Default_Of;
-
- ----------------------------
- -- Set_First_Case_Item_Of --
- ----------------------------
-
- procedure Set_First_Case_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Construction);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_First_Case_Item_Of;
-
- -------------------------
- -- Set_First_Choice_Of --
- -------------------------
-
- procedure Set_First_Choice_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_First_Choice_Of;
-
- -----------------------------
- -- Set_First_Comment_After --
- -----------------------------
-
- procedure Set_First_Comment_After
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
- begin
- In_Tree.Project_Nodes.Table (Zone).Field2 := To;
- end Set_First_Comment_After;
-
- ---------------------------------
- -- Set_First_Comment_After_End --
- ---------------------------------
-
- procedure Set_First_Comment_After_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
- begin
- In_Tree.Project_Nodes.Table (Zone).Comments := To;
- end Set_First_Comment_After_End;
-
- ------------------------------
- -- Set_First_Comment_Before --
- ------------------------------
-
- procedure Set_First_Comment_Before
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
- begin
- In_Tree.Project_Nodes.Table (Zone).Field1 := To;
- end Set_First_Comment_Before;
-
- ----------------------------------
- -- Set_First_Comment_Before_End --
- ----------------------------------
-
- procedure Set_First_Comment_Before_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- Zone : constant Project_Node_Id := Comment_Zones_Of (Node, In_Tree);
- begin
- In_Tree.Project_Nodes.Table (Zone).Field2 := To;
- end Set_First_Comment_Before_End;
-
- ------------------------
- -- Set_Next_Case_Item --
- ------------------------
-
- procedure Set_Next_Case_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item);
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- end Set_Next_Case_Item;
-
- ----------------------
- -- Set_Next_Comment --
- ----------------------
-
- procedure Set_Next_Comment
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Comment);
- In_Tree.Project_Nodes.Table (Node).Comments := To;
- end Set_Next_Comment;
-
- -----------------------------------
- -- Set_First_Declarative_Item_Of --
- -----------------------------------
-
- procedure Set_First_Declarative_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Case_Item
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
-
- if In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration then
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- else
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end if;
- end Set_First_Declarative_Item_Of;
-
- ----------------------------------
- -- Set_First_Expression_In_List --
- ----------------------------------
-
- procedure Set_First_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String_List);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_First_Expression_In_List;
-
- ------------------------------
- -- Set_First_Literal_String --
- ------------------------------
-
- procedure Set_First_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_String_Type_Declaration);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_First_Literal_String;
-
- --------------------------
- -- Set_First_Package_Of --
- --------------------------
-
- procedure Set_First_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Package_Declaration_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Packages := To;
- end Set_First_Package_Of;
-
- ------------------------------
- -- Set_First_String_Type_Of --
- ------------------------------
-
- procedure Set_First_String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- end Set_First_String_Type_Of;
-
- --------------------
- -- Set_First_Term --
- --------------------
-
- procedure Set_First_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_First_Term;
-
- ---------------------------
- -- Set_First_Variable_Of --
- ---------------------------
-
- procedure Set_First_Variable_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Variable_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration));
- In_Tree.Project_Nodes.Table (Node).Variables := To;
- end Set_First_Variable_Of;
-
- ------------------------------
- -- Set_First_With_Clause_Of --
- ------------------------------
-
- procedure Set_First_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_First_With_Clause_Of;
-
- --------------------------
- -- Set_Is_Extending_All --
- --------------------------
-
- procedure Set_Is_Extending_All
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
- In_Tree.Project_Nodes.Table (Node).Flag2 := True;
- end Set_Is_Extending_All;
-
- -----------------------------
- -- Set_Is_Not_Last_In_List --
- -----------------------------
-
- procedure Set_Is_Not_Last_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- is
- begin
- pragma Assert
- (Present (Node)
- and then In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
- In_Tree.Project_Nodes.Table (Node).Flag1 := True;
- end Set_Is_Not_Last_In_List;
-
- -----------------
- -- Set_Kind_Of --
- -----------------
-
- procedure Set_Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Kind)
- is
- begin
- pragma Assert (Present (Node));
- In_Tree.Project_Nodes.Table (Node).Kind := To;
- end Set_Kind_Of;
-
- ---------------------
- -- Set_Location_Of --
- ---------------------
-
- procedure Set_Location_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Source_Ptr)
- is
- begin
- pragma Assert (Present (Node));
- In_Tree.Project_Nodes.Table (Node).Location := To;
- end Set_Location_Of;
-
- -----------------------------
- -- Set_Extended_Project_Of --
- -----------------------------
-
- procedure Set_Extended_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Extended_Project_Of;
-
- ----------------------------------
- -- Set_Extended_Project_Path_Of --
- ----------------------------------
-
- procedure Set_Extended_Project_Path_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Path_Name_Type)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Value := Name_Id (To);
- end Set_Extended_Project_Path_Of;
-
- ------------------------------
- -- Set_Extending_Project_Of --
- ------------------------------
-
- procedure Set_Extending_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project_Declaration);
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- end Set_Extending_Project_Of;
-
- -----------------
- -- Set_Name_Of --
- -----------------
-
- procedure Set_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id)
- is
- begin
- pragma Assert (Present (Node));
- In_Tree.Project_Nodes.Table (Node).Name := To;
- end Set_Name_Of;
-
- -------------------------
- -- Set_Display_Name_Of --
- -------------------------
-
- procedure Set_Display_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Display_Name := To;
- end Set_Display_Name_Of;
-
- -------------------------------
- -- Set_Next_Declarative_Item --
- -------------------------------
-
- procedure Set_Next_Declarative_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Declarative_Item);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Next_Declarative_Item;
-
- -----------------------
- -- Set_Next_End_Node --
- -----------------------
-
- procedure Set_Next_End_Node (To : Project_Node_Id) is
- begin
- Next_End_Nodes.Increment_Last;
- Next_End_Nodes.Table (Next_End_Nodes.Last) := To;
- end Set_Next_End_Node;
-
- ---------------------------------
- -- Set_Next_Expression_In_List --
- ---------------------------------
-
- procedure Set_Next_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Expression);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Next_Expression_In_List;
-
- -----------------------------
- -- Set_Next_Literal_String --
- -----------------------------
-
- procedure Set_Next_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_Next_Literal_String;
-
- ---------------------------------
- -- Set_Next_Package_In_Project --
- ---------------------------------
-
- procedure Set_Next_Package_In_Project
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- end Set_Next_Package_In_Project;
-
- --------------------------
- -- Set_Next_String_Type --
- --------------------------
-
- procedure Set_Next_String_Type
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_String_Type_Declaration);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Next_String_Type;
-
- -------------------
- -- Set_Next_Term --
- -------------------
-
- procedure Set_Next_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Term);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Next_Term;
-
- -----------------------
- -- Set_Next_Variable --
- -----------------------
-
- procedure Set_Next_Variable
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Variable_Declaration));
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- end Set_Next_Variable;
-
- -----------------------------
- -- Set_Next_With_Clause_Of --
- -----------------------------
-
- procedure Set_Next_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Next_With_Clause_Of;
-
- -----------------------
- -- Set_Package_Id_Of --
- -----------------------
-
- procedure Set_Package_Id_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Package_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
- In_Tree.Project_Nodes.Table (Node).Pkg_Id := To;
- end Set_Package_Id_Of;
-
- -------------------------
- -- Set_Package_Node_Of --
- -------------------------
-
- procedure Set_Package_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Package_Node_Of;
-
- ----------------------
- -- Set_Path_Name_Of --
- ----------------------
-
- procedure Set_Path_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Path_Name_Type)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Project
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause));
- In_Tree.Project_Nodes.Table (Node).Path_Name := To;
- end Set_Path_Name_Of;
-
- ---------------------------
- -- Set_Previous_End_Node --
- ---------------------------
- procedure Set_Previous_End_Node (To : Project_Node_Id) is
- begin
- Previous_End_Node := To;
- end Set_Previous_End_Node;
-
- ----------------------------
- -- Set_Previous_Line_Node --
- ----------------------------
-
- procedure Set_Previous_Line_Node (To : Project_Node_Id) is
- begin
- Previous_Line_Node := To;
- end Set_Previous_Line_Node;
-
- --------------------------------
- -- Set_Project_Declaration_Of --
- --------------------------------
-
- procedure Set_Project_Declaration_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end Set_Project_Declaration_Of;
-
- ------------------------------
- -- Set_Project_Qualifier_Of --
- ------------------------------
-
- procedure Set_Project_Qualifier_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Qualifier)
- is
- begin
- pragma Assert
- (Present (Node)
- and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Qualifier := To;
- end Set_Project_Qualifier_Of;
-
- ---------------------------
- -- Set_Parent_Project_Of --
- ---------------------------
-
- procedure Set_Parent_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
- In_Tree.Project_Nodes.Table (Node).Field4 := To;
- end Set_Parent_Project_Of;
-
- -----------------------------------------------
- -- Set_Project_File_Includes_Unkept_Comments --
- -----------------------------------------------
-
- procedure Set_Project_File_Includes_Unkept_Comments
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Boolean)
- is
- Declaration : constant Project_Node_Id :=
- Project_Declaration_Of (Node, In_Tree);
- begin
- In_Tree.Project_Nodes.Table (Declaration).Flag1 := To;
- end Set_Project_File_Includes_Unkept_Comments;
-
- -------------------------
- -- Set_Project_Node_Of --
- -------------------------
-
- procedure Set_Project_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id;
- Limited_With : Boolean := False)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Attribute_Reference));
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
-
- if In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
- and then not Limited_With
- then
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- end if;
- end Set_Project_Node_Of;
-
- ---------------------------------------
- -- Set_Project_Of_Renamed_Package_Of --
- ---------------------------------------
-
- procedure Set_Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Package_Declaration);
- In_Tree.Project_Nodes.Table (Node).Field1 := To;
- end Set_Project_Of_Renamed_Package_Of;
-
- -------------------------
- -- Set_Source_Index_Of --
- -------------------------
-
- procedure Set_Source_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Int)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Attribute_Declaration));
- In_Tree.Project_Nodes.Table (Node).Src_Index := To;
- end Set_Source_Index_Of;
-
- ------------------------
- -- Set_String_Type_Of --
- ------------------------
-
- procedure Set_String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind =
- N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration)
- and then
- In_Tree.Project_Nodes.Table (To).Kind = N_String_Type_Declaration);
-
- if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then
- In_Tree.Project_Nodes.Table (Node).Field3 := To;
- else
- In_Tree.Project_Nodes.Table (Node).Field2 := To;
- end if;
- end Set_String_Type_Of;
-
- -------------------------
- -- Set_String_Value_Of --
- -------------------------
-
- procedure Set_String_Value_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id)
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Comment
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String));
- In_Tree.Project_Nodes.Table (Node).Value := To;
- end Set_String_Value_Of;
-
- ---------------------
- -- Source_Index_Of --
- ---------------------
-
- function Source_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Int
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Attribute_Declaration));
- return In_Tree.Project_Nodes.Table (Node).Src_Index;
- end Source_Index_Of;
-
- --------------------
- -- String_Type_Of --
- --------------------
-
- function String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind =
- N_Variable_Reference
- or else
- In_Tree.Project_Nodes.Table (Node).Kind =
- N_Typed_Variable_Declaration));
-
- if In_Tree.Project_Nodes.Table (Node).Kind = N_Variable_Reference then
- return In_Tree.Project_Nodes.Table (Node).Field3;
- else
- return In_Tree.Project_Nodes.Table (Node).Field2;
- end if;
- end String_Type_Of;
-
- ---------------------
- -- String_Value_Of --
- ---------------------
-
- function String_Value_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id
- is
- begin
- pragma Assert
- (Present (Node)
- and then
- (In_Tree.Project_Nodes.Table (Node).Kind = N_With_Clause
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Comment
- or else
- In_Tree.Project_Nodes.Table (Node).Kind = N_Literal_String));
- return In_Tree.Project_Nodes.Table (Node).Value;
- end String_Value_Of;
-
- --------------------
- -- Value_Is_Valid --
- --------------------
-
- function Value_Is_Valid
- (For_Typed_Variable : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Value : Name_Id) return Boolean
- is
- begin
- pragma Assert
- (Present (For_Typed_Variable)
- and then
- (In_Tree.Project_Nodes.Table (For_Typed_Variable).Kind =
- N_Typed_Variable_Declaration));
-
- declare
- Current_String : Project_Node_Id :=
- First_Literal_String
- (String_Type_Of (For_Typed_Variable, In_Tree),
- In_Tree);
-
- begin
- while Present (Current_String)
- and then
- String_Value_Of (Current_String, In_Tree) /= Value
- loop
- Current_String :=
- Next_Literal_String (Current_String, In_Tree);
- end loop;
-
- return Present (Current_String);
- end;
-
- end Value_Is_Valid;
-
- -------------------------------
- -- There_Are_Unkept_Comments --
- -------------------------------
-
- function There_Are_Unkept_Comments return Boolean is
- begin
- return Unkept_Comments;
- end There_Are_Unkept_Comments;
-
- --------------------
- -- Create_Project --
- --------------------
-
- function Create_Project
- (In_Tree : Project_Node_Tree_Ref;
- Name : Name_Id;
- Full_Path : Path_Name_Type;
- Is_Config_File : Boolean := False) return Project_Node_Id
- is
- Project : Project_Node_Id;
- Qualifier : Project_Qualifier := Unspecified;
- begin
- Project := Default_Project_Node (In_Tree, N_Project);
- Set_Name_Of (Project, In_Tree, Name);
- Set_Display_Name_Of (Project, In_Tree, Name);
- Set_Directory_Of
- (Project, In_Tree,
- Path_Name_Type (Get_Directory (File_Name_Type (Full_Path))));
- Set_Path_Name_Of (Project, In_Tree, Full_Path);
-
- Set_Project_Declaration_Of
- (Project, In_Tree,
- Default_Project_Node (In_Tree, N_Project_Declaration));
-
- if Is_Config_File then
- Qualifier := Configuration;
- end if;
-
- if not Is_Config_File then
- Prj.Tree.Tree_Private_Part.Projects_Htable.Set
- (In_Tree.Projects_HT,
- Name,
- Prj.Tree.Tree_Private_Part.Project_Name_And_Node'
- (Name => Name,
- Resolved_Path => No_Path,
- Node => Project,
- Extended => False,
- From_Extended => False,
- Proj_Qualifier => Qualifier));
- end if;
-
- return Project;
- end Create_Project;
-
- ----------------
- -- Add_At_End --
- ----------------
-
- procedure Add_At_End
- (Tree : Project_Node_Tree_Ref;
- Parent : Project_Node_Id;
- Expr : Project_Node_Id;
- Add_Before_First_Pkg : Boolean := False;
- Add_Before_First_Case : Boolean := False)
- is
- Real_Parent : Project_Node_Id;
- New_Decl, Decl, Next : Project_Node_Id;
- Last, L : Project_Node_Id;
-
- begin
- if Kind_Of (Expr, Tree) /= N_Declarative_Item then
- New_Decl := Default_Project_Node (Tree, N_Declarative_Item);
- Set_Current_Item_Node (New_Decl, Tree, Expr);
- else
- New_Decl := Expr;
- end if;
-
- if Kind_Of (Parent, Tree) = N_Project then
- Real_Parent := Project_Declaration_Of (Parent, Tree);
- else
- Real_Parent := Parent;
- end if;
-
- Decl := First_Declarative_Item_Of (Real_Parent, Tree);
-
- if Decl = Empty_Node then
- Set_First_Declarative_Item_Of (Real_Parent, Tree, New_Decl);
- else
- loop
- Next := Next_Declarative_Item (Decl, Tree);
- exit when Next = Empty_Node
- or else
- (Add_Before_First_Pkg
- and then Kind_Of (Current_Item_Node (Next, Tree), Tree) =
- N_Package_Declaration)
- or else
- (Add_Before_First_Case
- and then Kind_Of (Current_Item_Node (Next, Tree), Tree) =
- N_Case_Construction);
- Decl := Next;
- end loop;
-
- -- In case Expr is in fact a range of declarative items
-
- Last := New_Decl;
- loop
- L := Next_Declarative_Item (Last, Tree);
- exit when L = Empty_Node;
- Last := L;
- end loop;
-
- -- In case Expr is in fact a range of declarative items
-
- Last := New_Decl;
- loop
- L := Next_Declarative_Item (Last, Tree);
- exit when L = Empty_Node;
- Last := L;
- end loop;
-
- Set_Next_Declarative_Item (Last, Tree, Next);
- Set_Next_Declarative_Item (Decl, Tree, New_Decl);
- end if;
- end Add_At_End;
-
- ---------------------------
- -- Create_Literal_String --
- ---------------------------
-
- function Create_Literal_String
- (Str : Namet.Name_Id;
- Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- Node : Project_Node_Id;
- begin
- Node := Default_Project_Node (Tree, N_Literal_String, Prj.Single);
- Set_Next_Literal_String (Node, Tree, Empty_Node);
- Set_String_Value_Of (Node, Tree, Str);
- return Node;
- end Create_Literal_String;
-
- ---------------------------
- -- Enclose_In_Expression --
- ---------------------------
-
- function Enclose_In_Expression
- (Node : Project_Node_Id;
- Tree : Project_Node_Tree_Ref) return Project_Node_Id
- is
- Expr : Project_Node_Id;
- begin
- if Kind_Of (Node, Tree) /= N_Expression then
- Expr := Default_Project_Node (Tree, N_Expression, Single);
- Set_First_Term
- (Expr, Tree, Default_Project_Node (Tree, N_Term, Single));
- Set_Current_Term (First_Term (Expr, Tree), Tree, Node);
- return Expr;
- else
- return Node;
- end if;
- end Enclose_In_Expression;
-
- --------------------
- -- Create_Package --
- --------------------
-
- function Create_Package
- (Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id;
- Pkg : String) return Project_Node_Id
- is
- Pack : Project_Node_Id;
- N : Name_Id;
-
- begin
- Name_Len := Pkg'Length;
- Name_Buffer (1 .. Name_Len) := Pkg;
- N := Name_Find;
-
- -- Check if the package already exists
-
- Pack := First_Package_Of (Project, Tree);
- while Pack /= Empty_Node loop
- if Prj.Tree.Name_Of (Pack, Tree) = N then
- return Pack;
- end if;
-
- Pack := Next_Package_In_Project (Pack, Tree);
- end loop;
-
- -- Create the package and add it to the declarative item
-
- Pack := Default_Project_Node (Tree, N_Package_Declaration);
- Set_Name_Of (Pack, Tree, N);
-
- -- Find the correct package id to use
-
- Set_Package_Id_Of (Pack, Tree, Package_Node_Id_Of (N));
-
- -- Add it to the list of packages
-
- Set_Next_Package_In_Project
- (Pack, Tree, First_Package_Of (Project, Tree));
- Set_First_Package_Of (Project, Tree, Pack);
-
- Add_At_End (Tree, Project_Declaration_Of (Project, Tree), Pack);
-
- return Pack;
- end Create_Package;
-
- ----------------------
- -- Create_Attribute --
- ----------------------
-
- function Create_Attribute
- (Tree : Project_Node_Tree_Ref;
- Prj_Or_Pkg : Project_Node_Id;
- Name : Name_Id;
- Index_Name : Name_Id := No_Name;
- Kind : Variable_Kind := List;
- At_Index : Integer := 0;
- Value : Project_Node_Id := Empty_Node) return Project_Node_Id
- is
- Node : constant Project_Node_Id :=
- Default_Project_Node (Tree, N_Attribute_Declaration, Kind);
-
- Case_Insensitive : Boolean;
-
- Pkg : Package_Node_Id;
- Start_At : Attribute_Node_Id;
- Expr : Project_Node_Id;
-
- begin
- Set_Name_Of (Node, Tree, Name);
-
- if Index_Name /= No_Name then
- Set_Associative_Array_Index_Of (Node, Tree, Index_Name);
- end if;
-
- if Prj_Or_Pkg /= Empty_Node then
- Add_At_End (Tree, Prj_Or_Pkg, Node);
- end if;
-
- -- Find out the case sensitivity of the attribute
-
- if Prj_Or_Pkg /= Empty_Node
- and then Kind_Of (Prj_Or_Pkg, Tree) = N_Package_Declaration
- then
- Pkg := Prj.Attr.Package_Node_Id_Of (Name_Of (Prj_Or_Pkg, Tree));
- Start_At := First_Attribute_Of (Pkg);
- else
- Start_At := Attribute_First;
- end if;
-
- Start_At := Attribute_Node_Id_Of (Name, Start_At);
- Case_Insensitive :=
- Attribute_Kind_Of (Start_At) = Case_Insensitive_Associative_Array;
- Tree.Project_Nodes.Table (Node).Flag1 := Case_Insensitive;
-
- if At_Index /= 0 then
- if Attribute_Kind_Of (Start_At) =
- Optional_Index_Associative_Array
- or else Attribute_Kind_Of (Start_At) =
- Optional_Index_Case_Insensitive_Associative_Array
- then
- -- Results in: for Name ("index" at index) use "value";
- -- This is currently only used for executables.
-
- Set_Source_Index_Of (Node, Tree, To => Int (At_Index));
-
- else
- -- Results in: for Name ("index") use "value" at index;
-
- -- ??? This limitation makes no sense, we should be able to
- -- set the source index on an expression.
-
- pragma Assert (Kind_Of (Value, Tree) = N_Literal_String);
- Set_Source_Index_Of (Value, Tree, To => Int (At_Index));
- end if;
- end if;
-
- if Value /= Empty_Node then
- Expr := Enclose_In_Expression (Value, Tree);
- Set_Expression_Of (Node, Tree, Expr);
- end if;
-
- return Node;
- end Create_Attribute;
-
-end Prj.Tree;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . T R E E --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This package defines the structure of the Project File tree
-
-with GNAT.Dynamic_HTables;
-with GNAT.Dynamic_Tables;
-
-with Table;
-
-with Prj.Attr; use Prj.Attr;
-with Prj.Env;
-with Prj.Ext;
-
-package Prj.Tree is
-
- -----------------
- -- Environment --
- -----------------
-
- -- The following record contains the context in which projects are parsed
- -- and processed (finding importing project, resolving external values,..).
-
- type Environment is record
- External : Prj.Ext.External_References;
- -- External references are stored in this hash table (and manipulated
- -- through subprograms in prj-ext.ads). External references are
- -- project-tree specific so that one can load the same tree twice but
- -- have two views of it, for instance.
-
- Project_Path : aliased Prj.Env.Project_Search_Path;
- -- The project path is tree specific, since we might want to load
- -- simultaneously multiple projects, each with its own search path, in
- -- particular when using different compilers with different default
- -- search directories.
-
- Flags : Prj.Processing_Flags;
- -- Configure errors and warnings
- end record;
-
- procedure Initialize
- (Self : out Environment;
- Flags : Processing_Flags);
- -- Initialize a new environment
-
- procedure Initialize_And_Copy
- (Self : out Environment;
- Copy_From : Environment);
- -- Initialize a new environment, copying its values from Copy_From
-
- procedure Free (Self : in out Environment);
- -- Free the memory used by Self
-
- procedure Override_Flags
- (Self : in out Environment; Flags : Prj.Processing_Flags);
- -- Override the subprogram called in case there are parsing errors. This
- -- is needed in applications that do their own error handling, since the
- -- error handler is likely to be a local subprogram in this case (which
- -- can't be stored when the flags are created).
-
- -------------------
- -- Project nodes --
- -------------------
-
- type Project_Node_Tree_Data;
- type Project_Node_Tree_Ref is access all Project_Node_Tree_Data;
- -- Type to designate a project node tree, so that several project node
- -- trees can coexist in memory.
-
- Project_Nodes_Initial : constant := 1_000;
- Project_Nodes_Increment : constant := 100;
- -- Allocation parameters for initializing and extending number
- -- of nodes in table Tree_Private_Part.Project_Nodes
-
- Project_Node_Low_Bound : constant := 0;
- Project_Node_High_Bound : constant := 099_999_999;
- -- Range of values for project node id's (in practice infinite)
-
- type Project_Node_Id is range
- Project_Node_Low_Bound .. Project_Node_High_Bound;
- -- The index of table Tree_Private_Part.Project_Nodes
-
- Empty_Node : constant Project_Node_Id := Project_Node_Low_Bound;
- -- Designates no node in table Project_Nodes
-
- First_Node_Id : constant Project_Node_Id := Project_Node_Low_Bound + 1;
-
- subtype Variable_Node_Id is Project_Node_Id;
- -- Used to designate a node whose expected kind is one of
- -- N_Typed_Variable_Declaration, N_Variable_Declaration or
- -- N_Variable_Reference.
-
- subtype Package_Declaration_Id is Project_Node_Id;
- -- Used to designate a node whose expected kind is N_Project_Declaration
-
- type Project_Node_Kind is
- (N_Project,
- N_With_Clause,
- N_Project_Declaration,
- N_Declarative_Item,
- N_Package_Declaration,
- N_String_Type_Declaration,
- N_Literal_String,
- N_Attribute_Declaration,
- N_Typed_Variable_Declaration,
- N_Variable_Declaration,
- N_Expression,
- N_Term,
- N_Literal_String_List,
- N_Variable_Reference,
- N_External_Value,
- N_Attribute_Reference,
- N_Case_Construction,
- N_Case_Item,
- N_Comment_Zones,
- N_Comment);
- -- Each node in the tree is of a Project_Node_Kind. For the signification
- -- of the fields in each node of Project_Node_Kind, look at package
- -- Tree_Private_Part.
-
- function Present (Node : Project_Node_Id) return Boolean;
- pragma Inline (Present);
- -- Return True if Node /= Empty_Node
-
- function No (Node : Project_Node_Id) return Boolean;
- pragma Inline (No);
- -- Return True if Node = Empty_Node
-
- procedure Initialize (Tree : Project_Node_Tree_Ref);
- -- Initialize the Project File tree: empty the Project_Nodes table
- -- and reset the Projects_Htable.
-
- function Default_Project_Node
- (In_Tree : Project_Node_Tree_Ref;
- Of_Kind : Project_Node_Kind;
- And_Expr_Kind : Variable_Kind := Undefined) return Project_Node_Id;
- -- Returns a Project_Node_Record with the specified Kind and Expr_Kind. All
- -- the other components have default nil values.
- -- To create a node for a project itself, see Create_Project below instead
-
- function Hash (N : Project_Node_Id) return Header_Num;
- -- Used for hash tables where the key is a Project_Node_Id
-
- function Imported_Or_Extended_Project_Of
- (Project : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- With_Name : Name_Id) return Project_Node_Id;
- -- Return the node of a project imported or extended by project Project and
- -- whose name is With_Name. Return Empty_Node if there is no such project.
-
- --------------
- -- Comments --
- --------------
-
- type Comment_State is private;
- -- A type to store the values of several global variables related to
- -- comments.
-
- procedure Save (S : out Comment_State);
- -- Save in variable S the comment state. Called before scanning a new
- -- project file.
-
- procedure Restore_And_Free (S : in out Comment_State);
- -- Restore the comment state to a previously saved value. Called after
- -- scanning a project file. Frees the memory occupied by S
-
- procedure Reset_State;
- -- Set the comment state to its initial value. Called before scanning a
- -- new project file.
-
- function There_Are_Unkept_Comments return Boolean;
- -- Indicates that some of the comments in a project file could not be
- -- stored in the parse tree.
-
- procedure Set_Previous_Line_Node (To : Project_Node_Id);
- -- Indicate the node on the previous line. If there are comments
- -- immediately following this line, then they should be associated with
- -- this node.
-
- procedure Set_Previous_End_Node (To : Project_Node_Id);
- -- Indicate that on the previous line the "end" belongs to node To.
- -- If there are comments immediately following this "end" line, they
- -- should be associated with this node.
-
- procedure Set_End_Of_Line (To : Project_Node_Id);
- -- Indicate the node on the current line. If there is an end of line
- -- comment, then it should be associated with this node.
-
- procedure Set_Next_End_Node (To : Project_Node_Id);
- -- Put node To on the top of the end node stack. When an END line is found
- -- with this node on the top of the end node stack, the comments, if any,
- -- immediately preceding this "end" line will be associated with this node.
-
- procedure Remove_Next_End_Node;
- -- Remove the top of the end node stack
-
- ------------------------
- -- Comment Processing --
- ------------------------
-
- type Comment_Data is record
- Value : Name_Id := No_Name;
- Follows_Empty_Line : Boolean := False;
- Is_Followed_By_Empty_Line : Boolean := False;
- end record;
- -- Component type for Comments Table below
-
- package Comments is new Table.Table
- (Table_Component_Type => Comment_Data,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Prj.Tree.Comments");
- -- A table to store the comments that may be stored is the tree
-
- procedure Scan (In_Tree : Project_Node_Tree_Ref);
- -- Scan the tokens and accumulate comments
-
- type Comment_Location is
- (Before, After, Before_End, After_End, End_Of_Line);
- -- Used in call to Add_Comments below
-
- procedure Add_Comments
- (To : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Where : Comment_Location);
- -- Add comments to this node
-
- ----------------------
- -- Access Functions --
- ----------------------
-
- -- The following query functions are part of the abstract interface
- -- of the Project File tree. They provide access to fields of a project.
-
- -- The access functions should be called only with valid arguments.
- -- For each function the condition of validity is specified. If an access
- -- function is called with invalid arguments, then exception
- -- Assertion_Error is raised if assertions are enabled, otherwise the
- -- behavior is not defined and may result in a crash.
-
- function Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
- pragma Inline (Name_Of);
- -- Valid for all non empty nodes. May return No_Name for nodes that have
- -- no names.
-
- function Display_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
- pragma Inline (Display_Name_Of);
- -- Valid only for N_Project node. Returns the display name of the project.
-
- function Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Kind;
- pragma Inline (Kind_Of);
- -- Valid for all non empty nodes
-
- function Location_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Source_Ptr;
- pragma Inline (Location_Of);
- -- Valid for all non empty nodes
-
- function First_Comment_After
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Valid only for N_Comment_Zones nodes
-
- function First_Comment_After_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Valid only for N_Comment_Zones nodes
-
- function First_Comment_Before
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Valid only for N_Comment_Zones nodes
-
- function First_Comment_Before_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Valid only for N_Comment_Zones nodes
-
- function Next_Comment
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Valid only for N_Comment nodes
-
- function End_Of_Line_Comment
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
- -- Valid only for non empty nodes
-
- function Follows_Empty_Line
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean;
- -- Valid only for N_Comment nodes
-
- function Is_Followed_By_Empty_Line
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean;
- -- Valid only for N_Comment nodes
-
- function Parent_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Parent_Project_Of);
- -- Valid only for N_Project nodes
-
- function Project_File_Includes_Unkept_Comments
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean;
- -- Valid only for N_Project nodes
-
- function Directory_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
- pragma Inline (Directory_Of);
- -- Returns the directory that contains the project file. This always ends
- -- with a directory separator. Only valid for N_Project nodes.
-
- function Expression_Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Variable_Kind;
- pragma Inline (Expression_Kind_Of);
- -- Only valid for N_Literal_String, N_Attribute_Declaration,
- -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
- -- N_Term, N_Variable_Reference, N_Attribute_Reference nodes or
- -- N_External_Value.
-
- function Is_Extending_All
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean;
- pragma Inline (Is_Extending_All);
- -- Only valid for N_Project and N_With_Clause
-
- function Is_Not_Last_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean;
- pragma Inline (Is_Not_Last_In_List);
- -- Only valid for N_With_Clause
-
- function First_Variable_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Variable_Node_Id;
- pragma Inline (First_Variable_Of);
- -- Only valid for N_Project or N_Package_Declaration nodes
-
- function First_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Package_Declaration_Id;
- pragma Inline (First_Package_Of);
- -- Only valid for N_Project nodes
-
- function Package_Id_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Package_Node_Id;
- pragma Inline (Package_Id_Of);
- -- Only valid for N_Package_Declaration nodes
-
- function Path_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
- pragma Inline (Path_Name_Of);
- -- Only valid for N_Project and N_With_Clause nodes
-
- function String_Value_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
- pragma Inline (String_Value_Of);
- -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment.
- -- For a N_With_Clause created automatically for a virtual extending
- -- project, No_Name is returned.
-
- function Source_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Int;
- pragma Inline (Source_Index_Of);
- -- Only valid for N_Literal_String and N_Attribute_Declaration nodes
-
- function First_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_With_Clause_Of);
- -- Only valid for N_Project nodes
-
- function Project_Declaration_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Project_Declaration_Of);
- -- Only valid for N_Project nodes
-
- function Project_Qualifier_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Qualifier;
- pragma Inline (Project_Qualifier_Of);
- -- Only valid for N_Project nodes
-
- function Extending_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Extending_Project_Of);
- -- Only valid for N_Project_Declaration nodes
-
- function First_String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_String_Type_Of);
- -- Only valid for N_Project nodes
-
- function Extended_Project_Path_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Path_Name_Type;
- pragma Inline (Extended_Project_Path_Of);
- -- Only valid for N_With_Clause nodes
-
- function Project_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Project_Node_Of);
- -- Only valid for N_With_Clause, N_Variable_Reference and
- -- N_Attribute_Reference nodes.
-
- function Non_Limited_Project_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Non_Limited_Project_Node_Of);
- -- Only valid for N_With_Clause nodes. Returns Empty_Node for limited
- -- imported project files, otherwise returns the same result as
- -- Project_Node_Of.
-
- function Next_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_With_Clause_Of);
- -- Only valid for N_With_Clause nodes
-
- function First_Declarative_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_Declarative_Item_Of);
- -- Only valid for N_Project_Declaration, N_Case_Item and
- -- N_Package_Declaration.
-
- function Extended_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Extended_Project_Of);
- -- Only valid for N_Project_Declaration nodes
-
- function Current_Item_Node
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Current_Item_Node);
- -- Only valid for N_Declarative_Item nodes
-
- function Next_Declarative_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_Declarative_Item);
- -- Only valid for N_Declarative_Item node
-
- function Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Project_Of_Renamed_Package_Of);
- -- Only valid for N_Package_Declaration nodes. May return Empty_Node.
-
- function Next_Package_In_Project
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_Package_In_Project);
- -- Only valid for N_Package_Declaration nodes
-
- function First_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_Literal_String);
- -- Only valid for N_String_Type_Declaration nodes
-
- function Next_String_Type
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_String_Type);
- -- Only valid for N_String_Type_Declaration nodes
-
- function Next_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_Literal_String);
- -- Only valid for N_Literal_String nodes
-
- function Expression_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Expression_Of);
- -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
- -- or N_Variable_Declaration nodes
-
- function Associative_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- return Project_Node_Id;
- pragma Inline (Associative_Project_Of);
- -- Only valid for N_Attribute_Declaration nodes
-
- function Associative_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref)
- return Project_Node_Id;
- pragma Inline (Associative_Package_Of);
- -- Only valid for N_Attribute_Declaration nodes
-
- function Value_Is_Valid
- (For_Typed_Variable : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- Value : Name_Id) return Boolean;
- pragma Inline (Value_Is_Valid);
- -- Only valid for N_Typed_Variable_Declaration. Returns True if Value is
- -- in the list of allowed strings for For_Typed_Variable. False otherwise.
-
- function Associative_Array_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Name_Id;
- pragma Inline (Associative_Array_Index_Of);
- -- Only valid for N_Attribute_Declaration and N_Attribute_Reference.
- -- Returns No_Name for non associative array attributes.
-
- function Next_Variable
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_Variable);
- -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
- -- nodes.
-
- function First_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_Term);
- -- Only valid for N_Expression nodes
-
- function Next_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_Expression_In_List);
- -- Only valid for N_Expression nodes
-
- function Current_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Current_Term);
- -- Only valid for N_Term nodes
-
- function Next_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_Term);
- -- Only valid for N_Term nodes
-
- function First_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_Expression_In_List);
- -- Only valid for N_Literal_String_List nodes
-
- function Package_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Package_Node_Of);
- -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes.
- -- May return Empty_Node.
-
- function Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Attribute_Default_Value;
- pragma Inline (Default_Of);
- -- Only valid for N_Attribute_Reference nodes
-
- function String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (String_Type_Of);
- -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
- -- nodes.
-
- function External_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (External_Reference_Of);
- -- Only valid for N_External_Value nodes
-
- function External_Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (External_Default_Of);
- -- Only valid for N_External_Value nodes
-
- function Case_Variable_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Case_Variable_Reference_Of);
- -- Only valid for N_Case_Construction nodes
-
- function First_Case_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_Case_Item_Of);
- -- Only valid for N_Case_Construction nodes
-
- function First_Choice_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (First_Choice_Of);
- -- Only valid for N_Case_Item nodes. Return the first choice in a
- -- N_Case_Item, or Empty_Node if this is when others.
-
- function Next_Case_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- pragma Inline (Next_Case_Item);
- -- Only valid for N_Case_Item nodes
-
- function Case_Insensitive
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref) return Boolean;
- -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes
-
- -----------------------
- -- Create procedures --
- -----------------------
- -- The following procedures are used to edit a project file tree. They are
- -- slightly higher-level than the Set_* procedures below
-
- function Create_Project
- (In_Tree : Project_Node_Tree_Ref;
- Name : Name_Id;
- Full_Path : Path_Name_Type;
- Is_Config_File : Boolean := False) return Project_Node_Id;
- -- Create a new node for a project and register it in the tree so that it
- -- can be retrieved later on.
-
- function Create_Package
- (Tree : Project_Node_Tree_Ref;
- Project : Project_Node_Id;
- Pkg : String) return Project_Node_Id;
- -- Create a new package in Project. If the package already exists, it is
- -- returned. The name of the package *must* be lower-cases, or none of its
- -- attributes will be recognized.
-
- function Create_Attribute
- (Tree : Project_Node_Tree_Ref;
- Prj_Or_Pkg : Project_Node_Id;
- Name : Name_Id;
- Index_Name : Name_Id := No_Name;
- Kind : Variable_Kind := List;
- At_Index : Integer := 0;
- Value : Project_Node_Id := Empty_Node) return Project_Node_Id;
- -- Create a new attribute. The new declaration is added at the end of the
- -- declarative item list for Prj_Or_Pkg (a project or a package), but
- -- before any package declaration). No addition is done if Prj_Or_Pkg is
- -- Empty_Node. If Index_Name is not "", then if creates an attribute value
- -- for a specific index. At_Index is used for the " at <idx>" in the naming
- -- exceptions.
- --
- -- To set the value of the attribute, either provide a value for Value, or
- -- use Set_Expression_Of to set the value of the attribute (in which case
- -- Enclose_In_Expression might be useful). The former is recommended since
- -- it will more correctly handle cases where the index needs to be set on
- -- the expression rather than on the index of the attribute (i.e. 'for
- -- Specification ("unit") use "file" at 3', versus 'for Executable ("file"
- -- at 3) use "name"'). Value must be a N_String_Literal if an index will be
- -- added to it.
-
- function Create_Literal_String
- (Str : Namet.Name_Id;
- Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Create a literal string whose value is Str
-
- procedure Add_At_End
- (Tree : Project_Node_Tree_Ref;
- Parent : Project_Node_Id;
- Expr : Project_Node_Id;
- Add_Before_First_Pkg : Boolean := False;
- Add_Before_First_Case : Boolean := False);
- -- Add a new declarative item in the list in Parent. This new declarative
- -- item will contain Expr (unless Expr is already a declarative item, in
- -- which case it is added directly to the list). The new item is inserted
- -- at the end of the list, unless Add_Before_First_Pkg is True. In the
- -- latter case, it is added just before the first case construction is
- -- seen, or before the first package (this assumes that all packages are
- -- found at the end of the project, which isn't true in the general case
- -- unless you have normalized the project to match this description).
-
- function Enclose_In_Expression
- (Node : Project_Node_Id;
- Tree : Project_Node_Tree_Ref) return Project_Node_Id;
- -- Enclose the Node inside a N_Expression node, and return this expression.
- -- This does nothing if Node is already a N_Expression.
-
- --------------------
- -- Set Procedures --
- --------------------
-
- -- The following procedures are part of the abstract interface of the
- -- Project File tree.
-
- -- Foe each Set_* procedure the condition of validity is specified. If an
- -- access function is called with invalid arguments, then exception
- -- Assertion_Error is raised if assertions are enabled, otherwise the
- -- behavior is not defined and may result in a crash.
-
- -- These are very low-level, and manipulate the tree itself directly. You
- -- should look at the Create_* procedure instead if you want to use higher
- -- level constructs
-
- procedure Set_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id);
- pragma Inline (Set_Name_Of);
- -- Valid for all non empty nodes
-
- procedure Set_Display_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id);
- pragma Inline (Set_Display_Name_Of);
- -- Valid only for N_Project nodes
-
- procedure Set_Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Kind);
- pragma Inline (Set_Kind_Of);
- -- Valid for all non empty nodes
-
- procedure Set_Location_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Source_Ptr);
- pragma Inline (Set_Location_Of);
- -- Valid for all non empty nodes
-
- procedure Set_First_Comment_After
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Comment_After);
- -- Valid only for N_Comment_Zones nodes
-
- procedure Set_First_Comment_After_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Comment_After_End);
- -- Valid only for N_Comment_Zones nodes
-
- procedure Set_First_Comment_Before
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Comment_Before);
- -- Valid only for N_Comment_Zones nodes
-
- procedure Set_First_Comment_Before_End
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Comment_Before_End);
- -- Valid only for N_Comment_Zones nodes
-
- procedure Set_Next_Comment
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Comment);
- -- Valid only for N_Comment nodes
-
- procedure Set_Parent_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- -- Valid only for N_Project nodes
-
- procedure Set_Project_File_Includes_Unkept_Comments
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Boolean);
- -- Valid only for N_Project nodes
-
- procedure Set_Directory_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Path_Name_Type);
- pragma Inline (Set_Directory_Of);
- -- Valid only for N_Project nodes
-
- procedure Set_Expression_Kind_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Variable_Kind);
- pragma Inline (Set_Expression_Kind_Of);
- -- Only valid for N_Literal_String, N_Attribute_Declaration,
- -- N_Variable_Declaration, N_Typed_Variable_Declaration, N_Expression,
- -- N_Term, N_Variable_Reference, N_Attribute_Reference or N_External_Value
- -- nodes.
-
- procedure Set_Is_Extending_All
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref);
- pragma Inline (Set_Is_Extending_All);
- -- Only valid for N_Project and N_With_Clause
-
- procedure Set_Is_Not_Last_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref);
- pragma Inline (Set_Is_Not_Last_In_List);
- -- Only valid for N_With_Clause
-
- procedure Set_First_Variable_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Variable_Node_Id);
- pragma Inline (Set_First_Variable_Of);
- -- Only valid for N_Project or N_Package_Declaration nodes
-
- procedure Set_First_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Package_Declaration_Id);
- pragma Inline (Set_First_Package_Of);
- -- Only valid for N_Project nodes
-
- procedure Set_Package_Id_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Package_Node_Id);
- pragma Inline (Set_Package_Id_Of);
- -- Only valid for N_Package_Declaration nodes
-
- procedure Set_Path_Name_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Path_Name_Type);
- pragma Inline (Set_Path_Name_Of);
- -- Only valid for N_Project and N_With_Clause nodes
-
- procedure Set_String_Value_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id);
- pragma Inline (Set_String_Value_Of);
- -- Only valid for N_With_Clause, N_Literal_String nodes or N_Comment.
-
- procedure Set_Source_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Int);
- pragma Inline (Set_Source_Index_Of);
- -- Only valid for N_Literal_String and N_Attribute_Declaration nodes. For
- -- N_Literal_String, set the source index of the literal string. For
- -- N_Attribute_Declaration, set the source index of the index of the
- -- associative array element.
-
- procedure Set_First_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_With_Clause_Of);
- -- Only valid for N_Project nodes
-
- procedure Set_Project_Declaration_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Project_Declaration_Of);
- -- Only valid for N_Project nodes
-
- procedure Set_Project_Qualifier_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Qualifier);
- pragma Inline (Set_Project_Qualifier_Of);
- -- Only valid for N_Project nodes
-
- procedure Set_Extending_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Extending_Project_Of);
- -- Only valid for N_Project_Declaration nodes
-
- procedure Set_First_String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_String_Type_Of);
- -- Only valid for N_Project nodes
-
- procedure Set_Extended_Project_Path_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Path_Name_Type);
- pragma Inline (Set_Extended_Project_Path_Of);
- -- Only valid for N_With_Clause nodes
-
- procedure Set_Project_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id;
- Limited_With : Boolean := False);
- pragma Inline (Set_Project_Node_Of);
- -- Only valid for N_With_Clause, N_Variable_Reference and
- -- N_Attribute_Reference nodes.
-
- procedure Set_Next_With_Clause_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_With_Clause_Of);
- -- Only valid for N_With_Clause nodes
-
- procedure Set_First_Declarative_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Declarative_Item_Of);
- -- Only valid for N_Project_Declaration, N_Case_Item and
- -- N_Package_Declaration.
-
- procedure Set_Extended_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Extended_Project_Of);
- -- Only valid for N_Project_Declaration nodes
-
- procedure Set_Current_Item_Node
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Current_Item_Node);
- -- Only valid for N_Declarative_Item nodes
-
- procedure Set_Next_Declarative_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Declarative_Item);
- -- Only valid for N_Declarative_Item node
-
- procedure Set_Project_Of_Renamed_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Project_Of_Renamed_Package_Of);
- -- Only valid for N_Package_Declaration nodes.
-
- procedure Set_Next_Package_In_Project
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Package_In_Project);
- -- Only valid for N_Package_Declaration nodes
-
- procedure Set_First_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Literal_String);
- -- Only valid for N_String_Type_Declaration nodes
-
- procedure Set_Next_String_Type
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_String_Type);
- -- Only valid for N_String_Type_Declaration nodes
-
- procedure Set_Next_Literal_String
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Literal_String);
- -- Only valid for N_Literal_String nodes
-
- procedure Set_Expression_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Expression_Of);
- -- Only valid for N_Attribute_Declaration, N_Typed_Variable_Declaration
- -- or N_Variable_Declaration nodes
-
- procedure Set_Associative_Project_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Associative_Project_Of);
- -- Only valid for N_Attribute_Declaration nodes
-
- procedure Set_Associative_Package_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Associative_Package_Of);
- -- Only valid for N_Attribute_Declaration nodes
-
- procedure Set_Associative_Array_Index_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Name_Id);
- pragma Inline (Set_Associative_Array_Index_Of);
- -- Only valid for N_Attribute_Declaration and N_Attribute_Reference.
-
- procedure Set_Next_Variable
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Variable);
- -- Only valid for N_Typed_Variable_Declaration or N_Variable_Declaration
- -- nodes.
-
- procedure Set_First_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Term);
- -- Only valid for N_Expression nodes
-
- procedure Set_Next_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Expression_In_List);
- -- Only valid for N_Expression nodes
-
- procedure Set_Current_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Current_Term);
- -- Only valid for N_Term nodes
-
- procedure Set_Next_Term
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Term);
- -- Only valid for N_Term nodes
-
- procedure Set_First_Expression_In_List
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Expression_In_List);
- -- Only valid for N_Literal_String_List nodes
-
- procedure Set_Package_Node_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Package_Node_Of);
- -- Only valid for N_Variable_Reference or N_Attribute_Reference nodes
-
- procedure Set_Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Attribute_Default_Value);
- pragma Inline (Set_Default_Of);
- -- Only valid for N_Attribute_Reference nodes
-
- procedure Set_String_Type_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_String_Type_Of);
- -- Only valid for N_Variable_Reference or N_Typed_Variable_Declaration
- -- nodes.
-
- procedure Set_External_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_External_Reference_Of);
- -- Only valid for N_External_Value nodes
-
- procedure Set_External_Default_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_External_Default_Of);
- -- Only valid for N_External_Value nodes
-
- procedure Set_Case_Variable_Reference_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Case_Variable_Reference_Of);
- -- Only valid for N_Case_Construction nodes
-
- procedure Set_First_Case_Item_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Case_Item_Of);
- -- Only valid for N_Case_Construction nodes
-
- procedure Set_First_Choice_Of
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_First_Choice_Of);
- -- Only valid for N_Case_Item nodes.
-
- procedure Set_Next_Case_Item
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Project_Node_Id);
- pragma Inline (Set_Next_Case_Item);
- -- Only valid for N_Case_Item nodes.
-
- procedure Set_Case_Insensitive
- (Node : Project_Node_Id;
- In_Tree : Project_Node_Tree_Ref;
- To : Boolean);
- -- Only valid for N_Attribute_Declaration and N_Attribute_Reference nodes
-
- -------------------------------
- -- Restricted Access Section --
- -------------------------------
-
- package Tree_Private_Part is
-
- -- This is conceptually in the private part. However, for efficiency,
- -- some packages are accessing it directly.
-
- type Project_Node_Record is record
-
- Kind : Project_Node_Kind;
-
- Qualifier : Project_Qualifier := Unspecified;
-
- Location : Source_Ptr := No_Location;
-
- Directory : Path_Name_Type := No_Path;
- -- Only for N_Project
-
- Display_Name : Name_Id := No_Name;
- -- Only for N_Project
-
- Expr_Kind : Variable_Kind := Undefined;
- -- See below for what Project_Node_Kind it is used
-
- Variables : Variable_Node_Id := Empty_Node;
- -- First variable in a project or a package
-
- Packages : Package_Declaration_Id := Empty_Node;
- -- First package declaration in a project
-
- Pkg_Id : Package_Node_Id := Empty_Package;
- -- Only used for N_Package_Declaration
- --
- -- The component Pkg_Id is an entry into the table Package_Attributes
- -- (in Prj.Attr). It is used to indicate all the attributes of the
- -- package with their characteristics.
- --
- -- The tables Prj.Attr.Attributes and Prj.Attr.Package_Attributes
- -- are built once and for all through a call (from Prj.Initialize)
- -- to procedure Prj.Attr.Initialize. It is never modified after that.
-
- Name : Name_Id := No_Name;
- -- See below for what Project_Node_Kind it is used
-
- Src_Index : Int := 0;
- -- Index of a unit in a multi-unit source.
- -- Only for some N_Attribute_Declaration and N_Literal_String.
-
- Path_Name : Path_Name_Type := No_Path;
- -- See below for what Project_Node_Kind it is used
-
- Value : Name_Id := No_Name;
- -- See below for what Project_Node_Kind it is used
-
- Default : Attribute_Default_Value := Empty_Value;
- -- Only used in N_Attribute_Reference
-
- Field1 : Project_Node_Id := Empty_Node;
- -- See below the meaning for each Project_Node_Kind
-
- Field2 : Project_Node_Id := Empty_Node;
- -- See below the meaning for each Project_Node_Kind
-
- Field3 : Project_Node_Id := Empty_Node;
- -- See below the meaning for each Project_Node_Kind
-
- Field4 : Project_Node_Id := Empty_Node;
- -- See below the meaning for each Project_Node_Kind
-
- Flag1 : Boolean := False;
- -- This flag is significant only for:
- --
- -- N_Attribute_Declaration and N_Attribute_Reference
- -- Indicates for an associative array attribute, that the
- -- index is case insensitive.
- --
- -- N_Comment
- -- Indicates that the comment is preceded by an empty line.
- --
- -- N_Project
- -- Indicates that there are comments in the project source that
- -- cannot be kept in the tree.
- --
- -- N_Project_Declaration
- -- Indicates that there are unkept comments in the project.
- --
- -- N_With_Clause
- -- Indicates that this is not the last with in a with clause.
- -- Set for "A", but not for "B" in with "B"; and with "A", "B";
-
- Flag2 : Boolean := False;
- -- This flag is significant only for:
- --
- -- N_Project
- -- Indicates that the project "extends all" another project.
- --
- -- N_Comment
- -- Indicates that the comment is followed by an empty line.
- --
- -- N_With_Clause
- -- Indicates that the originally imported project is an extending
- -- all project.
-
- Comments : Project_Node_Id := Empty_Node;
- -- For nodes other that N_Comment_Zones or N_Comment, designates the
- -- comment zones associated with the node.
- --
- -- For N_Comment_Zones, designates the comment after the "end" of
- -- the construct.
- --
- -- For N_Comment, designates the next comment, if any.
-
- end record;
-
- -- type Project_Node_Kind is
-
- -- (N_Project,
- -- -- Name: project name
- -- -- Path_Name: project path name
- -- -- Expr_Kind: Undefined
- -- -- Field1: first with clause
- -- -- Field2: project declaration
- -- -- Field3: first string type
- -- -- Field4: parent project, if any
- -- -- Value: extended project path name (if any)
-
- -- N_With_Clause,
- -- -- Name: imported project name
- -- -- Path_Name: imported project path name
- -- -- Expr_Kind: Undefined
- -- -- Field1: project node
- -- -- Field2: next with clause
- -- -- Field3: project node or empty if "limited with"
- -- -- Field4: not used
- -- -- Value: literal string withed
-
- -- N_Project_Declaration,
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: Undefined
- -- -- Field1: first declarative item
- -- -- Field2: extended project
- -- -- Field3: extending project
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Declarative_Item,
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: Undefined
- -- -- Field1: current item node
- -- -- Field2: next declarative item
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Package_Declaration,
- -- -- Name: package name
- -- -- Path_Name: not used
- -- -- Expr_Kind: Undefined
- -- -- Field1: project of renamed package (if any)
- -- -- Field2: first declarative item
- -- -- Field3: next package in project
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_String_Type_Declaration,
- -- -- Name: type name
- -- -- Path_Name: not used
- -- -- Expr_Kind: Undefined
- -- -- Field1: first literal string
- -- -- Field2: next string type
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Literal_String,
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: Single
- -- -- Field1: next literal string
- -- -- Field2: not used
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: string value
-
- -- N_Attribute_Declaration,
- -- -- Name: attribute name
- -- -- Path_Name: not used
- -- -- Expr_Kind: attribute kind
- -- -- Field1: expression
- -- -- Field2: project of full associative array
- -- -- Field3: package of full associative array
- -- -- Field4: not used
- -- -- Value: associative array index
- -- -- (if an associative array element)
-
- -- N_Typed_Variable_Declaration,
- -- -- Name: variable name
- -- -- Path_Name: not used
- -- -- Expr_Kind: Single
- -- -- Field1: expression
- -- -- Field2: type of variable (N_String_Type_Declaration)
- -- -- Field3: next variable
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Variable_Declaration,
- -- -- Name: variable name
- -- -- Path_Name: not used
- -- -- Expr_Kind: variable kind
- -- -- Field1: expression
- -- -- Field2: not used
- -- -- Field3 is used for next variable, instead of Field2,
- -- -- so that it is the same field for
- -- -- N_Variable_Declaration and
- -- -- N_Typed_Variable_Declaration
- -- -- Field3: next variable
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Expression,
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: expression kind
- -- -- Field1: first term
- -- -- Field2: next expression in list
- -- -- Field3: not used
- -- -- Value: not used
-
- -- N_Term,
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: term kind
- -- -- Field1: current term
- -- -- Field2: next term in the expression
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Literal_String_List,
- -- -- Designates a list of string expressions between brackets
- -- -- separated by commas. The string expressions are not necessarily
- -- -- literal strings.
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: List
- -- -- Field1: first expression
- -- -- Field2: not used
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Variable_Reference,
- -- -- Name: variable name
- -- -- Path_Name: not used
- -- -- Expr_Kind: variable kind
- -- -- Field1: project (if specified)
- -- -- Field2: package (if specified)
- -- -- Field3: type of variable (N_String_Type_Declaration), if any
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_External_Value,
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: Single
- -- -- Field1: Name of the external reference (literal string)
- -- -- Field2: Default (literal string)
- -- -- Field3: not used
- -- -- Value: not used
-
- -- N_Attribute_Reference,
- -- -- Name: attribute name
- -- -- Path_Name: not used
- -- -- Expr_Kind: attribute kind
- -- -- Field1: project
- -- -- Field2: package (if attribute of a package)
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: associative array index
- -- -- (if an associative array element)
-
- -- N_Case_Construction,
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: Undefined
- -- -- Field1: case variable reference
- -- -- Field2: first case item
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Case_Item
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: not used
- -- -- Field1: first choice (literal string), or Empty_Node
- -- -- for when others
- -- -- Field2: first declarative item
- -- -- Field3: next case item
- -- -- Field4: not used
- -- -- Value: not used
-
- -- N_Comment_zones
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: not used
- -- -- Field1: comment before the construct
- -- -- Field2: comment after the construct
- -- -- Field3: comment before the "end" of the construct
- -- -- Value: end of line comment
- -- -- Field4: not used
- -- -- Comments: comment after the "end" of the construct
-
- -- N_Comment
- -- -- Name: not used
- -- -- Path_Name: not used
- -- -- Expr_Kind: not used
- -- -- Field1: not used
- -- -- Field2: not used
- -- -- Field3: not used
- -- -- Field4: not used
- -- -- Value: comment
- -- -- Flag1: comment is preceded by an empty line
- -- -- Flag2: comment is followed by an empty line
- -- -- Comments: next comment
-
- package Project_Node_Table is new
- GNAT.Dynamic_Tables
- (Table_Component_Type => Project_Node_Record,
- Table_Index_Type => Project_Node_Id,
- Table_Low_Bound => First_Node_Id,
- Table_Initial => Project_Nodes_Initial,
- Table_Increment => Project_Nodes_Increment);
- -- Table contains the syntactic tree of project data from project files
-
- type Project_Name_And_Node is record
- Name : Name_Id;
- -- Name of the project
-
- Node : Project_Node_Id;
- -- Node of the project in table Project_Nodes
-
- Resolved_Path : Path_Name_Type;
- -- Resolved and canonical path of a real project file.
- -- No_Name in case of virtual projects.
-
- Extended : Boolean;
- -- True when the project is being extended by another project
-
- From_Extended : Boolean;
- -- True when the project is only imported by projects that are
- -- extended.
-
- Proj_Qualifier : Project_Qualifier;
- -- The project qualifier of the project, if any
- end record;
-
- No_Project_Name_And_Node : constant Project_Name_And_Node :=
- (Name => No_Name,
- Node => Empty_Node,
- Resolved_Path => No_Path,
- Extended => True,
- From_Extended => False,
- Proj_Qualifier => Unspecified);
-
- package Projects_Htable is new GNAT.Dynamic_HTables.Simple_HTable
- (Header_Num => Header_Num,
- Element => Project_Name_And_Node,
- No_Element => No_Project_Name_And_Node,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
- -- This hash table contains a mapping of project names to project nodes.
- -- Note that this hash table contains only the nodes whose Kind is
- -- N_Project. It is used to find the node of a project from its name,
- -- and to verify if a project has already been parsed, knowing its name.
-
- end Tree_Private_Part;
-
- type Project_Node_Tree_Data is record
- Project_Nodes : Tree_Private_Part.Project_Node_Table.Instance;
- Projects_HT : Tree_Private_Part.Projects_Htable.Instance;
-
- Incomplete_With : Boolean := False;
- -- Set to True if the projects were loaded with the flag
- -- Ignore_Missing_With set to True, and there were indeed some with
- -- statements that could not be resolved
- end record;
-
- procedure Free (Proj : in out Project_Node_Tree_Ref);
- -- Free memory used by Prj
-
-private
- type Comment_Array is array (Positive range <>) of Comment_Data;
- type Comments_Ptr is access Comment_Array;
-
- type Comment_State is record
- End_Of_Line_Node : Project_Node_Id := Empty_Node;
- Previous_Line_Node : Project_Node_Id := Empty_Node;
- Previous_End_Node : Project_Node_Id := Empty_Node;
- Unkept_Comments : Boolean := False;
- Comments : Comments_Ptr := null;
- end record;
-
-end Prj.Tree;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . U T I L --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Ada.Containers.Indefinite_Ordered_Sets;
-with Ada.Directories;
-with Ada.Strings.Fixed; use Ada.Strings.Fixed;
-with Ada.Strings.Maps; use Ada.Strings.Maps;
-with Ada.Unchecked_Deallocation;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Regexp; use GNAT.Regexp;
-
-with ALI; use ALI;
-with Osint; use Osint;
-with Output; use Output;
-with Opt;
-with Prj.Com;
-with Snames; use Snames;
-with Table;
-with Targparm; use Targparm;
-
-with GNAT.HTable;
-
-package body Prj.Util is
-
- package Source_Info_Table is new Table.Table
- (Table_Component_Type => Source_Info_Iterator,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Makeutl.Source_Info_Table");
-
- package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable
- (Header_Num => Prj.Header_Num,
- Element => Natural,
- No_Element => 0,
- Key => Name_Id,
- Hash => Prj.Hash,
- Equal => "=");
-
- procedure Free is new Ada.Unchecked_Deallocation
- (Text_File_Data, Text_File);
-
- -----------
- -- Close --
- -----------
-
- procedure Close (File : in out Text_File) is
- Len : Integer;
- Status : Boolean;
-
- begin
- if File = null then
- Prj.Com.Fail ("Close attempted on an invalid Text_File");
- end if;
-
- if File.Out_File then
- if File.Buffer_Len > 0 then
- Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
-
- if Len /= File.Buffer_Len then
- Prj.Com.Fail ("Unable to write to an out Text_File");
- end if;
- end if;
-
- Close (File.FD, Status);
-
- if not Status then
- Prj.Com.Fail ("Unable to close an out Text_File");
- end if;
-
- else
-
- -- Close in file, no need to test status, since this is a file that
- -- we read, and the file was read successfully before we closed it.
-
- Close (File.FD);
- end if;
-
- Free (File);
- end Close;
-
- ------------
- -- Create --
- ------------
-
- procedure Create (File : out Text_File; Name : String) is
- FD : File_Descriptor;
- File_Name : String (1 .. Name'Length + 1);
-
- begin
- File_Name (1 .. Name'Length) := Name;
- File_Name (File_Name'Last) := ASCII.NUL;
- FD := Create_File (Name => File_Name'Address,
- Fmode => GNAT.OS_Lib.Text);
-
- if FD = Invalid_FD then
- File := null;
-
- else
- File := new Text_File_Data;
- File.FD := FD;
- File.Out_File := True;
- File.End_Of_File_Reached := True;
- end if;
- end Create;
-
- ---------------
- -- Duplicate --
- ---------------
-
- procedure Duplicate
- (This : in out Name_List_Index;
- Shared : Shared_Project_Tree_Data_Access)
- is
- Old_Current : Name_List_Index;
- New_Current : Name_List_Index;
-
- begin
- if This /= No_Name_List then
- Old_Current := This;
- Name_List_Table.Increment_Last (Shared.Name_Lists);
- New_Current := Name_List_Table.Last (Shared.Name_Lists);
- This := New_Current;
- Shared.Name_Lists.Table (New_Current) :=
- (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
-
- loop
- Old_Current := Shared.Name_Lists.Table (Old_Current).Next;
- exit when Old_Current = No_Name_List;
- Shared.Name_Lists.Table (New_Current).Next := New_Current + 1;
- Name_List_Table.Increment_Last (Shared.Name_Lists);
- New_Current := New_Current + 1;
- Shared.Name_Lists.Table (New_Current) :=
- (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
- end loop;
- end if;
- end Duplicate;
-
- -----------------
- -- End_Of_File --
- -----------------
-
- function End_Of_File (File : Text_File) return Boolean is
- begin
- if File = null then
- Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
- end if;
-
- return File.End_Of_File_Reached;
- end End_Of_File;
-
- -------------------
- -- Executable_Of --
- -------------------
-
- function Executable_Of
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Main : File_Name_Type;
- Index : Int;
- Ada_Main : Boolean := True;
- Language : String := "";
- Include_Suffix : Boolean := True) return File_Name_Type
- is
- pragma Assert (Project /= No_Project);
-
- The_Packages : constant Package_Id := Project.Decl.Packages;
-
- Builder_Package : constant Prj.Package_Id :=
- Prj.Util.Value_Of
- (Name => Name_Builder,
- In_Packages => The_Packages,
- Shared => Shared);
-
- Executable : Variable_Value :=
- Prj.Util.Value_Of
- (Name => Name_Id (Main),
- Index => Index,
- Attribute_Or_Array_Name => Name_Executable,
- In_Package => Builder_Package,
- Shared => Shared);
-
- Lang : Language_Ptr;
-
- Spec_Suffix : Name_Id := No_Name;
- Body_Suffix : Name_Id := No_Name;
-
- Spec_Suffix_Length : Natural := 0;
- Body_Suffix_Length : Natural := 0;
-
- procedure Get_Suffixes
- (B_Suffix : File_Name_Type;
- S_Suffix : File_Name_Type);
- -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
-
- function Add_Suffix (File : File_Name_Type) return File_Name_Type;
- -- Return the name of the executable, based on File, and adding the
- -- executable suffix if needed
-
- ------------------
- -- Get_Suffixes --
- ------------------
-
- procedure Get_Suffixes
- (B_Suffix : File_Name_Type;
- S_Suffix : File_Name_Type)
- is
- begin
- if B_Suffix /= No_File then
- Body_Suffix := Name_Id (B_Suffix);
- Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
- end if;
-
- if S_Suffix /= No_File then
- Spec_Suffix := Name_Id (S_Suffix);
- Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
- end if;
- end Get_Suffixes;
-
- ----------------
- -- Add_Suffix --
- ----------------
-
- function Add_Suffix (File : File_Name_Type) return File_Name_Type is
- Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
- Result : File_Name_Type;
- Suffix_From_Project : Variable_Value;
- begin
- if Include_Suffix then
- if Project.Config.Executable_Suffix /= No_Name then
- Executable_Extension_On_Target :=
- Project.Config.Executable_Suffix;
- end if;
-
- Result := Executable_Name (File);
- Executable_Extension_On_Target := Saved_EEOT;
- return Result;
-
- elsif Builder_Package /= No_Package then
-
- -- If the suffix is specified in the project itself, as opposed to
- -- the config file, it needs to be taken into account. However,
- -- when the project was processed, in both cases the suffix was
- -- stored in Project.Config, so get it from the project again.
-
- Suffix_From_Project :=
- Prj.Util.Value_Of
- (Variable_Name => Name_Executable_Suffix,
- In_Variables =>
- Shared.Packages.Table (Builder_Package).Decl.Attributes,
- Shared => Shared);
-
- if Suffix_From_Project /= Nil_Variable_Value
- and then Suffix_From_Project.Value /= No_Name
- then
- Executable_Extension_On_Target := Suffix_From_Project.Value;
- Result := Executable_Name (File);
- Executable_Extension_On_Target := Saved_EEOT;
- return Result;
- end if;
- end if;
-
- return File;
- end Add_Suffix;
-
- -- Start of processing for Executable_Of
-
- begin
- if Ada_Main then
- Lang := Get_Language_From_Name (Project, "ada");
- elsif Language /= "" then
- Lang := Get_Language_From_Name (Project, Language);
- end if;
-
- if Lang /= null then
- Get_Suffixes
- (B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
- S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
- end if;
-
- if Builder_Package /= No_Package then
- if Executable = Nil_Variable_Value and then Ada_Main then
- Get_Name_String (Main);
-
- -- Try as index the name minus the implementation suffix or minus
- -- the specification suffix.
-
- declare
- Name : constant String (1 .. Name_Len) :=
- Name_Buffer (1 .. Name_Len);
- Last : Positive := Name_Len;
-
- Truncated : Boolean := False;
-
- begin
- if Body_Suffix /= No_Name
- and then Last > Natural (Length_Of_Name (Body_Suffix))
- and then Name (Last - Body_Suffix_Length + 1 .. Last) =
- Get_Name_String (Body_Suffix)
- then
- Truncated := True;
- Last := Last - Body_Suffix_Length;
- end if;
-
- if Spec_Suffix /= No_Name
- and then not Truncated
- and then Last > Spec_Suffix_Length
- and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
- Get_Name_String (Spec_Suffix)
- then
- Truncated := True;
- Last := Last - Spec_Suffix_Length;
- end if;
-
- if Truncated then
- Name_Len := Last;
- Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
- Executable :=
- Prj.Util.Value_Of
- (Name => Name_Find,
- Index => 0,
- Attribute_Or_Array_Name => Name_Executable,
- In_Package => Builder_Package,
- Shared => Shared);
- end if;
- end;
- end if;
-
- -- If we have found an Executable attribute, return its value,
- -- possibly suffixed by the executable suffix.
-
- if Executable /= Nil_Variable_Value
- and then Executable.Value /= No_Name
- and then Length_Of_Name (Executable.Value) /= 0
- then
- return Add_Suffix (File_Name_Type (Executable.Value));
- end if;
- end if;
-
- Get_Name_String (Main);
-
- -- If there is a body suffix or a spec suffix, remove this suffix,
- -- otherwise remove any suffix ('.' followed by other characters), if
- -- there is one.
-
- if Body_Suffix /= No_Name
- and then Name_Len > Body_Suffix_Length
- and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =
- Get_Name_String (Body_Suffix)
- then
- -- Found the body termination, remove it
-
- Name_Len := Name_Len - Body_Suffix_Length;
-
- elsif Spec_Suffix /= No_Name
- and then Name_Len > Spec_Suffix_Length
- and then
- Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
- Get_Name_String (Spec_Suffix)
- then
- -- Found the spec termination, remove it
-
- Name_Len := Name_Len - Spec_Suffix_Length;
-
- else
- -- Remove any suffix, if there is one
-
- Get_Name_String (Strip_Suffix (Main));
- end if;
-
- return Add_Suffix (Name_Find);
- end Executable_Of;
-
- ---------------------------
- -- For_Interface_Sources --
- ---------------------------
-
- procedure For_Interface_Sources
- (Tree : Project_Tree_Ref;
- Project : Project_Id)
- is
- use Ada;
- use type Ada.Containers.Count_Type;
-
- package Dep_Names is new Containers.Indefinite_Ordered_Sets (String);
-
- function Load_ALI (Filename : String) return ALI_Id;
- -- Load an ALI file and return its id
-
- --------------
- -- Load_ALI --
- --------------
-
- function Load_ALI (Filename : String) return ALI_Id is
- Result : ALI_Id := No_ALI_Id;
- Text : Text_Buffer_Ptr;
- Lib_File : File_Name_Type;
-
- begin
- if Directories.Exists (Filename) then
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Filename);
- Lib_File := Name_Find;
- Text := Osint.Read_Library_Info (Lib_File);
- Result :=
- ALI.Scan_ALI
- (Lib_File,
- Text,
- Ignore_ED => False,
- Err => True,
- Read_Lines => "UD");
- Free (Text);
- end if;
-
- return Result;
- end Load_ALI;
-
- -- Local declarations
-
- Iter : Source_Iterator;
- Sid : Source_Id;
- ALI : ALI_Id;
-
- First_Unit : Unit_Id;
- Second_Unit : Unit_Id;
- Body_Needed : Boolean;
- Deps : Dep_Names.Set;
-
- -- Start of processing for For_Interface_Sources
-
- begin
- if Project.Qualifier = Aggregate_Library then
- Iter := For_Each_Source (Tree);
- else
- Iter := For_Each_Source (Tree, Project);
- end if;
-
- -- First look at each spec, check if the body is needed
-
- loop
- Sid := Element (Iter);
- exit when Sid = No_Source;
-
- -- Skip sources that are removed/excluded and sources not part of
- -- the interface for standalone libraries.
-
- if Sid.Kind = Spec
- and then (not Sid.Project.Externally_Built
- or else Sid.Project = Project)
- and then not Sid.Locally_Removed
- and then (Project.Standalone_Library = No
- or else Sid.Declared_In_Interfaces)
-
- -- Handle case of non-compilable languages
-
- and then Sid.Dep_Name /= No_File
- then
- Action (Sid);
-
- -- Check ALI for dependencies on body and sep
-
- ALI :=
- Load_ALI
- (Get_Name_String (Get_Object_Directory (Sid.Project, True))
- & Get_Name_String (Sid.Dep_Name));
-
- if ALI /= No_ALI_Id then
- First_Unit := ALIs.Table (ALI).First_Unit;
- Second_Unit := No_Unit_Id;
- Body_Needed := True;
-
- -- If there is both a spec and a body, check if both needed
-
- if Units.Table (First_Unit).Utype = Is_Body then
- Second_Unit := ALIs.Table (ALI).Last_Unit;
-
- -- If the body is not needed, then reset First_Unit
-
- if not Units.Table (Second_Unit).Body_Needed_For_SAL then
- Body_Needed := False;
- end if;
-
- elsif Units.Table (First_Unit).Utype = Is_Spec_Only then
- Body_Needed := False;
- end if;
-
- -- Handle all the separates, if any
-
- if Body_Needed then
- if Other_Part (Sid) /= null then
- Deps.Include (Get_Name_String (Other_Part (Sid).File));
- end if;
-
- for Dep in ALIs.Table (ALI).First_Sdep ..
- ALIs.Table (ALI).Last_Sdep
- loop
- if Sdep.Table (Dep).Subunit_Name /= No_Name then
- Deps.Include
- (Get_Name_String (Sdep.Table (Dep).Sfile));
- end if;
- end loop;
- end if;
- end if;
- end if;
-
- Next (Iter);
- end loop;
-
- -- Now handle the bodies and separates if needed
-
- if Deps.Length /= 0 then
- if Project.Qualifier = Aggregate_Library then
- Iter := For_Each_Source (Tree);
- else
- Iter := For_Each_Source (Tree, Project);
- end if;
-
- loop
- Sid := Element (Iter);
- exit when Sid = No_Source;
-
- if Sid.Kind /= Spec
- and then Deps.Contains (Get_Name_String (Sid.File))
- then
- Action (Sid);
- end if;
-
- Next (Iter);
- end loop;
- end if;
- end For_Interface_Sources;
-
- --------------
- -- Get_Line --
- --------------
-
- procedure Get_Line
- (File : Text_File;
- Line : out String;
- Last : out Natural)
- is
- C : Character;
-
- procedure Advance;
-
- -------------
- -- Advance --
- -------------
-
- procedure Advance is
- begin
- if File.Cursor = File.Buffer_Len then
- File.Buffer_Len :=
- Read
- (FD => File.FD,
- A => File.Buffer'Address,
- N => File.Buffer'Length);
-
- if File.Buffer_Len = 0 then
- File.End_Of_File_Reached := True;
- return;
- else
- File.Cursor := 1;
- end if;
-
- else
- File.Cursor := File.Cursor + 1;
- end if;
- end Advance;
-
- -- Start of processing for Get_Line
-
- begin
- if File = null then
- Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
-
- elsif File.Out_File then
- Prj.Com.Fail ("Get_Line attempted on an out file");
- end if;
-
- Last := Line'First - 1;
-
- if not File.End_Of_File_Reached then
- loop
- C := File.Buffer (File.Cursor);
- exit when C = ASCII.CR or else C = ASCII.LF;
- Last := Last + 1;
- Line (Last) := C;
- Advance;
-
- if File.End_Of_File_Reached then
- return;
- end if;
-
- exit when Last = Line'Last;
- end loop;
-
- if C = ASCII.CR or else C = ASCII.LF then
- Advance;
-
- if File.End_Of_File_Reached then
- return;
- end if;
- end if;
-
- if C = ASCII.CR
- and then File.Buffer (File.Cursor) = ASCII.LF
- then
- Advance;
- end if;
- end if;
- end Get_Line;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize
- (Iter : out Source_Info_Iterator;
- For_Project : Name_Id)
- is
- Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project);
- begin
- if Ind = 0 then
- Iter := (No_Source_Info, 0);
- else
- Iter := Source_Info_Table.Table (Ind);
- end if;
- end Initialize;
-
- --------------
- -- Is_Valid --
- --------------
-
- function Is_Valid (File : Text_File) return Boolean is
- begin
- return File /= null;
- end Is_Valid;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Iter : in out Source_Info_Iterator) is
- begin
- if Iter.Next = 0 then
- Iter.Info := No_Source_Info;
-
- else
- Iter := Source_Info_Table.Table (Iter.Next);
- end if;
- end Next;
-
- ----------
- -- Open --
- ----------
-
- procedure Open (File : out Text_File; Name : String) is
- FD : File_Descriptor;
- File_Name : String (1 .. Name'Length + 1);
-
- begin
- File_Name (1 .. Name'Length) := Name;
- File_Name (File_Name'Last) := ASCII.NUL;
- FD := Open_Read (Name => File_Name'Address,
- Fmode => GNAT.OS_Lib.Text);
-
- if FD = Invalid_FD then
- File := null;
-
- else
- File := new Text_File_Data;
- File.FD := FD;
- File.Buffer_Len :=
- Read (FD => FD,
- A => File.Buffer'Address,
- N => File.Buffer'Length);
-
- if File.Buffer_Len = 0 then
- File.End_Of_File_Reached := True;
- else
- File.Cursor := 1;
- end if;
- end if;
- end Open;
-
- ---------
- -- Put --
- ---------
-
- procedure Put
- (Into_List : in out Name_List_Index;
- From_List : String_List_Id;
- In_Tree : Project_Tree_Ref;
- Lower_Case : Boolean := False)
- is
- Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
-
- Current_Name : Name_List_Index;
- List : String_List_Id;
- Element : String_Element;
- Last : Name_List_Index :=
- Name_List_Table.Last (Shared.Name_Lists);
- Value : Name_Id;
-
- begin
- Current_Name := Into_List;
- while Current_Name /= No_Name_List
- and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List
- loop
- Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
- end loop;
-
- List := From_List;
- while List /= Nil_String loop
- Element := Shared.String_Elements.Table (List);
- Value := Element.Value;
-
- if Lower_Case then
- Get_Name_String (Value);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Value := Name_Find;
- end if;
-
- Name_List_Table.Append
- (Shared.Name_Lists, (Name => Value, Next => No_Name_List));
-
- Last := Last + 1;
-
- if Current_Name = No_Name_List then
- Into_List := Last;
- else
- Shared.Name_Lists.Table (Current_Name).Next := Last;
- end if;
-
- Current_Name := Last;
-
- List := Element.Next;
- end loop;
- end Put;
-
- procedure Put (File : Text_File; S : String) is
- Len : Integer;
- begin
- if File = null then
- Prj.Com.Fail ("Attempted to write on an invalid Text_File");
-
- elsif not File.Out_File then
- Prj.Com.Fail ("Attempted to write an in Text_File");
- end if;
-
- if File.Buffer_Len + S'Length > File.Buffer'Last then
- -- Write buffer
- Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
-
- if Len /= File.Buffer_Len then
- Prj.Com.Fail ("Failed to write to an out Text_File");
- end if;
-
- File.Buffer_Len := 0;
- end if;
-
- File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
- File.Buffer_Len := File.Buffer_Len + S'Length;
- end Put;
-
- --------------
- -- Put_Line --
- --------------
-
- procedure Put_Line (File : Text_File; Line : String) is
- L : String (1 .. Line'Length + 1);
- begin
- L (1 .. Line'Length) := Line;
- L (L'Last) := ASCII.LF;
- Put (File, L);
- end Put_Line;
-
- -------------------
- -- Relative_Path --
- -------------------
-
- function Relative_Path (Pathname : String; To : String) return String is
- function Ensure_Directory (Path : String) return String;
- -- Returns Path with an added directory separator if needed
-
- ----------------------
- -- Ensure_Directory --
- ----------------------
-
- function Ensure_Directory (Path : String) return String is
- begin
- if Path'Length = 0
- or else Path (Path'Last) = Directory_Separator
- or else Path (Path'Last) = '/' -- on Windows check also for /
- then
- return Path;
- else
- return Path & Directory_Separator;
- end if;
- end Ensure_Directory;
-
- -- Local variables
-
- Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
-
- P : String (1 .. Pathname'Length) := Pathname;
- T : String (1 .. To'Length) := To;
-
- Pi : Natural; -- common prefix ending
- N : Natural := 0;
-
- -- Start of processing for Relative_Path
-
- begin
- pragma Assert (Is_Absolute_Path (Pathname));
- pragma Assert (Is_Absolute_Path (To));
-
- -- Use canonical directory separator
-
- Translate (Source => P, Mapping => Dir_Sep_Map);
- Translate (Source => T, Mapping => Dir_Sep_Map);
-
- -- First check for common prefix
-
- Pi := 1;
- while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop
- Pi := Pi + 1;
- end loop;
-
- -- Cut common prefix at a directory separator
-
- while Pi > P'First and then P (Pi) /= '/' loop
- Pi := Pi - 1;
- end loop;
-
- -- Count directory under prefix in P, these will be replaced by the
- -- corresponding number of "..".
-
- N := Count (T (Pi + 1 .. T'Last), "/");
-
- if T (T'Last) /= '/' then
- N := N + 1;
- end if;
-
- return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last));
- end Relative_Path;
-
- ---------------------------
- -- Read_Source_Info_File --
- ---------------------------
-
- procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
- File : Text_File;
- Info : Source_Info_Iterator;
- Proj : Name_Id;
-
- procedure Report_Error;
-
- ------------------
- -- Report_Error --
- ------------------
-
- procedure Report_Error is
- begin
- Write_Line ("errors in source info file """ &
- Tree.Source_Info_File_Name.all & '"');
- Tree.Source_Info_File_Exists := False;
- end Report_Error;
-
- begin
- Source_Info_Project_HTable.Reset;
- Source_Info_Table.Init;
-
- if Tree.Source_Info_File_Name = null then
- Tree.Source_Info_File_Exists := False;
- return;
- end if;
-
- Open (File, Tree.Source_Info_File_Name.all);
-
- if not Is_Valid (File) then
- if Opt.Verbose_Mode then
- Write_Line ("source info file " & Tree.Source_Info_File_Name.all &
- " does not exist");
- end if;
-
- Tree.Source_Info_File_Exists := False;
- return;
- end if;
-
- Tree.Source_Info_File_Exists := True;
-
- if Opt.Verbose_Mode then
- Write_Line ("Reading source info file " &
- Tree.Source_Info_File_Name.all);
- end if;
-
- Source_Loop :
- while not End_Of_File (File) loop
- Info := (new Source_Info_Data, 0);
- Source_Info_Table.Increment_Last;
-
- -- project name
- Get_Line (File, Name_Buffer, Name_Len);
- Proj := Name_Find;
- Info.Info.Project := Proj;
- Info.Next := Source_Info_Project_HTable.Get (Proj);
- Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last);
-
- if End_Of_File (File) then
- Report_Error;
- exit Source_Loop;
- end if;
-
- -- language name
- Get_Line (File, Name_Buffer, Name_Len);
- Info.Info.Language := Name_Find;
-
- if End_Of_File (File) then
- Report_Error;
- exit Source_Loop;
- end if;
-
- -- kind
- Get_Line (File, Name_Buffer, Name_Len);
- Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
-
- if End_Of_File (File) then
- Report_Error;
- exit Source_Loop;
- end if;
-
- -- display path name
- Get_Line (File, Name_Buffer, Name_Len);
- Info.Info.Display_Path_Name := Name_Find;
- Info.Info.Path_Name := Info.Info.Display_Path_Name;
-
- if End_Of_File (File) then
- Report_Error;
- exit Source_Loop;
- end if;
-
- -- optional fields
- Option_Loop :
- loop
- Get_Line (File, Name_Buffer, Name_Len);
- exit Option_Loop when Name_Len = 0;
-
- if Name_Len <= 2 then
- Report_Error;
- exit Source_Loop;
-
- else
- if Name_Buffer (1 .. 2) = "P=" then
- Name_Buffer (1 .. Name_Len - 2) :=
- Name_Buffer (3 .. Name_Len);
- Name_Len := Name_Len - 2;
- Info.Info.Path_Name := Name_Find;
-
- elsif Name_Buffer (1 .. 2) = "U=" then
- Name_Buffer (1 .. Name_Len - 2) :=
- Name_Buffer (3 .. Name_Len);
- Name_Len := Name_Len - 2;
- Info.Info.Unit_Name := Name_Find;
-
- elsif Name_Buffer (1 .. 2) = "I=" then
- Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
-
- elsif Name_Buffer (1 .. Name_Len) = "N=Y" then
- Info.Info.Naming_Exception := Yes;
-
- elsif Name_Buffer (1 .. Name_Len) = "N=I" then
- Info.Info.Naming_Exception := Inherited;
-
- else
- Report_Error;
- exit Source_Loop;
- end if;
- end if;
- end loop Option_Loop;
-
- Source_Info_Table.Table (Source_Info_Table.Last) := Info;
- end loop Source_Loop;
-
- Close (File);
-
- exception
- when others =>
- Close (File);
- Report_Error;
- end Read_Source_Info_File;
-
- --------------------
- -- Source_Info_Of --
- --------------------
-
- function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
- begin
- return Iter.Info;
- end Source_Info_Of;
-
- --------------
- -- Value_Of --
- --------------
-
- function Value_Of
- (Variable : Variable_Value;
- Default : String) return String
- is
- begin
- if Variable.Kind /= Single
- or else Variable.Default
- or else Variable.Value = No_Name
- then
- return Default;
- else
- return Get_Name_String (Variable.Value);
- end if;
- end Value_Of;
-
- function Value_Of
- (Index : Name_Id;
- In_Array : Array_Element_Id;
- Shared : Shared_Project_Tree_Data_Access) return Name_Id
- is
-
- Current : Array_Element_Id;
- Element : Array_Element;
- Real_Index : Name_Id := Index;
-
- begin
- Current := In_Array;
-
- if Current = No_Array_Element then
- return No_Name;
- end if;
-
- Element := Shared.Array_Elements.Table (Current);
-
- if not Element.Index_Case_Sensitive then
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Real_Index := Name_Find;
- end if;
-
- while Current /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Current);
-
- if Real_Index = Element.Index then
- exit when Element.Value.Kind /= Single;
- exit when Element.Value.Value = Empty_String;
- return Element.Value.Value;
- else
- Current := Element.Next;
- end if;
- end loop;
-
- return No_Name;
- end Value_Of;
-
- function Value_Of
- (Index : Name_Id;
- Src_Index : Int := 0;
- In_Array : Array_Element_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Force_Lower_Case_Index : Boolean := False;
- Allow_Wildcards : Boolean := False) return Variable_Value
- is
- Current : Array_Element_Id;
- Element : Array_Element;
- Real_Index_1 : Name_Id;
- Real_Index_2 : Name_Id;
-
- begin
- Current := In_Array;
-
- if Current = No_Array_Element then
- return Nil_Variable_Value;
- end if;
-
- Element := Shared.Array_Elements.Table (Current);
-
- Real_Index_1 := Index;
-
- if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
- if Index /= All_Other_Names then
- Get_Name_String (Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Real_Index_1 := Name_Find;
- end if;
- end if;
-
- while Current /= No_Array_Element loop
- Element := Shared.Array_Elements.Table (Current);
- Real_Index_2 := Element.Index;
-
- if not Element.Index_Case_Sensitive
- or else Force_Lower_Case_Index
- then
- if Element.Index /= All_Other_Names then
- Get_Name_String (Element.Index);
- To_Lower (Name_Buffer (1 .. Name_Len));
- Real_Index_2 := Name_Find;
- end if;
- end if;
-
- if Src_Index = Element.Src_Index and then
- (Real_Index_1 = Real_Index_2 or else
- (Real_Index_2 /= All_Other_Names and then
- Allow_Wildcards and then
- Match (Get_Name_String (Real_Index_1),
- Compile (Get_Name_String (Real_Index_2),
- Glob => True))))
- then
- return Element.Value;
- else
- Current := Element.Next;
- end if;
- end loop;
-
- return Nil_Variable_Value;
- end Value_Of;
-
- function Value_Of
- (Name : Name_Id;
- Index : Int := 0;
- Attribute_Or_Array_Name : Name_Id;
- In_Package : Package_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Force_Lower_Case_Index : Boolean := False;
- Allow_Wildcards : Boolean := False) return Variable_Value
- is
- The_Array : Array_Element_Id;
- The_Attribute : Variable_Value := Nil_Variable_Value;
-
- begin
- if In_Package /= No_Package then
-
- -- First, look if there is an array element that fits
-
- The_Array :=
- Value_Of
- (Name => Attribute_Or_Array_Name,
- In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
- Shared => Shared);
- The_Attribute :=
- Value_Of
- (Index => Name,
- Src_Index => Index,
- In_Array => The_Array,
- Shared => Shared,
- Force_Lower_Case_Index => Force_Lower_Case_Index,
- Allow_Wildcards => Allow_Wildcards);
-
- -- If there is no array element, look for a variable
-
- if The_Attribute = Nil_Variable_Value then
- The_Attribute :=
- Value_Of
- (Variable_Name => Attribute_Or_Array_Name,
- In_Variables => Shared.Packages.Table
- (In_Package).Decl.Attributes,
- Shared => Shared);
- end if;
- end if;
-
- return The_Attribute;
- end Value_Of;
-
- function Value_Of
- (Index : Name_Id;
- In_Array : Name_Id;
- In_Arrays : Array_Id;
- Shared : Shared_Project_Tree_Data_Access) return Name_Id
- is
- Current : Array_Id;
- The_Array : Array_Data;
-
- begin
- Current := In_Arrays;
- while Current /= No_Array loop
- The_Array := Shared.Arrays.Table (Current);
- if The_Array.Name = In_Array then
- return Value_Of
- (Index, In_Array => The_Array.Value, Shared => Shared);
- else
- Current := The_Array.Next;
- end if;
- end loop;
-
- return No_Name;
- end Value_Of;
-
- function Value_Of
- (Name : Name_Id;
- In_Arrays : Array_Id;
- Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id
- is
- Current : Array_Id;
- The_Array : Array_Data;
-
- begin
- Current := In_Arrays;
- while Current /= No_Array loop
- The_Array := Shared.Arrays.Table (Current);
-
- if The_Array.Name = Name then
- return The_Array.Value;
- else
- Current := The_Array.Next;
- end if;
- end loop;
-
- return No_Array_Element;
- end Value_Of;
-
- function Value_Of
- (Name : Name_Id;
- In_Packages : Package_Id;
- Shared : Shared_Project_Tree_Data_Access) return Package_Id
- is
- Current : Package_Id;
- The_Package : Package_Element;
-
- begin
- Current := In_Packages;
- while Current /= No_Package loop
- The_Package := Shared.Packages.Table (Current);
- exit when The_Package.Name /= No_Name
- and then The_Package.Name = Name;
- Current := The_Package.Next;
- end loop;
-
- return Current;
- end Value_Of;
-
- function Value_Of
- (Variable_Name : Name_Id;
- In_Variables : Variable_Id;
- Shared : Shared_Project_Tree_Data_Access) return Variable_Value
- is
- Current : Variable_Id;
- The_Variable : Variable;
-
- begin
- Current := In_Variables;
- while Current /= No_Variable loop
- The_Variable := Shared.Variable_Elements.Table (Current);
-
- if Variable_Name = The_Variable.Name then
- return The_Variable.Value;
- else
- Current := The_Variable.Next;
- end if;
- end loop;
-
- return Nil_Variable_Value;
- end Value_Of;
-
- ----------------------------
- -- Write_Source_Info_File --
- ----------------------------
-
- procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
- Iter : Source_Iterator := For_Each_Source (Tree);
- Source : Prj.Source_Id;
- File : Text_File;
-
- begin
- if Opt.Verbose_Mode then
- Write_Line ("Writing new source info file " &
- Tree.Source_Info_File_Name.all);
- end if;
-
- Create (File, Tree.Source_Info_File_Name.all);
-
- if not Is_Valid (File) then
- Write_Line ("warning: unable to create source info file """ &
- Tree.Source_Info_File_Name.all & '"');
- return;
- end if;
-
- loop
- Source := Element (Iter);
- exit when Source = No_Source;
-
- if not Source.Locally_Removed and then
- Source.Replaced_By = No_Source
- then
- -- Project name
-
- Put_Line (File, Get_Name_String (Source.Project.Name));
-
- -- Language name
-
- Put_Line (File, Get_Name_String (Source.Language.Name));
-
- -- Kind
-
- Put_Line (File, Source.Kind'Img);
-
- -- Display path name
-
- Put_Line (File, Get_Name_String (Source.Path.Display_Name));
-
- -- Optional lines:
-
- -- Path name (P=)
-
- if Source.Path.Name /= Source.Path.Display_Name then
- Put (File, "P=");
- Put_Line (File, Get_Name_String (Source.Path.Name));
- end if;
-
- -- Unit name (U=)
-
- if Source.Unit /= No_Unit_Index then
- Put (File, "U=");
- Put_Line (File, Get_Name_String (Source.Unit.Name));
- end if;
-
- -- Multi-source index (I=)
-
- if Source.Index /= 0 then
- Put (File, "I=");
- Put_Line (File, Source.Index'Img);
- end if;
-
- -- Naming exception ("N=T");
-
- if Source.Naming_Exception = Yes then
- Put_Line (File, "N=Y");
-
- elsif Source.Naming_Exception = Inherited then
- Put_Line (File, "N=I");
- end if;
-
- -- Empty line to indicate end of info on this source
-
- Put_Line (File, "");
- end if;
-
- Next (Iter);
- end loop;
-
- Close (File);
- end Write_Source_Info_File;
-
- ---------------
- -- Write_Str --
- ---------------
-
- procedure Write_Str
- (S : String;
- Max_Length : Positive;
- Separator : Character)
- is
- First : Positive := S'First;
- Last : Natural := S'Last;
-
- begin
- -- Nothing to do for empty strings
-
- if S'Length > 0 then
-
- -- Start on a new line if current line is already longer than
- -- Max_Length.
-
- if Positive (Column) >= Max_Length then
- Write_Eol;
- end if;
-
- -- If length of remainder is longer than Max_Length, we need to
- -- cut the remainder in several lines.
-
- while Positive (Column) + S'Last - First > Max_Length loop
-
- -- Try the maximum length possible
-
- Last := First + Max_Length - Positive (Column);
-
- -- Look for last Separator in the line
-
- while Last >= First and then S (Last) /= Separator loop
- Last := Last - 1;
- end loop;
-
- -- If we do not find a separator, output maximum length possible
-
- if Last < First then
- Last := First + Max_Length - Positive (Column);
- end if;
-
- Write_Line (S (First .. Last));
-
- -- Set the beginning of the new remainder
-
- First := Last + 1;
- end loop;
-
- -- What is left goes to the buffer, without EOL
-
- Write_Str (S (First .. S'Last));
- end if;
- end Write_Str;
-
-end Prj.Util;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J . U T I L --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- Utilities for use in processing project files
-
-package Prj.Util is
-
- function Executable_Of
- (Project : Project_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Main : File_Name_Type;
- Index : Int;
- Ada_Main : Boolean := True;
- Language : String := "";
- Include_Suffix : Boolean := True) return File_Name_Type;
- -- Return the value of the attribute Builder'Executable for file Main in
- -- the project Project, if it exists. If there is no attribute Executable
- -- for Main, remove the suffix from Main; then, if the attribute
- -- Executable_Suffix is specified, add this suffix, otherwise add the
- -- standard executable suffix for the platform.
- --
- -- If Include_Suffix is true, then the ".exe" suffix (or any suffix defined
- -- in the config) will be added. The suffix defined by the user in his own
- -- project file is always taken into account. Otherwise, such a suffix is
- -- not added. In particular, the prefix should not be added if you are
- -- potentially testing for cross-platforms, since the suffix might not be
- -- known (its default value comes from the ...-gnatmake prefix).
- --
- -- What is Ada_Main???
- -- What is Language???
-
- procedure Put
- (Into_List : in out Name_List_Index;
- From_List : String_List_Id;
- In_Tree : Project_Tree_Ref;
- Lower_Case : Boolean := False);
- -- Append a name list to a string list
- -- Describe parameters???
-
- procedure Duplicate
- (This : in out Name_List_Index;
- Shared : Shared_Project_Tree_Data_Access);
- -- Duplicate a name list
-
- function Value_Of
- (Variable : Variable_Value;
- Default : String) return String;
- -- Get the value of a single string variable. If Variable is a string list,
- -- is Nil_Variable_Value,or is defaulted, return Default.
-
- function Value_Of
- (Index : Name_Id;
- In_Array : Array_Element_Id;
- Shared : Shared_Project_Tree_Data_Access) return Name_Id;
- -- Get a single string array component. Returns No_Name if there is no
- -- component Index, if In_Array is null, or if the component is a String
- -- list. Depending on the attribute (only attributes may be associative
- -- arrays) the index may or may not be case sensitive. If the index is not
- -- case sensitive, it is first set to lower case before the search in the
- -- associative array.
-
- function Value_Of
- (Index : Name_Id;
- Src_Index : Int := 0;
- In_Array : Array_Element_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Force_Lower_Case_Index : Boolean := False;
- Allow_Wildcards : Boolean := False) return Variable_Value;
- -- Get a string array component (single String or String list). Returns
- -- Nil_Variable_Value if no component Index or if In_Array is null.
- --
- -- Depending on the attribute (only attributes may be associative arrays)
- -- the index may or may not be case sensitive. If the index is not case
- -- sensitive, it is first set to lower case before the search in the
- -- associative array.
-
- function Value_Of
- (Name : Name_Id;
- Index : Int := 0;
- Attribute_Or_Array_Name : Name_Id;
- In_Package : Package_Id;
- Shared : Shared_Project_Tree_Data_Access;
- Force_Lower_Case_Index : Boolean := False;
- Allow_Wildcards : Boolean := False) return Variable_Value;
- -- In a specific package:
- -- - if there exists an array Attribute_Or_Array_Name with an index Name,
- -- returns the corresponding component (depending on the attribute, the
- -- index may or may not be case sensitive, see previous function),
- -- - otherwise if there is a single attribute Attribute_Or_Array_Name,
- -- returns this attribute,
- -- - otherwise, returns Nil_Variable_Value.
- -- If In_Package is null, returns Nil_Variable_Value.
-
- function Value_Of
- (Index : Name_Id;
- In_Array : Name_Id;
- In_Arrays : Array_Id;
- Shared : Shared_Project_Tree_Data_Access) return Name_Id;
- -- Get a string array component in an array of an array list. Returns
- -- No_Name if there is no component Index, if In_Arrays is null, if
- -- In_Array is not found in In_Arrays or if the component is a String list.
-
- function Value_Of
- (Name : Name_Id;
- In_Arrays : Array_Id;
- Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id;
- -- Returns a specified array in an array list. Returns No_Array_Element
- -- if In_Arrays is null or if Name is not the name of an array in
- -- In_Arrays. The caller must ensure that Name is in lower case.
-
- function Value_Of
- (Name : Name_Id;
- In_Packages : Package_Id;
- Shared : Shared_Project_Tree_Data_Access) return Package_Id;
- -- Returns a specified package in a package list. Returns No_Package
- -- if In_Packages is null or if Name is not the name of a package in
- -- Package_List. The caller must ensure that Name is in lower case.
-
- function Value_Of
- (Variable_Name : Name_Id;
- In_Variables : Variable_Id;
- Shared : Shared_Project_Tree_Data_Access) return Variable_Value;
- -- Returns a specified variable in a variable list. Returns null if
- -- In_Variables is null or if Variable_Name is not the name of a
- -- variable in In_Variables. Caller must ensure that Name is lower case.
-
- procedure Write_Str
- (S : String;
- Max_Length : Positive;
- Separator : Character);
- -- Output string S using Output.Write_Str. If S is too long to fit in one
- -- line of Max_Length, cut it in several lines, using Separator as the last
- -- character of each line, if possible.
-
- type Text_File is limited private;
- -- Represents a text file (default is invalid text file)
-
- function Is_Valid (File : Text_File) return Boolean;
- -- Returns True if File designates an open text file that has not yet been
- -- closed.
-
- procedure Open (File : out Text_File; Name : String);
- -- Open a text file to read (File is invalid if text file cannot be opened)
-
- procedure Create (File : out Text_File; Name : String);
- -- Create a text file to write (File is invalid if text file cannot be
- -- created).
-
- function End_Of_File (File : Text_File) return Boolean;
- -- Returns True if the end of the text file File has been reached. Fails if
- -- File is invalid. Return True if File is an out file.
-
- procedure Get_Line
- (File : Text_File;
- Line : out String;
- Last : out Natural);
- -- Reads a line from an open text file (fails if File is invalid or in an
- -- out file).
-
- procedure Put (File : Text_File; S : String);
- procedure Put_Line (File : Text_File; Line : String);
- -- Output a string or a line to an out text file (fails if File is invalid
- -- or in an in file).
-
- procedure Close (File : in out Text_File);
- -- Close an open text file. File becomes invalid. Fails if File is already
- -- invalid or if an out file cannot be closed successfully.
-
- -----------------------
- -- Source info files --
- -----------------------
-
- procedure Write_Source_Info_File (Tree : Project_Tree_Ref);
- -- Create a new source info file, with the path name specified in the
- -- project tree data. Issue a warning if it is not possible to create
- -- the new file.
-
- procedure Read_Source_Info_File (Tree : Project_Tree_Ref);
- -- Check if there is a source info file specified for the project Tree. If
- -- so, attempt to read it. If the file exists and is successfully read, set
- -- the flag Source_Info_File_Exists to True for the tree.
-
- type Source_Info_Data is record
- Project : Name_Id;
- Language : Name_Id;
- Kind : Source_Kind;
- Display_Path_Name : Name_Id;
- Path_Name : Name_Id;
- Unit_Name : Name_Id := No_Name;
- Index : Int := 0;
- Naming_Exception : Naming_Exception_Type := No;
- end record;
- -- Data read from a source info file for a single source
-
- type Source_Info is access all Source_Info_Data;
- No_Source_Info : constant Source_Info := null;
-
- type Source_Info_Iterator is private;
- -- Iterator to get the sources for a single project
-
- procedure Initialize
- (Iter : out Source_Info_Iterator;
- For_Project : Name_Id);
- -- Initialize Iter for the project
-
- function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info;
- -- Get the source info for the source corresponding to the current value of
- -- the iterator. Returns No_Source_Info if there is no source corresponding
- -- to the iterator.
-
- procedure Next (Iter : in out Source_Info_Iterator);
- -- Advance the iterator to the next source in the project
-
- generic
- with procedure Action (Source : Source_Id);
- procedure For_Interface_Sources
- (Tree : Project_Tree_Ref;
- Project : Project_Id);
- -- Call Action for every sources that are needed to use Project. This is
- -- either the sources corresponding to the units in attribute Interfaces
- -- or all sources of the project. Note that only the bodies that are
- -- needed (because the unit is generic or contains some inline pragmas)
- -- are handled. This routine must be called only when the project has
- -- been built successfully.
-
- function Relative_Path (Pathname : String; To : String) return String;
- -- Returns the relative pathname which corresponds to Pathname when
- -- starting from directory to. Both Pathname and To must be absolute paths.
-
-private
- type Text_File_Data is record
- FD : File_Descriptor := Invalid_FD;
- Out_File : Boolean := False;
- Buffer : String (1 .. 1_000);
- Buffer_Len : Natural := 0;
- Cursor : Natural := 0;
- End_Of_File_Reached : Boolean := False;
- end record;
-
- type Text_File is access Text_File_Data;
-
- type Source_Info_Iterator is record
- Info : Source_Info;
- Next : Natural;
- end record;
-
-end Prj.Util;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Opt;
-with Osint; use Osint;
-with Output; use Output;
-with Prj.Attr;
-with Prj.Com;
-with Prj.Err; use Prj.Err;
-with Snames; use Snames;
-with Uintp; use Uintp;
-
-with Ada.Characters.Handling; use Ada.Characters.Handling;
-with Ada.Containers.Ordered_Sets;
-with Ada.Unchecked_Deallocation;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-with GNAT.HTable;
-
-package body Prj is
-
- type Restricted_Lang;
- type Restricted_Lang_Access is access Restricted_Lang;
- type Restricted_Lang is record
- Name : Name_Id;
- Next : Restricted_Lang_Access;
- end record;
-
- Restricted_Languages : Restricted_Lang_Access := null;
- -- When null, all languages are allowed, otherwise only the languages in
- -- the list are allowed.
-
- Object_Suffix : constant String := Get_Target_Object_Suffix.all;
- -- File suffix for object files
-
- Initial_Buffer_Size : constant := 100;
- -- Initial size for extensible buffer used in Add_To_Buffer
-
- The_Empty_String : Name_Id := No_Name;
- The_Dot_String : Name_Id := No_Name;
-
- Debug_Level : Integer := 0;
- -- Current indentation level for debug traces
-
- type Cst_String_Access is access constant String;
-
- All_Lower_Case_Image : aliased constant String := "lowercase";
- All_Upper_Case_Image : aliased constant String := "UPPERCASE";
- Mixed_Case_Image : aliased constant String := "MixedCase";
-
- The_Casing_Images : constant array (Known_Casing) of Cst_String_Access :=
- (All_Lower_Case => All_Lower_Case_Image'Access,
- All_Upper_Case => All_Upper_Case_Image'Access,
- Mixed_Case => Mixed_Case_Image'Access);
-
- package Name_Id_Set is
- new Ada.Containers.Ordered_Sets (Element_Type => Name_Id);
-
- procedure Free (Project : in out Project_Id);
- -- Free memory allocated for Project
-
- procedure Free_List (Languages : in out Language_Ptr);
- procedure Free_List (Source : in out Source_Id);
- procedure Free_List (Languages : in out Language_List);
- -- Free memory allocated for the list of languages or sources
-
- procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance);
- -- Resets all Units to No_Unit_Index Unit.File_Names (Spec).Unit &
- -- Unit.File_Names (Impl).Unit in the given table.
-
- procedure Free_Units (Table : in out Units_Htable.Instance);
- -- Free memory allocated for unit information in the project
-
- procedure Language_Changed (Iter : in out Source_Iterator);
- procedure Project_Changed (Iter : in out Source_Iterator);
- -- Called when a new project or language was selected for this iterator
-
- function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
- -- Return True if there is at least one ALI file in the directory Dir
-
- -----------------------------
- -- Add_Restricted_Language --
- -----------------------------
-
- procedure Add_Restricted_Language (Name : String) is
- N : String (1 .. Name'Length) := Name;
- begin
- To_Lower (N);
- Name_Len := 0;
- Add_Str_To_Name_Buffer (N);
- Restricted_Languages :=
- new Restricted_Lang'(Name => Name_Find, Next => Restricted_Languages);
- end Add_Restricted_Language;
-
- -------------------------------------
- -- Remove_All_Restricted_Languages --
- -------------------------------------
-
- procedure Remove_All_Restricted_Languages is
- begin
- Restricted_Languages := null;
- end Remove_All_Restricted_Languages;
-
- -------------------
- -- Add_To_Buffer --
- -------------------
-
- procedure Add_To_Buffer
- (S : String;
- To : in out String_Access;
- Last : in out Natural)
- is
- begin
- if To = null then
- To := new String (1 .. Initial_Buffer_Size);
- Last := 0;
- end if;
-
- -- If Buffer is too small, double its size
-
- while Last + S'Length > To'Last loop
- declare
- New_Buffer : constant String_Access :=
- new String (1 .. 2 * To'Length);
- begin
- New_Buffer (1 .. Last) := To (1 .. Last);
- Free (To);
- To := New_Buffer;
- end;
- end loop;
-
- To (Last + 1 .. Last + S'Length) := S;
- Last := Last + S'Length;
- end Add_To_Buffer;
-
- ---------------------------------
- -- Current_Object_Path_File_Of --
- ---------------------------------
-
- function Current_Object_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type
- is
- begin
- return Shared.Private_Part.Current_Object_Path_File;
- end Current_Object_Path_File_Of;
-
- ---------------------------------
- -- Current_Source_Path_File_Of --
- ---------------------------------
-
- function Current_Source_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access)
- return Path_Name_Type is
- begin
- return Shared.Private_Part.Current_Source_Path_File;
- end Current_Source_Path_File_Of;
-
- ---------------------------
- -- Delete_Temporary_File --
- ---------------------------
-
- procedure Delete_Temporary_File
- (Shared : Shared_Project_Tree_Data_Access := null;
- Path : Path_Name_Type)
- is
- Dont_Care : Boolean;
- pragma Warnings (Off, Dont_Care);
-
- begin
- if not Opt.Keep_Temporary_Files then
- if Current_Verbosity = High then
- Write_Line ("Removing temp file: " & Get_Name_String (Path));
- end if;
-
- Delete_File (Get_Name_String (Path), Dont_Care);
-
- if Shared /= null then
- for Index in
- 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
- loop
- if Shared.Private_Part.Temp_Files.Table (Index) = Path then
- Shared.Private_Part.Temp_Files.Table (Index) := No_Path;
- end if;
- end loop;
- end if;
- end if;
- end Delete_Temporary_File;
-
- ------------------------------
- -- Delete_Temp_Config_Files --
- ------------------------------
-
- procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is
- Success : Boolean;
- pragma Warnings (Off, Success);
-
- Proj : Project_List;
-
- begin
- if not Opt.Keep_Temporary_Files then
- if Project_Tree /= null then
- Proj := Project_Tree.Projects;
- while Proj /= null loop
- if Proj.Project.Config_File_Temp then
- Delete_Temporary_File
- (Project_Tree.Shared, Proj.Project.Config_File_Name);
-
- -- Make sure that we don't have a config file for this
- -- project, in case there are several mains. In this case,
- -- we will recreate another config file: we cannot reuse the
- -- one that we just deleted.
-
- Proj.Project.Config_Checked := False;
- Proj.Project.Config_File_Name := No_Path;
- Proj.Project.Config_File_Temp := False;
- end if;
-
- Proj := Proj.Next;
- end loop;
- end if;
- end if;
- end Delete_Temp_Config_Files;
-
- ---------------------------
- -- Delete_All_Temp_Files --
- ---------------------------
-
- procedure Delete_All_Temp_Files
- (Shared : Shared_Project_Tree_Data_Access)
- is
- Dont_Care : Boolean;
- pragma Warnings (Off, Dont_Care);
-
- Path : Path_Name_Type;
-
- begin
- if not Opt.Keep_Temporary_Files then
- for Index in
- 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
- loop
- Path := Shared.Private_Part.Temp_Files.Table (Index);
-
- if Path /= No_Path then
- if Current_Verbosity = High then
- Write_Line ("Removing temp file: "
- & Get_Name_String (Path));
- end if;
-
- Delete_File (Get_Name_String (Path), Dont_Care);
- end if;
- end loop;
-
- Temp_Files_Table.Free (Shared.Private_Part.Temp_Files);
- Temp_Files_Table.Init (Shared.Private_Part.Temp_Files);
- end if;
-
- -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or
- -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
- -- the empty string.
-
- if Shared.Private_Part.Current_Source_Path_File /= No_Path then
- Setenv (Project_Include_Path_File, "");
- end if;
-
- if Shared.Private_Part.Current_Object_Path_File /= No_Path then
- Setenv (Project_Objects_Path_File, "");
- end if;
- end Delete_All_Temp_Files;
-
- ---------------------
- -- Dependency_Name --
- ---------------------
-
- function Dependency_Name
- (Source_File_Name : File_Name_Type;
- Dependency : Dependency_File_Kind) return File_Name_Type
- is
- begin
- case Dependency is
- when None =>
- return No_File;
-
- when Makefile =>
- return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix);
-
- when ALI_Closure
- | ALI_File
- =>
- return Extend_Name (Source_File_Name, ALI_Dependency_Suffix);
- end case;
- end Dependency_Name;
-
- ----------------
- -- Dot_String --
- ----------------
-
- function Dot_String return Name_Id is
- begin
- return The_Dot_String;
- end Dot_String;
-
- ----------------
- -- Empty_File --
- ----------------
-
- function Empty_File return File_Name_Type is
- begin
- return File_Name_Type (The_Empty_String);
- end Empty_File;
-
- -------------------
- -- Empty_Project --
- -------------------
-
- function Empty_Project
- (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.
-
- Data.Config := Default_Project_Config;
- return Data;
- end;
- end Empty_Project;
-
- ------------------
- -- Empty_String --
- ------------------
-
- function Empty_String return Name_Id is
- begin
- return The_Empty_String;
- end Empty_String;
-
- ------------
- -- Expect --
- ------------
-
- 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;
-
- -----------------
- -- Extend_Name --
- -----------------
-
- function Extend_Name
- (File : File_Name_Type;
- With_Suffix : String) return File_Name_Type
- is
- Last : Positive;
-
- begin
- Get_Name_String (File);
- Last := Name_Len + 1;
-
- while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
- Name_Len := Name_Len - 1;
- end loop;
-
- if Name_Len <= 1 then
- Name_Len := Last;
- end if;
-
- for J in With_Suffix'Range loop
- Name_Buffer (Name_Len) := With_Suffix (J);
- Name_Len := Name_Len + 1;
- end loop;
-
- Name_Len := Name_Len - 1;
- return Name_Find;
- end Extend_Name;
-
- -------------------------
- -- Is_Allowed_Language --
- -------------------------
-
- function Is_Allowed_Language (Name : Name_Id) return Boolean is
- R : Restricted_Lang_Access := Restricted_Languages;
- Lang : constant String := Get_Name_String (Name);
-
- begin
- if R = null then
- return True;
-
- else
- while R /= null loop
- if Get_Name_String (R.Name) = Lang then
- return True;
- end if;
-
- R := R.Next;
- end loop;
-
- return False;
- end if;
- end Is_Allowed_Language;
-
- ---------------------
- -- Project_Changed --
- ---------------------
-
- procedure Project_Changed (Iter : in out Source_Iterator) is
- begin
- if Iter.Project /= null then
- Iter.Language := Iter.Project.Project.Languages;
- Language_Changed (Iter);
- end if;
- end Project_Changed;
-
- ----------------------
- -- Language_Changed --
- ----------------------
-
- procedure Language_Changed (Iter : in out Source_Iterator) is
- begin
- Iter.Current := No_Source;
-
- if Iter.Language_Name /= No_Name then
- while Iter.Language /= null
- and then Iter.Language.Name /= Iter.Language_Name
- loop
- Iter.Language := Iter.Language.Next;
- end loop;
- end if;
-
- -- If there is no matching language in this project, move to next
-
- if Iter.Language = No_Language_Index then
- if Iter.All_Projects then
- loop
- Iter.Project := Iter.Project.Next;
- exit when Iter.Project = null
- or else Iter.Encapsulated_Libs
- or else not Iter.Project.From_Encapsulated_Lib;
- end loop;
-
- Project_Changed (Iter);
- else
- Iter.Project := null;
- end if;
-
- else
- Iter.Current := Iter.Language.First_Source;
-
- if Iter.Current = No_Source then
- Iter.Language := Iter.Language.Next;
- Language_Changed (Iter);
-
- elsif not Iter.Locally_Removed
- and then Iter.Current.Locally_Removed
- then
- Next (Iter);
- end if;
- end if;
- end Language_Changed;
-
- ---------------------
- -- For_Each_Source --
- ---------------------
-
- function For_Each_Source
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id := No_Project;
- Language : Name_Id := No_Name;
- Encapsulated_Libs : Boolean := True;
- Locally_Removed : Boolean := True) return Source_Iterator
- is
- Iter : Source_Iterator;
- begin
- Iter := Source_Iterator'
- (In_Tree => In_Tree,
- Project => In_Tree.Projects,
- All_Projects => Project = No_Project,
- Language_Name => Language,
- Language => No_Language_Index,
- Current => No_Source,
- Encapsulated_Libs => Encapsulated_Libs,
- Locally_Removed => Locally_Removed);
-
- if Project /= null then
- while Iter.Project /= null
- and then Iter.Project.Project /= Project
- loop
- Iter.Project := Iter.Project.Next;
- end loop;
-
- else
- while not Iter.Encapsulated_Libs
- and then Iter.Project.From_Encapsulated_Lib
- loop
- Iter.Project := Iter.Project.Next;
- end loop;
- end if;
-
- Project_Changed (Iter);
-
- return Iter;
- end For_Each_Source;
-
- -------------
- -- Element --
- -------------
-
- function Element (Iter : Source_Iterator) return Source_Id is
- begin
- return Iter.Current;
- end Element;
-
- ----------
- -- Next --
- ----------
-
- procedure Next (Iter : in out Source_Iterator) is
- begin
- loop
- Iter.Current := Iter.Current.Next_In_Lang;
-
- exit when Iter.Locally_Removed
- or else Iter.Current = No_Source
- or else not Iter.Current.Locally_Removed;
- end loop;
-
- if Iter.Current = No_Source then
- Iter.Language := Iter.Language.Next;
- Language_Changed (Iter);
- end if;
- end Next;
-
- --------------------------------
- -- For_Every_Project_Imported --
- --------------------------------
-
- procedure For_Every_Project_Imported_Context
- (By : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out State;
- Include_Aggregated : Boolean := True;
- Imported_First : Boolean := False)
- is
- use Project_Boolean_Htable;
-
- procedure Recursive_Check_Context
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- In_Aggregate_Lib : Boolean;
- From_Encapsulated_Lib : Boolean);
- -- Recursively handle the project tree creating a new context for
- -- keeping track about already handled projects.
-
- -----------------------------
- -- Recursive_Check_Context --
- -----------------------------
-
- procedure Recursive_Check_Context
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- In_Aggregate_Lib : Boolean;
- From_Encapsulated_Lib : Boolean)
- is
- package Name_Id_Set is
- new Ada.Containers.Ordered_Sets (Element_Type => Path_Name_Type);
-
- Seen_Name : Name_Id_Set.Set;
- -- This set is needed to ensure that we do not handle the same
- -- project twice in the context of aggregate libraries.
- -- Since duplicate project names are possible in the context of
- -- aggregated projects, we need to check the full paths.
-
- procedure Recursive_Check
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- In_Aggregate_Lib : Boolean;
- From_Encapsulated_Lib : Boolean);
- -- Check if project has already been seen. If not, mark it as Seen,
- -- Call Action, and check all its imported and aggregated projects.
-
- ---------------------
- -- Recursive_Check --
- ---------------------
-
- procedure Recursive_Check
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- In_Aggregate_Lib : Boolean;
- From_Encapsulated_Lib : Boolean)
- is
-
- function Has_Sources (P : Project_Id) return Boolean;
- -- Returns True if P has sources
-
- function Get_From_Tree (P : Project_Id) return Project_Id;
- -- Get project P from Tree. If P has no sources get another
- -- instance of this project with sources. If P has sources,
- -- returns it.
-
- -----------------
- -- Has_Sources --
- -----------------
-
- function Has_Sources (P : Project_Id) return Boolean is
- Lang : Language_Ptr;
-
- begin
- Lang := P.Languages;
- while Lang /= No_Language_Index loop
- if Lang.First_Source /= No_Source then
- return True;
- end if;
-
- Lang := Lang.Next;
- end loop;
-
- return False;
- end Has_Sources;
-
- -------------------
- -- Get_From_Tree --
- -------------------
-
- function Get_From_Tree (P : Project_Id) return Project_Id is
- List : Project_List := Tree.Projects;
-
- begin
- if not Has_Sources (P) then
- while List /= null loop
- if List.Project.Name = P.Name
- and then Has_Sources (List.Project)
- then
- return List.Project;
- end if;
-
- List := List.Next;
- end loop;
- end if;
-
- return P;
- end Get_From_Tree;
-
- -- Local variables
-
- List : Project_List;
-
- -- Start of processing for Recursive_Check
-
- begin
- if not Seen_Name.Contains (Project.Path.Name) then
-
- -- Even if a project is aggregated multiple times in an
- -- aggregated library, we will only return it once.
-
- Seen_Name.Include (Project.Path.Name);
-
- if not Imported_First then
- Action
- (Get_From_Tree (Project),
- Tree,
- Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
- With_State);
- end if;
-
- -- Visit all extended projects
-
- if Project.Extends /= No_Project then
- Recursive_Check
- (Project.Extends, Tree,
- In_Aggregate_Lib, From_Encapsulated_Lib);
- end if;
-
- -- Visit all imported projects
-
- List := Project.Imported_Projects;
- while List /= null loop
- Recursive_Check
- (List.Project, Tree,
- In_Aggregate_Lib,
- From_Encapsulated_Lib
- or else Project.Standalone_Library = Encapsulated);
- List := List.Next;
- end loop;
-
- -- Visit all aggregated projects
-
- if Include_Aggregated
- and then Project.Qualifier in Aggregate_Project
- then
- declare
- Agg : Aggregated_Project_List;
-
- begin
- Agg := Project.Aggregated_Projects;
- while Agg /= null loop
- pragma Assert (Agg.Project /= No_Project);
-
- -- For aggregated libraries, the tree must be the one
- -- of the aggregate library.
-
- if Project.Qualifier = Aggregate_Library then
- Recursive_Check
- (Agg.Project, Tree,
- True,
- From_Encapsulated_Lib
- or else
- Project.Standalone_Library = Encapsulated);
-
- else
- -- Use a new context as we want to returns the same
- -- project in different project tree for aggregated
- -- projects.
-
- Recursive_Check_Context
- (Agg.Project, Agg.Tree, False, False);
- end if;
-
- Agg := Agg.Next;
- end loop;
- end;
- end if;
-
- if Imported_First then
- Action
- (Get_From_Tree (Project),
- Tree,
- Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
- With_State);
- end if;
- end if;
- end Recursive_Check;
-
- -- Start of processing for Recursive_Check_Context
-
- begin
- Recursive_Check
- (Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib);
- end Recursive_Check_Context;
-
- -- Start of processing for For_Every_Project_Imported
-
- begin
- Recursive_Check_Context
- (Project => By,
- Tree => Tree,
- In_Aggregate_Lib => False,
- From_Encapsulated_Lib => False);
- end For_Every_Project_Imported_Context;
-
- procedure For_Every_Project_Imported
- (By : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out State;
- Include_Aggregated : Boolean := True;
- Imported_First : Boolean := False)
- is
- procedure Internal
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context;
- With_State : in out State);
- -- Action wrapper for handling the context
-
- --------------
- -- Internal --
- --------------
-
- procedure Internal
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context;
- With_State : in out State)
- is
- pragma Unreferenced (Context);
- begin
- Action (Project, Tree, With_State);
- end Internal;
-
- procedure For_Projects is
- new For_Every_Project_Imported_Context (State, Internal);
-
- begin
- For_Projects (By, Tree, With_State, Include_Aggregated, Imported_First);
- end For_Every_Project_Imported;
-
- -----------------
- -- Find_Source --
- -----------------
-
- function Find_Source
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- In_Imported_Only : Boolean := False;
- In_Extended_Only : Boolean := False;
- Base_Name : File_Name_Type;
- Index : Int := 0) return Source_Id
- is
- Result : Source_Id := No_Source;
-
- procedure Look_For_Sources
- (Proj : Project_Id;
- Tree : Project_Tree_Ref;
- Src : in out Source_Id);
- -- Look for Base_Name in the sources of Proj
-
- ----------------------
- -- Look_For_Sources --
- ----------------------
-
- procedure Look_For_Sources
- (Proj : Project_Id;
- Tree : Project_Tree_Ref;
- Src : in out Source_Id)
- is
- Iterator : Source_Iterator;
-
- begin
- Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
- while Element (Iterator) /= No_Source loop
- if Element (Iterator).File = Base_Name
- and then (Index = 0 or else Element (Iterator).Index = Index)
- then
- Src := Element (Iterator);
-
- -- If the source has been excluded, continue looking. We will
- -- get the excluded source only if there is no other source
- -- with the same base name that is not locally removed.
-
- if not Element (Iterator).Locally_Removed then
- return;
- end if;
- end if;
-
- Next (Iterator);
- end loop;
- end Look_For_Sources;
-
- procedure For_Imported_Projects is new For_Every_Project_Imported
- (State => Source_Id, Action => Look_For_Sources);
-
- Proj : Project_Id;
-
- -- Start of processing for Find_Source
-
- begin
- if In_Extended_Only then
- Proj := Project;
- while Proj /= No_Project loop
- Look_For_Sources (Proj, In_Tree, Result);
- exit when Result /= No_Source;
-
- Proj := Proj.Extends;
- end loop;
-
- elsif In_Imported_Only then
- Look_For_Sources (Project, In_Tree, Result);
-
- if Result = No_Source then
- For_Imported_Projects
- (By => Project,
- Tree => In_Tree,
- Include_Aggregated => False,
- With_State => Result);
- end if;
-
- else
- Look_For_Sources (No_Project, In_Tree, Result);
- end if;
-
- return Result;
- end Find_Source;
-
- ----------------------
- -- Find_All_Sources --
- ----------------------
-
- function Find_All_Sources
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- In_Imported_Only : Boolean := False;
- In_Extended_Only : Boolean := False;
- Base_Name : File_Name_Type;
- Index : Int := 0) return Source_Ids
- is
- Result : Source_Ids (1 .. 1_000);
- Last : Natural := 0;
-
- type Empty_State is null record;
- No_State : Empty_State;
- -- This is needed for the State parameter of procedure Look_For_Sources
- -- below, because of the instantiation For_Imported_Projects of generic
- -- procedure For_Every_Project_Imported. As procedure Look_For_Sources
- -- does not modify parameter State, there is no need to give its type
- -- more than one value.
-
- procedure Look_For_Sources
- (Proj : Project_Id;
- Tree : Project_Tree_Ref;
- State : in out Empty_State);
- -- Look for Base_Name in the sources of Proj
-
- ----------------------
- -- Look_For_Sources --
- ----------------------
-
- procedure Look_For_Sources
- (Proj : Project_Id;
- Tree : Project_Tree_Ref;
- State : in out Empty_State)
- is
- Iterator : Source_Iterator;
- Src : Source_Id;
-
- begin
- State := No_State;
-
- Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
- while Element (Iterator) /= No_Source loop
- if Element (Iterator).File = Base_Name
- and then (Index = 0
- or else
- (Element (Iterator).Unit /= No_Unit_Index
- and then
- Element (Iterator).Index = Index))
- then
- Src := Element (Iterator);
-
- -- If the source has been excluded, continue looking. We will
- -- get the excluded source only if there is no other source
- -- with the same base name that is not locally removed.
-
- if not Element (Iterator).Locally_Removed then
- Last := Last + 1;
- Result (Last) := Src;
- end if;
- end if;
-
- Next (Iterator);
- end loop;
- end Look_For_Sources;
-
- procedure For_Imported_Projects is new For_Every_Project_Imported
- (State => Empty_State, Action => Look_For_Sources);
-
- Proj : Project_Id;
-
- -- Start of processing for Find_All_Sources
-
- begin
- if In_Extended_Only then
- Proj := Project;
- while Proj /= No_Project loop
- Look_For_Sources (Proj, In_Tree, No_State);
- exit when Last > 0;
- Proj := Proj.Extends;
- end loop;
-
- elsif In_Imported_Only then
- Look_For_Sources (Project, In_Tree, No_State);
-
- if Last = 0 then
- For_Imported_Projects
- (By => Project,
- Tree => In_Tree,
- Include_Aggregated => False,
- With_State => No_State);
- end if;
-
- else
- Look_For_Sources (No_Project, In_Tree, No_State);
- end if;
-
- return Result (1 .. Last);
- end Find_All_Sources;
-
- ----------
- -- Hash --
- ----------
-
- function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
- -- Used in implementation of other functions Hash below
-
- ----------
- -- Hash --
- ----------
-
- function Hash (Name : File_Name_Type) return Header_Num is
- begin
- return Hash (Get_Name_String (Name));
- end Hash;
-
- function Hash (Name : Name_Id) return Header_Num is
- begin
- return Hash (Get_Name_String (Name));
- end Hash;
-
- function Hash (Name : Path_Name_Type) return Header_Num is
- begin
- return Hash (Get_Name_String (Name));
- end Hash;
-
- function Hash (Project : Project_Id) return Header_Num is
- begin
- if Project = No_Project then
- return Header_Num'First;
- else
- return Hash (Get_Name_String (Project.Name));
- end if;
- end Hash;
-
- -----------
- -- Image --
- -----------
-
- function Image (The_Casing : Casing_Type) return String is
- begin
- return The_Casing_Images (The_Casing).all;
- end Image;
-
- -----------------------------
- -- Is_Standard_GNAT_Naming --
- -----------------------------
-
- function Is_Standard_GNAT_Naming
- (Naming : Lang_Naming_Data) return Boolean
- is
- begin
- return Get_Name_String (Naming.Spec_Suffix) = ".ads"
- and then Get_Name_String (Naming.Body_Suffix) = ".adb"
- and then Get_Name_String (Naming.Dot_Replacement) = "-";
- end Is_Standard_GNAT_Naming;
-
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize (Tree : Project_Tree_Ref) is
- begin
- if The_Empty_String = No_Name then
- Uintp.Initialize;
- Name_Len := 0;
- The_Empty_String := Name_Find;
-
- Name_Len := 1;
- Name_Buffer (1) := '.';
- The_Dot_String := Name_Find;
-
- Prj.Attr.Initialize;
-
- -- Make sure that new reserved words after Ada 95 may be used as
- -- identifiers.
-
- Opt.Ada_Version := Opt.Ada_95;
- Opt.Ada_Version_Pragma := Empty;
-
- Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project));
- Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends));
- Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
- Set_Name_Table_Byte
- (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
- end if;
-
- if Tree /= No_Project_Tree then
- Reset (Tree);
- end if;
- end Initialize;
-
- ------------------
- -- Is_Extending --
- ------------------
-
- function Is_Extending
- (Extending : Project_Id;
- Extended : Project_Id) return Boolean
- is
- Proj : Project_Id;
-
- begin
- Proj := Extending;
- while Proj /= No_Project loop
- if Proj = Extended then
- return True;
- end if;
-
- Proj := Proj.Extends;
- end loop;
-
- return False;
- end Is_Extending;
-
- -----------------
- -- Object_Name --
- -----------------
-
- function Object_Name
- (Source_File_Name : File_Name_Type;
- Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
- is
- begin
- if Object_File_Suffix = No_Name then
- return Extend_Name
- (Source_File_Name, Object_Suffix);
- else
- return Extend_Name
- (Source_File_Name, Get_Name_String (Object_File_Suffix));
- end if;
- end Object_Name;
-
- function Object_Name
- (Source_File_Name : File_Name_Type;
- Source_Index : Int;
- Index_Separator : Character;
- Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
- is
- Index_Img : constant String := Source_Index'Img;
- Last : Natural;
-
- begin
- Get_Name_String (Source_File_Name);
-
- Last := Name_Len;
- while Last > 1 and then Name_Buffer (Last) /= '.' loop
- Last := Last - 1;
- end loop;
-
- if Last > 1 then
- Name_Len := Last - 1;
- end if;
-
- Add_Char_To_Name_Buffer (Index_Separator);
- Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
-
- if Object_File_Suffix = No_Name then
- Add_Str_To_Name_Buffer (Object_Suffix);
- else
- Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
- end if;
-
- return Name_Find;
- end Object_Name;
-
- ----------------------
- -- Record_Temp_File --
- ----------------------
-
- procedure Record_Temp_File
- (Shared : Shared_Project_Tree_Data_Access;
- Path : Path_Name_Type)
- is
- begin
- Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path);
- end Record_Temp_File;
-
- ----------
- -- 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;
-
- Free (List.Tree);
-
- Unchecked_Free (List);
- List := Tmp;
- end loop;
- end Free;
-
- ----------------------------
- -- Add_Aggregated_Project --
- ----------------------------
-
- procedure Add_Aggregated_Project
- (Project : Project_Id;
- Path : Path_Name_Type)
- is
- Aggregated : Aggregated_Project_List;
-
- begin
- -- Check if the project is already in the aggregated project list. If it
- -- is, do not add it again.
-
- Aggregated := Project.Aggregated_Projects;
- while Aggregated /= null loop
- if Path = Aggregated.Path then
- return;
- else
- Aggregated := Aggregated.Next;
- end if;
- end loop;
-
- Project.Aggregated_Projects := new Aggregated_Project'
- (Path => Path,
- Project => No_Project,
- Tree => null,
- 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);
-
- begin
- if Project /= null then
- Free (Project.Ada_Include_Path);
- Free (Project.Objects_Path);
- Free (Project.Ada_Objects_Path);
- Free (Project.Ada_Objects_Path_No_Libs);
- Free_List (Project.Imported_Projects, Free_Project => False);
- Free_List (Project.All_Imported_Projects, Free_Project => False);
- Free_List (Project.Languages);
-
- case Project.Qualifier is
- when Aggregate
- | Aggregate_Library
- =>
- Free (Project.Aggregated_Projects);
-
- when others =>
- null;
- end case;
-
- Unchecked_Free (Project);
- end if;
- end Free;
-
- ---------------
- -- Free_List --
- ---------------
-
- procedure Free_List (Languages : in out Language_List) is
- procedure Unchecked_Free is new Ada.Unchecked_Deallocation
- (Language_List_Element, Language_List);
- Tmp : Language_List;
- begin
- while Languages /= null loop
- Tmp := Languages.Next;
- Unchecked_Free (Languages);
- Languages := Tmp;
- end loop;
- end Free_List;
-
- ---------------
- -- Free_List --
- ---------------
-
- procedure Free_List (Source : in out Source_Id) is
- procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation (Source_Data, Source_Id);
-
- Tmp : Source_Id;
-
- begin
- while Source /= No_Source loop
- Tmp := Source.Next_In_Lang;
- Free_List (Source.Alternate_Languages);
-
- if Source.Unit /= null
- and then Source.Kind in Spec_Or_Body
- then
- Source.Unit.File_Names (Source.Kind) := null;
- end if;
-
- Unchecked_Free (Source);
- Source := Tmp;
- end loop;
- end Free_List;
-
- ---------------
- -- Free_List --
- ---------------
-
- procedure Free_List
- (List : in out Project_List;
- Free_Project : Boolean)
- is
- procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
-
- Tmp : Project_List;
-
- begin
- while List /= null loop
- Tmp := List.Next;
-
- if Free_Project then
- Free (List.Project);
- end if;
-
- Unchecked_Free (List);
- List := Tmp;
- end loop;
- end Free_List;
-
- ---------------
- -- Free_List --
- ---------------
-
- procedure Free_List (Languages : in out Language_Ptr) is
- procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
-
- Tmp : Language_Ptr;
-
- begin
- while Languages /= null loop
- Tmp := Languages.Next;
- Free_List (Languages.First_Source);
- Unchecked_Free (Languages);
- Languages := Tmp;
- end loop;
- end Free_List;
-
- --------------------------
- -- Reset_Units_In_Table --
- --------------------------
-
- procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is
- Unit : Unit_Index;
-
- begin
- Unit := Units_Htable.Get_First (Table);
- while Unit /= No_Unit_Index loop
- if Unit.File_Names (Spec) /= null then
- Unit.File_Names (Spec).Unit := No_Unit_Index;
- end if;
-
- if Unit.File_Names (Impl) /= null then
- Unit.File_Names (Impl).Unit := No_Unit_Index;
- end if;
-
- Unit := Units_Htable.Get_Next (Table);
- end loop;
- end Reset_Units_In_Table;
-
- ----------------
- -- Free_Units --
- ----------------
-
- procedure Free_Units (Table : in out Units_Htable.Instance) is
- procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
-
- Unit : Unit_Index;
-
- begin
- Unit := Units_Htable.Get_First (Table);
- while Unit /= No_Unit_Index loop
-
- -- We cannot reset Unit.File_Names (Impl or Spec).Unit here as
- -- Source_Data buffer is freed by the following instruction
- -- Free_List (Tree.Projects, Free_Project => True);
-
- Unchecked_Free (Unit);
- Unit := Units_Htable.Get_Next (Table);
- end loop;
-
- Units_Htable.Reset (Table);
- end Free_Units;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Tree : in out Project_Tree_Ref) is
- procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation
- (Project_Tree_Data, Project_Tree_Ref);
-
- procedure Unchecked_Free is new
- Ada.Unchecked_Deallocation
- (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access);
-
- begin
- if Tree /= null then
- if Tree.Is_Root_Tree then
- Name_List_Table.Free (Tree.Shared.Name_Lists);
- Number_List_Table.Free (Tree.Shared.Number_Lists);
- String_Element_Table.Free (Tree.Shared.String_Elements);
- Variable_Element_Table.Free (Tree.Shared.Variable_Elements);
- Array_Element_Table.Free (Tree.Shared.Array_Elements);
- Array_Table.Free (Tree.Shared.Arrays);
- Package_Table.Free (Tree.Shared.Packages);
- Temp_Files_Table.Free (Tree.Shared.Private_Part.Temp_Files);
- end if;
-
- if Tree.Appdata /= null then
- Free (Tree.Appdata.all);
- Unchecked_Free (Tree.Appdata);
- end if;
-
- Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
- Source_Files_Htable.Reset (Tree.Source_Files_HT);
-
- Reset_Units_In_Table (Tree.Units_HT);
- Free_List (Tree.Projects, Free_Project => True);
- Free_Units (Tree.Units_HT);
-
- Unchecked_Free (Tree);
- end if;
- end Free;
-
- -----------
- -- Reset --
- -----------
-
- procedure Reset (Tree : Project_Tree_Ref) is
- begin
- -- Visible tables
-
- if Tree.Is_Root_Tree then
-
- -- We cannot use 'Access here:
- -- "illegal attribute for discriminant-dependent component"
- -- However, we know this is valid since Shared and Shared_Data have
- -- the same lifetime and will always exist concurrently.
-
- Tree.Shared := Tree.Shared_Data'Unrestricted_Access;
- Name_List_Table.Init (Tree.Shared.Name_Lists);
- Number_List_Table.Init (Tree.Shared.Number_Lists);
- String_Element_Table.Init (Tree.Shared.String_Elements);
- Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
- Array_Element_Table.Init (Tree.Shared.Array_Elements);
- Array_Table.Init (Tree.Shared.Arrays);
- Package_Table.Init (Tree.Shared.Packages);
-
- -- Create Dot_String_List
-
- String_Element_Table.Append
- (Tree.Shared.String_Elements,
- String_Element'
- (Value => The_Dot_String,
- Index => 0,
- Display_Value => The_Dot_String,
- Location => No_Location,
- Flag => False,
- Next => Nil_String));
- Tree.Shared.Dot_String_List :=
- String_Element_Table.Last (Tree.Shared.String_Elements);
-
- -- Private part table
-
- Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files);
-
- Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
- Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
- end if;
-
- Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
- Source_Files_Htable.Reset (Tree.Source_Files_HT);
- Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
-
- Tree.Replaced_Source_Number := 0;
-
- Reset_Units_In_Table (Tree.Units_HT);
- Free_List (Tree.Projects, Free_Project => True);
- Free_Units (Tree.Units_HT);
- end Reset;
-
- -------------------------------------
- -- Set_Current_Object_Path_File_Of --
- -------------------------------------
-
- procedure Set_Current_Object_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access;
- To : Path_Name_Type)
- is
- begin
- Shared.Private_Part.Current_Object_Path_File := To;
- end Set_Current_Object_Path_File_Of;
-
- -------------------------------------
- -- Set_Current_Source_Path_File_Of --
- -------------------------------------
-
- procedure Set_Current_Source_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access;
- To : Path_Name_Type)
- is
- begin
- Shared.Private_Part.Current_Source_Path_File := To;
- end Set_Current_Source_Path_File_Of;
-
- -----------------------
- -- Set_Path_File_Var --
- -----------------------
-
- procedure Set_Path_File_Var (Name : String; Value : String) is
- Host_Spec : String_Access := To_Host_File_Spec (Value);
- begin
- if Host_Spec = null then
- Prj.Com.Fail
- ("could not convert file name """ & Value & """ to host spec");
- else
- Setenv (Name, Host_Spec.all);
- Free (Host_Spec);
- end if;
- end Set_Path_File_Var;
-
- -------------------
- -- Switches_Name --
- -------------------
-
- function Switches_Name
- (Source_File_Name : File_Name_Type) return File_Name_Type
- is
- begin
- return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
- end Switches_Name;
-
- -----------
- -- Value --
- -----------
-
- function Value (Image : String) return Casing_Type is
- begin
- for Casing in The_Casing_Images'Range loop
- if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
- return Casing;
- end if;
- end loop;
-
- raise Constraint_Error;
- end Value;
-
- ---------------------
- -- Has_Ada_Sources --
- ---------------------
-
- function Has_Ada_Sources (Data : Project_Id) return Boolean is
- Lang : Language_Ptr;
-
- begin
- Lang := Data.Languages;
- while Lang /= No_Language_Index loop
- if Lang.Name = Name_Ada then
- return Lang.First_Source /= No_Source;
- end if;
- Lang := Lang.Next;
- end loop;
-
- return False;
- end Has_Ada_Sources;
-
- ------------------------
- -- Contains_ALI_Files --
- ------------------------
-
- function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
- Dir_Name : constant String := Get_Name_String (Dir);
- Direct : Dir_Type;
- Name : String (1 .. 1_000);
- Last : Natural;
- Result : Boolean := False;
-
- begin
- Open (Direct, Dir_Name);
-
- -- For each file in the directory, check if it is an ALI file
-
- loop
- Read (Direct, Name, Last);
- exit when Last = 0;
- Canonical_Case_File_Name (Name (1 .. Last));
- Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
- exit when Result;
- end loop;
-
- Close (Direct);
- return Result;
-
- exception
- -- If there is any problem, close the directory if open and return True.
- -- The library directory will be added to the path.
-
- when others =>
- if Is_Open (Direct) then
- Close (Direct);
- end if;
-
- return True;
- end Contains_ALI_Files;
-
- --------------------------
- -- Get_Object_Directory --
- --------------------------
-
- function Get_Object_Directory
- (Project : Project_Id;
- Including_Libraries : Boolean;
- Only_If_Ada : Boolean := False) return Path_Name_Type
- is
- begin
- if (Project.Library and then Including_Libraries)
- or else
- (Project.Object_Directory /= No_Path_Information
- and then (not Including_Libraries or else not Project.Library))
- then
- -- For a library project, add the library ALI directory if there is
- -- no object directory or if the library ALI directory contains ALI
- -- files; otherwise add the object directory.
-
- if Project.Library then
- if Project.Object_Directory = No_Path_Information
- or else
- (Including_Libraries
- and then
- Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name))
- then
- return Project.Library_ALI_Dir.Display_Name;
- else
- return Project.Object_Directory.Display_Name;
- end if;
-
- -- For a non-library project, add object directory if it is not a
- -- virtual project, and if there are Ada sources in the project or
- -- one of the projects it extends. If there are no Ada sources,
- -- adding the object directory could disrupt the order of the
- -- object dirs in the path.
-
- elsif not Project.Virtual then
- declare
- Add_Object_Dir : Boolean;
- Prj : Project_Id;
-
- begin
- Add_Object_Dir := not Only_If_Ada;
- Prj := Project;
- while not Add_Object_Dir and then Prj /= No_Project loop
- if Has_Ada_Sources (Prj) then
- Add_Object_Dir := True;
- else
- Prj := Prj.Extends;
- end if;
- end loop;
-
- if Add_Object_Dir then
- return Project.Object_Directory.Display_Name;
- end if;
- end;
- end if;
- end if;
-
- return No_Path;
- end Get_Object_Directory;
-
- -----------------------------------
- -- Ultimate_Extending_Project_Of --
- -----------------------------------
-
- function Ultimate_Extending_Project_Of
- (Proj : Project_Id) return Project_Id
- is
- Prj : Project_Id;
-
- begin
- Prj := Proj;
- while Prj /= null and then Prj.Extended_By /= No_Project loop
- Prj := Prj.Extended_By;
- end loop;
-
- return Prj;
- end Ultimate_Extending_Project_Of;
-
- -----------------------------------
- -- Compute_All_Imported_Projects --
- -----------------------------------
-
- procedure Compute_All_Imported_Projects
- (Root_Project : Project_Id;
- Tree : Project_Tree_Ref)
- is
- procedure Analyze_Tree
- (Local_Root : Project_Id;
- Local_Tree : Project_Tree_Ref;
- Context : Project_Context);
- -- Process Project and all its aggregated project to analyze their own
- -- imported projects.
-
- ------------------
- -- Analyze_Tree --
- ------------------
-
- procedure Analyze_Tree
- (Local_Root : Project_Id;
- Local_Tree : Project_Tree_Ref;
- Context : Project_Context)
- is
- pragma Unreferenced (Local_Root);
-
- Project : Project_Id;
-
- procedure Recursive_Add
- (Prj : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context;
- Dummy : in out Boolean);
- -- Recursively add the projects imported by project Project, but not
- -- those that are extended.
-
- -------------------
- -- Recursive_Add --
- -------------------
-
- procedure Recursive_Add
- (Prj : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context;
- Dummy : in out Boolean)
- is
- pragma Unreferenced (Tree);
-
- List : Project_List;
- Prj2 : Project_Id;
-
- begin
- -- A project is not importing itself
-
- Prj2 := Ultimate_Extending_Project_Of (Prj);
-
- if Project /= Prj2 then
-
- -- Check that the project is not already in the list. We know
- -- the one passed to Recursive_Add have never been visited
- -- before, but the one passed it are the extended projects.
-
- List := Project.All_Imported_Projects;
- while List /= null loop
- if List.Project = Prj2 then
- return;
- end if;
-
- List := List.Next;
- end loop;
-
- -- Add it to the list
-
- Project.All_Imported_Projects :=
- new Project_List_Element'
- (Project => Prj2,
- From_Encapsulated_Lib =>
- Context.From_Encapsulated_Lib
- or else Analyze_Tree.Context.From_Encapsulated_Lib,
- Next => Project.All_Imported_Projects);
- end if;
- end Recursive_Add;
-
- procedure For_All_Projects is
- new For_Every_Project_Imported_Context (Boolean, Recursive_Add);
-
- Dummy : Boolean := False;
- List : Project_List;
-
- begin
- List := Local_Tree.Projects;
- while List /= null loop
- Project := List.Project;
- Free_List
- (Project.All_Imported_Projects, Free_Project => False);
- For_All_Projects
- (Project, Local_Tree, Dummy, Include_Aggregated => False);
- List := List.Next;
- end loop;
- end Analyze_Tree;
-
- procedure For_Aggregates is
- new For_Project_And_Aggregated_Context (Analyze_Tree);
-
- -- Start of processing for Compute_All_Imported_Projects
-
- begin
- For_Aggregates (Root_Project, Tree);
- end Compute_All_Imported_Projects;
-
- -------------------
- -- Is_Compilable --
- -------------------
-
- function Is_Compilable (Source : Source_Id) return Boolean is
- begin
- case Source.Compilable is
- when Unknown =>
- if Source.Language.Config.Compiler_Driver /= No_File
- and then
- Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
- and then not Source.Locally_Removed
- and then (Source.Language.Config.Kind /= File_Based
- or else Source.Kind /= Spec)
- then
- -- Do not modify Source.Compilable before the source record
- -- has been initialized.
-
- if Source.Source_TS /= Empty_Time_Stamp then
- Source.Compilable := Yes;
- end if;
-
- return True;
-
- else
- if Source.Source_TS /= Empty_Time_Stamp then
- Source.Compilable := No;
- end if;
-
- return False;
- end if;
-
- when Yes =>
- return True;
-
- when No =>
- return False;
- end case;
- end Is_Compilable;
-
- ------------------------------
- -- Object_To_Global_Archive --
- ------------------------------
-
- function Object_To_Global_Archive (Source : Source_Id) return Boolean is
- begin
- return Source.Language.Config.Kind = File_Based
- and then Source.Kind = Impl
- and then Source.Language.Config.Objects_Linked
- and then Is_Compilable (Source)
- and then Source.Language.Config.Object_Generated;
- end Object_To_Global_Archive;
-
- ----------------------------
- -- Get_Language_From_Name --
- ----------------------------
-
- function Get_Language_From_Name
- (Project : Project_Id;
- Name : String) return Language_Ptr
- is
- N : Name_Id;
- Result : Language_Ptr;
-
- begin
- Name_Len := Name'Length;
- Name_Buffer (1 .. Name_Len) := Name;
- To_Lower (Name_Buffer (1 .. Name_Len));
- N := Name_Find;
-
- Result := Project.Languages;
- while Result /= No_Language_Index loop
- if Result.Name = N then
- return Result;
- end if;
-
- Result := Result.Next;
- end loop;
-
- return No_Language_Index;
- end Get_Language_From_Name;
-
- ----------------
- -- Other_Part --
- ----------------
-
- function Other_Part (Source : Source_Id) return Source_Id is
- begin
- if Source.Unit /= No_Unit_Index then
- case Source.Kind is
- when Impl => return Source.Unit.File_Names (Spec);
- when Spec => return Source.Unit.File_Names (Impl);
- when Sep => return No_Source;
- end case;
- else
- return No_Source;
- end if;
- end Other_Part;
-
- ------------------
- -- Create_Flags --
- ------------------
-
- function Create_Flags
- (Report_Error : Error_Handler;
- When_No_Sources : Error_Warning;
- Require_Sources_Other_Lang : Boolean := True;
- Allow_Duplicate_Basenames : Boolean := True;
- Compiler_Driver_Mandatory : Boolean := False;
- Error_On_Unknown_Language : Boolean := True;
- Require_Obj_Dirs : Error_Warning := Error;
- Allow_Invalid_External : Error_Warning := Error;
- Missing_Source_Files : Error_Warning := Error;
- Ignore_Missing_With : Boolean := False)
- return Processing_Flags
- is
- begin
- return Processing_Flags'
- (Report_Error => Report_Error,
- When_No_Sources => When_No_Sources,
- Require_Sources_Other_Lang => Require_Sources_Other_Lang,
- Allow_Duplicate_Basenames => Allow_Duplicate_Basenames,
- Error_On_Unknown_Language => Error_On_Unknown_Language,
- Compiler_Driver_Mandatory => Compiler_Driver_Mandatory,
- Require_Obj_Dirs => Require_Obj_Dirs,
- Allow_Invalid_External => Allow_Invalid_External,
- Missing_Source_Files => Missing_Source_Files,
- Ignore_Missing_With => Ignore_Missing_With,
- Incomplete_Withs => False);
- end Create_Flags;
-
- ------------
- -- Length --
- ------------
-
- function Length
- (Table : Name_List_Table.Instance;
- List : Name_List_Index) return Natural
- is
- Count : Natural := 0;
- Tmp : Name_List_Index;
-
- begin
- Tmp := List;
- while Tmp /= No_Name_List loop
- Count := Count + 1;
- Tmp := Table.Table (Tmp).Next;
- end loop;
-
- return Count;
- end Length;
-
- ------------------
- -- Debug_Output --
- ------------------
-
- procedure Debug_Output (Str : String) is
- begin
- if Current_Verbosity > Default then
- Set_Standard_Error;
- Write_Line ((1 .. Debug_Level * 2 => ' ') & Str);
- Set_Standard_Output;
- end if;
- end Debug_Output;
-
- ------------------
- -- Debug_Indent --
- ------------------
-
- procedure Debug_Indent is
- begin
- if Current_Verbosity = High then
- Set_Standard_Error;
- Write_Str ((1 .. Debug_Level * 2 => ' '));
- Set_Standard_Output;
- end if;
- end Debug_Indent;
-
- ------------------
- -- Debug_Output --
- ------------------
-
- procedure Debug_Output (Str : String; Str2 : Name_Id) is
- begin
- if Current_Verbosity > Default then
- Debug_Indent;
- Set_Standard_Error;
- Write_Str (Str);
-
- if Str2 = No_Name then
- Write_Line (" <no_name>");
- else
- Write_Line (" """ & Get_Name_String (Str2) & '"');
- end if;
-
- Set_Standard_Output;
- end if;
- end Debug_Output;
-
- ---------------------------
- -- Debug_Increase_Indent --
- ---------------------------
-
- procedure Debug_Increase_Indent
- (Str : String := ""; Str2 : Name_Id := No_Name)
- is
- begin
- if Str2 /= No_Name then
- Debug_Output (Str, Str2);
- else
- Debug_Output (Str);
- end if;
- Debug_Level := Debug_Level + 1;
- end Debug_Increase_Indent;
-
- ---------------------------
- -- Debug_Decrease_Indent --
- ---------------------------
-
- procedure Debug_Decrease_Indent (Str : String := "") is
- begin
- if Debug_Level > 0 then
- Debug_Level := Debug_Level - 1;
- end if;
-
- if Str /= "" then
- Debug_Output (Str);
- end if;
- end Debug_Decrease_Indent;
-
- ----------------
- -- Debug_Name --
- ----------------
-
- function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
- P : Project_List;
-
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer ("Tree [");
-
- P := Tree.Projects;
- while P /= null loop
- if P /= Tree.Projects then
- Add_Char_To_Name_Buffer (',');
- end if;
-
- Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name));
-
- P := P.Next;
- end loop;
-
- Add_Char_To_Name_Buffer (']');
-
- return Name_Find;
- end Debug_Name;
-
- ----------
- -- Free --
- ----------
-
- procedure Free (Tree : in out Project_Tree_Appdata) is
- pragma Unreferenced (Tree);
- begin
- null;
- end Free;
-
- --------------------------------
- -- For_Project_And_Aggregated --
- --------------------------------
-
- procedure For_Project_And_Aggregated
- (Root_Project : Project_Id;
- Root_Tree : Project_Tree_Ref)
- is
- Agg : Aggregated_Project_List;
-
- begin
- Action (Root_Project, Root_Tree);
-
- if Root_Project.Qualifier in Aggregate_Project then
- Agg := Root_Project.Aggregated_Projects;
- while Agg /= null loop
- For_Project_And_Aggregated (Agg.Project, Agg.Tree);
- Agg := Agg.Next;
- end loop;
- end if;
- end For_Project_And_Aggregated;
-
- ----------------------------------------
- -- For_Project_And_Aggregated_Context --
- ----------------------------------------
-
- procedure For_Project_And_Aggregated_Context
- (Root_Project : Project_Id;
- Root_Tree : Project_Tree_Ref)
- is
-
- procedure Recursive_Process
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context);
- -- Process Project and all aggregated projects recursively
-
- -----------------------
- -- Recursive_Process --
- -----------------------
-
- procedure Recursive_Process
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context)
- is
- Agg : Aggregated_Project_List;
- Ctx : Project_Context;
-
- begin
- Action (Project, Tree, Context);
-
- if Project.Qualifier in Aggregate_Project then
- Ctx :=
- (In_Aggregate_Lib => Project.Qualifier = Aggregate_Library,
- From_Encapsulated_Lib =>
- Context.From_Encapsulated_Lib
- or else Project.Standalone_Library = Encapsulated);
-
- Agg := Project.Aggregated_Projects;
- while Agg /= null loop
- Recursive_Process (Agg.Project, Agg.Tree, Ctx);
- Agg := Agg.Next;
- end loop;
- end if;
- end Recursive_Process;
-
- -- Start of processing for For_Project_And_Aggregated_Context
-
- begin
- Recursive_Process
- (Root_Project, Root_Tree, Project_Context'(False, False));
- end For_Project_And_Aggregated_Context;
-
- -----------------------------
- -- Set_Ignore_Missing_With --
- -----------------------------
-
- procedure Set_Ignore_Missing_With
- (Flags : in out Processing_Flags;
- Value : Boolean)
- is
- begin
- Flags.Ignore_Missing_With := Value;
- end Set_Ignore_Missing_With;
-
--- Package initialization for Prj
-
-begin
- -- Make sure that the standard config and user project file extensions are
- -- compatible with canonical case file naming.
-
- Canonical_Case_File_Name (Config_Project_File_Extension);
- Canonical_Case_File_Name (Project_File_Extension);
-end Prj;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- P R J --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- The following package declares the data types for GNAT project.
--- These data types may be used by GNAT Project-aware tools.
-
--- Children of these package implements various services on these data types.
--- See in particular Prj.Pars and Prj.Env.
-
-with Casing; use Casing;
-with Namet; use Namet;
-with Osint;
-with Scans; use Scans;
-with Types; use Types;
-
-with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables;
-with GNAT.Dynamic_Tables;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
-
-package Prj is
-
- procedure Add_Restricted_Language (Name : String);
- -- Call by gprbuild for each language specify by switch
- -- --restricted-to-languages=.
-
- procedure Remove_All_Restricted_Languages;
- -- Call by gprbuild in CodePeer mode to ignore switches
- -- --restricted-to-languages=.
-
- function Is_Allowed_Language (Name : Name_Id) return Boolean;
- -- Returns True if --restricted-to-languages= is not used or if Name
- -- is one of the restricted languages.
-
- All_Other_Names : constant Name_Id := Names_High_Bound;
- -- Name used to replace others as an index of an associative array
- -- attribute in situations where this is allowed.
-
- Subdirs : String_Ptr := null;
- -- The value after the equal sign in switch --subdirs=...
- -- Contains the relative subdirectory.
-
- Build_Tree_Dir : String_Ptr := null;
- -- A root directory for building out-of-tree projects. All relative object
- -- directories will be rooted at this location.
-
- Root_Dir : String_Ptr := null;
- -- When using out-of-tree build we need to keep information about the root
- -- directory of artifacts to properly relocate them. Note that the root
- -- directory is not necessarily the directory of the main project.
-
- type Library_Support is (None, Static_Only, Full);
- -- Support for Library Project File.
- -- - None: Library Project Files are not supported at all
- -- - Static_Only: Library Project Files are only supported for static
- -- libraries.
- -- - Full: Library Project Files are supported for static and dynamic
- -- (shared) libraries.
-
- type Yes_No_Unknown is (Yes, No, Unknown);
- -- Tri-state to decide if -lgnarl is needed when linking
-
- type Attribute_Default_Value is
- (Read_Only_Value, -- For read only attributes (Name, Project_Dir)
- Empty_Value, -- Empty string or empty string list
- Dot_Value, -- "." or (".")
- Object_Dir_Value, -- 'Object_Dir
- Target_Value, -- 'Target (special rules)
- Runtime_Value); -- 'Runtime (special rules)
- -- Describe the default values of attributes that are referenced but not
- -- declared.
-
- pragma Warnings (Off);
- type Project_Qualifier is
- (Unspecified,
-
- -- The following clash with Standard is OK, and justified by the context
- -- which really wants to use the same set of qualifiers.
-
- Standard,
-
- Library,
- Configuration,
- Abstract_Project,
- Aggregate,
- Aggregate_Library);
- pragma Warnings (On);
- -- Qualifiers that can prefix the reserved word "project" in a project
- -- file:
- -- Standard: standard project ...
- -- Library: library project is ...
- -- Abstract_Project: abstract project is
- -- Aggregate: aggregate project is
- -- Aggregate_Library: aggregate library project is ...
- -- Configuration: configuration project is ...
-
- subtype Aggregate_Project is
- Project_Qualifier range Aggregate .. Aggregate_Library;
-
- All_Packages : constant String_List_Access;
- -- Default value of parameter Packages of procedures Parse, in Prj.Pars and
- -- Prj.Part, indicating that all packages should be checked.
-
- type Project_Tree_Data;
- type Project_Tree_Ref is access all Project_Tree_Data;
- -- Reference to a project tree. Several project trees may exist in memory
- -- at the same time.
-
- No_Project_Tree : constant Project_Tree_Ref;
-
- procedure Free (Tree : in out Project_Tree_Ref);
- -- Free memory associated with the tree
-
- Config_Project_File_Extension : String := ".cgpr";
- Project_File_Extension : String := ".gpr";
- -- The standard config and user project file name extensions. They are not
- -- constants, because Canonical_Case_File_Name is called on these variables
- -- in the body of Prj.
-
- function Empty_File return File_Name_Type;
- function Empty_String return Name_Id;
- -- Return the id for an empty string ""
-
- function Dot_String return Name_Id;
- -- Return the id for "."
-
- type Path_Information is record
- Name : Path_Name_Type := No_Path;
- Display_Name : Path_Name_Type := No_Path;
- end record;
- -- Directory names always end with a directory separator
-
- No_Path_Information : constant Path_Information := (No_Path, No_Path);
-
- type Project_Data;
- type Project_Id is access all Project_Data;
- No_Project : constant Project_Id := null;
- -- Id of a Project File
-
- type String_List_Id is new Nat;
- Nil_String : constant String_List_Id := 0;
- type String_Element is record
- Value : Name_Id := No_Name;
- Index : Int := 0;
- Display_Value : Name_Id := No_Name;
- Location : Source_Ptr := No_Location;
- Flag : Boolean := False;
- Next : String_List_Id := Nil_String;
- end record;
- -- To hold values for string list variables and array elements.
- -- Component Flag may be used for various purposes. For source
- -- directories, it indicates if the directory contains Ada source(s).
-
- package String_Element_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => String_Element,
- Table_Index_Type => String_List_Id,
- Table_Low_Bound => 1,
- Table_Initial => 200,
- Table_Increment => 100);
- -- The table for string elements in string lists
-
- type Variable_Kind is (Undefined, List, Single);
- -- Different kinds of variables
-
- subtype Defined_Variable_Kind is Variable_Kind range List .. Single;
- -- The defined kinds of variables
-
- Ignored : constant Variable_Kind;
- -- Used to indicate that a package declaration must be ignored while
- -- processing the project tree (unknown package name).
-
- type Variable_Value (Kind : Variable_Kind := Undefined) is record
- Project : Project_Id := No_Project;
- Location : Source_Ptr := No_Location;
- Default : Boolean := False;
- case Kind is
- when Undefined =>
- null;
- when List =>
- Values : String_List_Id := Nil_String;
- when Single =>
- Value : Name_Id := No_Name;
- Index : Int := 0;
- end case;
- end record;
- -- Values for variables and array elements. Default is True if the
- -- current value is the default one for the variable.
-
- Nil_Variable_Value : constant Variable_Value;
- -- Value of a non existing variable or array element
-
- type Variable_Id is new Nat;
- No_Variable : constant Variable_Id := 0;
- type Variable is record
- Next : Variable_Id := No_Variable;
- Name : Name_Id;
- Value : Variable_Value;
- end record;
- -- To hold the list of variables in a project file and in packages
-
- package Variable_Element_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Variable,
- Table_Index_Type => Variable_Id,
- Table_Low_Bound => 1,
- Table_Initial => 200,
- Table_Increment => 100);
- -- The table of variable in list of variables
-
- type Array_Element_Id is new Nat;
- No_Array_Element : constant Array_Element_Id := 0;
- type Array_Element is record
- Index : Name_Id;
- Restricted : Boolean := False;
- Src_Index : Int := 0;
- Index_Case_Sensitive : Boolean := True;
- Value : Variable_Value;
- Next : Array_Element_Id := No_Array_Element;
- end record;
- -- Each Array_Element represents an array element and is linked (Next)
- -- to the next array element, if any, in the array.
-
- package Array_Element_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Array_Element,
- Table_Index_Type => Array_Element_Id,
- Table_Low_Bound => 1,
- Table_Initial => 200,
- Table_Increment => 100);
- -- The table that contains all array elements
-
- type Array_Id is new Nat;
- No_Array : constant Array_Id := 0;
- type Array_Data is record
- Name : Name_Id := No_Name;
- Location : Source_Ptr := No_Location;
- Value : Array_Element_Id := No_Array_Element;
- Next : Array_Id := No_Array;
- end record;
- -- Each Array_Data value represents an array.
- -- Value is the id of the first element.
- -- Next is the id of the next array in the project file or package.
-
- package Array_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Array_Data,
- Table_Index_Type => Array_Id,
- Table_Low_Bound => 1,
- Table_Initial => 200,
- Table_Increment => 100);
- -- The table that contains all arrays
-
- type Package_Id is new Nat;
- No_Package : constant Package_Id := 0;
- type Declarations is record
- Variables : Variable_Id := No_Variable;
- Attributes : Variable_Id := No_Variable;
- Arrays : Array_Id := No_Array;
- Packages : Package_Id := No_Package;
- end record;
- -- Contains the declarations (variables, single and array attributes,
- -- packages) for a project or a package in a project.
-
- No_Declarations : constant Declarations :=
- (Variables => No_Variable,
- Attributes => No_Variable,
- Arrays => No_Array,
- Packages => No_Package);
- -- Default value of Declarations: used if there are no declarations
-
- type Package_Element is record
- Name : Name_Id := No_Name;
- Decl : Declarations := No_Declarations;
- Parent : Package_Id := No_Package;
- Next : Package_Id := No_Package;
- end record;
- -- A package (includes declarations that may include other packages)
-
- package Package_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Package_Element,
- Table_Index_Type => Package_Id,
- Table_Low_Bound => 1,
- Table_Initial => 100,
- Table_Increment => 100);
- -- The table that contains all packages
-
- type Language_Data;
- type Language_Ptr is access all Language_Data;
- -- Index of language data
-
- No_Language_Index : constant Language_Ptr := null;
- -- Constant indicating that there is no language data
-
- function Get_Language_From_Name
- (Project : Project_Id;
- Name : String) return Language_Ptr;
- -- Get a language from a project. This might return null if no such
- -- language exists in the project
-
- Max_Header_Num : constant := 6150;
- type Header_Num is range 0 .. Max_Header_Num;
- -- Size for hash table below. The upper bound is an arbitrary value, the
- -- value here was chosen after testing to determine a good compromise
- -- between speed of access and memory usage.
-
- function Hash (Name : Name_Id) return Header_Num;
- function Hash (Name : File_Name_Type) return Header_Num;
- function Hash (Name : Path_Name_Type) return Header_Num;
- function Hash (Project : Project_Id) return Header_Num;
- -- Used for computing hash values for names put into hash tables
-
- type Language_Kind is (File_Based, Unit_Based);
- -- Type for the kind of language. All languages are file based, except Ada
- -- which is unit based.
-
- -- Type of dependency to be checked
-
- type Dependency_File_Kind is
- (None,
- -- There is no dependency file, the source must always be recompiled
-
- Makefile,
- -- The dependency file is a Makefile fragment indicating all the files
- -- the source depends on. If the object file or the dependency file is
- -- more recent than any of these files, the source must be recompiled.
-
- ALI_File,
- -- The dependency file is an ALI file and the source must be recompiled
- -- if the object or ALI file is more recent than any of the sources
- -- listed in the D lines.
-
- ALI_Closure);
- -- The dependency file is an ALI file and the source must be recompiled
- -- if the object or ALI file is more recent than any source in the full
- -- closure.
-
- Makefile_Dependency_Suffix : constant String := ".d";
- ALI_Dependency_Suffix : constant String := ".ali";
- Switches_Dependency_Suffix : constant String := ".cswi";
-
- Binder_Exchange_Suffix : constant String := ".bexch";
- -- Suffix for binder exchange files
-
- Library_Exchange_Suffix : constant String := ".lexch";
- -- Suffix for library exchange files
-
- type Name_List_Index is new Nat;
- No_Name_List : constant Name_List_Index := 0;
-
- type Name_Node is record
- Name : Name_Id := No_Name;
- Next : Name_List_Index := No_Name_List;
- end record;
-
- package Name_List_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Name_Node,
- Table_Index_Type => Name_List_Index,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100);
- -- The table for lists of names
-
- function Length
- (Table : Name_List_Table.Instance;
- List : Name_List_Index) return Natural;
- -- Return the number of elements in specified list
-
- type Number_List_Index is new Nat;
- No_Number_List : constant Number_List_Index := 0;
-
- type Number_Node is record
- Number : Natural := 0;
- Next : Number_List_Index := No_Number_List;
- end record;
-
- package Number_List_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Number_Node,
- Table_Index_Type => Number_List_Index,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100);
- -- The table for lists of numbers
-
- package Mapping_Files_Htable is new Simple_HTable
- (Header_Num => Header_Num,
- Element => Path_Name_Type,
- No_Element => No_Path,
- Key => Path_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- A hash table to store the mapping files that are not used
-
- -- The following record ???
-
- type Lang_Naming_Data is record
- Dot_Replacement : File_Name_Type := No_File;
- -- The string to replace '.' in the source file name (for Ada)
-
- Casing : Casing_Type := All_Lower_Case;
- -- The casing of the source file name (for Ada)
-
- Separate_Suffix : File_Name_Type := No_File;
- -- String to append to unit name for source file name of an Ada subunit
-
- Spec_Suffix : File_Name_Type := No_File;
- -- The string to append to the unit name for the
- -- source file name of a spec.
-
- Body_Suffix : File_Name_Type := No_File;
- -- The string to append to the unit name for the
- -- source file name of a body.
- end record;
-
- No_Lang_Naming_Data : constant Lang_Naming_Data :=
- (Dot_Replacement => No_File,
- Casing => All_Lower_Case,
- Separate_Suffix => No_File,
- Spec_Suffix => No_File,
- Body_Suffix => No_File);
-
- function Is_Standard_GNAT_Naming (Naming : Lang_Naming_Data) return Boolean;
- -- True if the naming scheme is GNAT's default naming scheme. This
- -- is to take into account shortened names like "Ada." (a-), "System." (s-)
- -- and so on.
-
- type Source_Data;
- type Source_Id is access all Source_Data;
-
- function Is_Compilable (Source : Source_Id) return Boolean;
- pragma Inline (Is_Compilable);
- -- Return True if we know how to compile Source (i.e. if a compiler is
- -- defined). This doesn't indicate whether the source should be compiled.
-
- function Object_To_Global_Archive (Source : Source_Id) return Boolean;
- pragma Inline (Object_To_Global_Archive);
- -- Return True if the object file should be put in the global archive.
- -- This is for Ada, when only the closure of a main needs to be
- -- (re)compiled.
-
- function Other_Part (Source : Source_Id) return Source_Id;
- pragma Inline (Other_Part);
- -- Source ID for the other part, if any: for a spec, returns its body;
- -- for a body, returns its spec.
-
- No_Source : constant Source_Id := null;
-
- type Path_Syntax_Kind is
- (Canonical, -- Unix style
- Host); -- Host specific syntax
-
- -- The following record describes the configuration of a language
-
- type Language_Config is record
- Kind : Language_Kind := File_Based;
- -- Kind of language. Most languages are file based. A few, such as Ada,
- -- are unit based.
-
- Naming_Data : Lang_Naming_Data;
- -- The naming data for the languages (prefixes, etc.)
-
- Include_Compatible_Languages : Name_List_Index := No_Name_List;
- -- List of languages that are "include compatible" with this language. A
- -- language B (for example "C") is "include compatible" with a language
- -- A (for example "C++") if it is expected that sources of language A
- -- may "include" header files from language B.
-
- Compiler_Driver : File_Name_Type := No_File;
- -- The name of the executable for the compiler of the language
-
- Compiler_Driver_Path : String_Access := null;
- -- The path name of the executable for the compiler of the language
-
- Compiler_Leading_Required_Switches : Name_List_Index := No_Name_List;
- -- The list of initial switches that are required as a minimum to invoke
- -- the compiler driver.
-
- Compiler_Trailing_Required_Switches : Name_List_Index := No_Name_List;
- -- The list of final switches that are required as a minimum to invoke
- -- the compiler driver.
-
- Multi_Unit_Switches : Name_List_Index := No_Name_List;
- -- The switch(es) to indicate the index of a unit in a multi-source file
-
- Multi_Unit_Object_Separator : Character := ' ';
- -- The string separating the base name of a source from the index of the
- -- unit in a multi-source file, in the object file name.
-
- Path_Syntax : Path_Syntax_Kind := Host;
- -- Value may be Canonical (Unix style) or Host (host syntax)
-
- Source_File_Switches : Name_List_Index := No_Name_List;
- -- Optional switches to be put before the source file. The source file
- -- path name is appended to the last switch in the list.
- -- Example: ("-i", "");
-
- Object_File_Suffix : Name_Id := No_Name;
- -- Optional alternate object file suffix
-
- Object_File_Switches : Name_List_Index := No_Name_List;
- -- Optional object file switches. When this is defined, the switches
- -- are used to specify the object file. The object file name is appended
- -- to the last switch in the list. Example: ("-o", "").
-
- Object_Path_Switches : Name_List_Index := No_Name_List;
- -- List of switches to specify to the compiler the path name of a
- -- temporary file containing the list of object directories in the
- -- correct order.
-
- Compilation_PIC_Option : Name_List_Index := No_Name_List;
- -- The option(s) to compile a source in Position Independent Code for
- -- shared libraries. Specified in the configuration. When not specified,
- -- there is no need for such switch.
-
- Object_Generated : Boolean := True;
- -- False if no object file is generated
-
- Objects_Linked : Boolean := True;
- -- False if object files are not use to link executables and build
- -- libraries.
-
- Runtime_Library_Dir : Name_Id := No_Name;
- -- Path name of the runtime library directory, if any
-
- Runtime_Source_Dir : Name_Id := No_Name;
- -- Path name of the runtime source directory, if any
-
- Mapping_File_Switches : Name_List_Index := No_Name_List;
- -- The option(s) to provide a mapping file to the compiler. Specified in
- -- the configuration. When value is No_Name_List, there is no mapping
- -- file.
-
- Mapping_Spec_Suffix : File_Name_Type := No_File;
- -- Placeholder representing the spec suffix in a mapping file
-
- Mapping_Body_Suffix : File_Name_Type := No_File;
- -- Placeholder representing the body suffix in a mapping file
-
- Config_File_Switches : Name_List_Index := No_Name_List;
- -- The option(s) to provide a config file to the compiler. Specified in
- -- the configuration. If value is No_Name_List there is no config file.
-
- Dependency_Kind : Dependency_File_Kind := None;
- -- The kind of dependency to be checked: none, Makefile fragment or
- -- ALI file (for Ada).
-
- Dependency_Option : Name_List_Index := No_Name_List;
- -- The option(s) to be used to create the dependency file. When value is
- -- No_Name_List, there is not such option(s).
-
- Compute_Dependency : Name_List_Index := No_Name_List;
- -- Hold the value of attribute Dependency_Driver, if declared for the
- -- language.
-
- Include_Option : Name_List_Index := No_Name_List;
- -- Hold the value of attribute Include_Switches, if declared for the
- -- language.
-
- Include_Path : Name_Id := No_Name;
- -- Name of environment variable declared by attribute Include_Path for
- -- the language.
-
- Include_Path_File : Name_Id := No_Name;
- -- Name of environment variable declared by attribute Include_Path_File
- -- for the language.
-
- Objects_Path : Name_Id := No_Name;
- -- Name of environment variable declared by attribute Objects_Path for
- -- the language.
-
- Objects_Path_File : Name_Id := No_Name;
- -- Name of environment variable declared by attribute Objects_Path_File
- -- for the language.
-
- Config_Body : Name_Id := No_Name;
- -- The template for a pragma Source_File_Name(_Project) for a specific
- -- file name of a body.
-
- Config_Body_Index : Name_Id := No_Name;
- -- The template for a pragma Source_File_Name(_Project) for a specific
- -- file name of a body in a multi-source file.
-
- Config_Body_Pattern : Name_Id := No_Name;
- -- The template for a pragma Source_File_Name(_Project) for a naming
- -- body pattern.
-
- Config_Spec : Name_Id := No_Name;
- -- The template for a pragma Source_File_Name(_Project) for a specific
- -- file name of a spec.
-
- Config_Spec_Index : Name_Id := No_Name;
- -- The template for a pragma Source_File_Name(_Project) for a specific
- -- file name of a spec in a multi-source file.
-
- Config_Spec_Pattern : Name_Id := No_Name;
- -- The template for a pragma Source_File_Name(_Project) for a naming
- -- spec pattern.
-
- Config_File_Unique : Boolean := False;
- -- True if the config file specified to the compiler needs to be unique.
- -- If it is unique, then all config files are concatenated into a temp
- -- config file.
-
- Binder_Driver : File_Name_Type := No_File;
- -- The name of the binder driver for the language, if any
-
- Binder_Driver_Path : Path_Name_Type := No_Path;
- -- The path name of the binder driver
-
- Binder_Required_Switches : Name_List_Index := No_Name_List;
- -- Hold the value of attribute Binder'Required_Switches for the language
-
- Binder_Prefix : Name_Id := No_Name;
- -- Hold the value of attribute Binder'Prefix for the language
-
- Toolchain_Version : Name_Id := No_Name;
- -- Hold the value of attribute Toolchain_Version for the language
-
- Toolchain_Description : Name_Id := No_Name;
- -- Hold the value of attribute Toolchain_Description for the language
-
- Clean_Object_Artifacts : Name_List_Index := No_Name_List;
- -- List of object artifact extensions to be deleted by gprclean
-
- Clean_Source_Artifacts : Name_List_Index := No_Name_List;
- -- List of source artifact extensions to be deleted by gprclean
-
- end record;
-
- No_Language_Config : constant Language_Config :=
- (Kind => File_Based,
- Naming_Data => No_Lang_Naming_Data,
- Include_Compatible_Languages => No_Name_List,
- Compiler_Driver => No_File,
- Compiler_Driver_Path => null,
- Compiler_Leading_Required_Switches
- => No_Name_List,
- Compiler_Trailing_Required_Switches
- => No_Name_List,
- Multi_Unit_Switches => No_Name_List,
- Multi_Unit_Object_Separator => ' ',
- Path_Syntax => Canonical,
- Source_File_Switches => No_Name_List,
- Object_File_Suffix => No_Name,
- Object_File_Switches => No_Name_List,
- Object_Path_Switches => No_Name_List,
- Compilation_PIC_Option => No_Name_List,
- Object_Generated => True,
- Objects_Linked => True,
- Runtime_Library_Dir => No_Name,
- Runtime_Source_Dir => No_Name,
- Mapping_File_Switches => No_Name_List,
- Mapping_Spec_Suffix => No_File,
- Mapping_Body_Suffix => No_File,
- Config_File_Switches => No_Name_List,
- Dependency_Kind => None,
- Dependency_Option => No_Name_List,
- Compute_Dependency => No_Name_List,
- Include_Option => No_Name_List,
- Include_Path => No_Name,
- Include_Path_File => No_Name,
- Objects_Path => No_Name,
- Objects_Path_File => No_Name,
- Config_Body => No_Name,
- Config_Body_Index => No_Name,
- Config_Body_Pattern => No_Name,
- Config_Spec => No_Name,
- Config_Spec_Index => No_Name,
- Config_Spec_Pattern => No_Name,
- Config_File_Unique => False,
- Binder_Driver => No_File,
- Binder_Driver_Path => No_Path,
- Binder_Required_Switches => No_Name_List,
- Binder_Prefix => No_Name,
- Toolchain_Version => No_Name,
- Toolchain_Description => No_Name,
- Clean_Object_Artifacts => No_Name_List,
- Clean_Source_Artifacts => No_Name_List);
-
- type Language_Data is record
- Name : Name_Id := No_Name;
- -- The name of the language in lower case
-
- Display_Name : Name_Id := No_Name;
- -- The name of the language, as found in attribute Languages
-
- Config : Language_Config := No_Language_Config;
- -- Configuration of the language
-
- First_Source : Source_Id := No_Source;
- -- Head of the list of sources of the language in the project
-
- Mapping_Files : Mapping_Files_Htable.Instance :=
- Mapping_Files_Htable.Nil;
- -- Hash table containing the mapping of the sources to their path names
-
- Next : Language_Ptr := No_Language_Index;
- -- Next language of the project
-
- end record;
-
- No_Language_Data : constant Language_Data :=
- (Name => No_Name,
- Display_Name => No_Name,
- Config => No_Language_Config,
- First_Source => No_Source,
- Mapping_Files => Mapping_Files_Htable.Nil,
- Next => No_Language_Index);
-
- type Language_List_Element;
- type Language_List is access all Language_List_Element;
- type Language_List_Element is record
- Language : Language_Ptr := No_Language_Index;
- Next : Language_List;
- end record;
-
- type Source_Kind is (Spec, Impl, Sep);
- subtype Spec_Or_Body is Source_Kind range Spec .. Impl;
-
- -- The following declarations declare a structure used to store the Name
- -- and File and Path names of a unit, with a reference to its GNAT Project
- -- File(s). Some units might have neither Spec nor Impl when they were
- -- created for a "separate".
-
- type File_Names_Data is array (Spec_Or_Body) of Source_Id;
-
- type Unit_Data is record
- Name : Name_Id := No_Name;
- File_Names : File_Names_Data;
- end record;
-
- type Unit_Index is access all Unit_Data;
-
- No_Unit_Index : constant Unit_Index := null;
- -- Used to indicate a null entry for no unit
-
- type Source_Roots;
- type Roots_Access is access Source_Roots;
- type Source_Roots is record
- Root : Source_Id;
- Next : Roots_Access;
- end record;
- -- A list to store the roots associated with a main unit. These are the
- -- files that need to linked along with the main (for instance a C file
- -- corresponding to an Ada file). In general, these are dependencies that
- -- cannot be computed automatically by the builder.
-
- type Naming_Exception_Type is (No, Yes, Inherited);
-
- -- Structure to define source data
-
- type Source_Data is record
- Initialized : Boolean := False;
- -- Set to True when Source_Data is completely initialized
-
- Project : Project_Id := No_Project;
- -- Project of the source
-
- Location : Source_Ptr := No_Location;
- -- Location in the project file of the declaration of the source in
- -- package Naming.
-
- Source_Dir_Rank : Natural := 0;
- -- The rank of the source directory in list declared with attribute
- -- Source_Dirs. Two source files with the same name cannot appears in
- -- different directory with the same rank. That can happen when the
- -- recursive notation <dir>/** is used in attribute Source_Dirs.
-
- Language : Language_Ptr := No_Language_Index;
- -- Language of the source
-
- In_Interfaces : Boolean := True;
- -- False when the source is not included in interfaces, when attribute
- -- Interfaces is declared.
-
- Declared_In_Interfaces : Boolean := False;
- -- True when source is declared in attribute Interfaces
-
- Alternate_Languages : Language_List := null;
- -- List of languages a header file may also be, in addition of language
- -- Language_Name.
-
- Kind : Source_Kind := Spec;
- -- Kind of the source: spec, body or subunit
-
- Unit : Unit_Index := No_Unit_Index;
- -- Name of the unit, if language is unit based. This is only set for
- -- those files that are part of the compilation set (for instance a
- -- file in an extended project that is overridden will not have this
- -- field set).
-
- Index : Int := 0;
- -- Index of the source in a multi unit source file (the same Source_Data
- -- is duplicated several times when there are several units in the same
- -- file). Index is 0 if there is either no unit or a single one, and
- -- starts at 1 when there are multiple units
-
- Compilable : Yes_No_Unknown := Unknown;
- -- Updated at the first call to Is_Compilable. Yes if source file is
- -- compilable.
-
- In_The_Queue : Boolean := False;
- -- True if the source has been put in the queue
-
- Locally_Removed : Boolean := False;
- -- True if the source has been "excluded"
-
- Suppressed : Boolean := False;
- -- True if the source is a locally removed direct source of the project.
- -- These sources should not be put in the mapping file.
-
- Replaced_By : Source_Id := No_Source;
- -- Source in an extending project that replaces the current source
-
- File : File_Name_Type := No_File;
- -- Canonical file name of the source
-
- Display_File : File_Name_Type := No_File;
- -- File name of the source, for display purposes
-
- Path : Path_Information := No_Path_Information;
- -- Path name of the source
-
- Source_TS : Time_Stamp_Type := Empty_Time_Stamp;
- -- Time stamp of the source file
-
- Object_Project : Project_Id := No_Project;
- -- Project where the object file is. This might be different from
- -- Project when using extending project files.
-
- Object : File_Name_Type := No_File;
- -- File name of the object file
-
- Current_Object_Path : Path_Name_Type := No_Path;
- -- Object path of an existing object file
-
- Object_Path : Path_Name_Type := No_Path;
- -- Object path of the real object file
-
- Object_TS : Time_Stamp_Type := Empty_Time_Stamp;
- -- Object file time stamp
-
- Dep_Name : File_Name_Type := No_File;
- -- Dependency file simple name
-
- Current_Dep_Path : Path_Name_Type := No_Path;
- -- Path name of an existing dependency file
-
- Dep_Path : Path_Name_Type := No_Path;
- -- Path name of the real dependency file
-
- Dep_TS : aliased Osint.File_Attributes := Osint.Unknown_Attributes;
- -- Dependency file time stamp
-
- Switches : File_Name_Type := No_File;
- -- File name of the switches file. For all languages, this is a file
- -- that ends with the .cswi extension.
-
- Switches_Path : Path_Name_Type := No_Path;
- -- Path name of the switches file
-
- Switches_TS : Time_Stamp_Type := Empty_Time_Stamp;
- -- Switches file time stamp
-
- Naming_Exception : Naming_Exception_Type := No;
- -- True if the source has an exceptional name
-
- Duplicate_Unit : Boolean := False;
- -- True when a duplicate unit has been reported for this source
-
- Next_In_Lang : Source_Id := No_Source;
- -- Link to another source of the same language in the same project
-
- Next_With_File_Name : Source_Id := No_Source;
- -- Link to another source with the same base file name
-
- Roots : Roots_Access := null;
- -- The roots for a main unit
-
- end record;
-
- No_Source_Data : constant Source_Data :=
- (Initialized => False,
- Project => No_Project,
- Location => No_Location,
- Source_Dir_Rank => 0,
- Language => No_Language_Index,
- In_Interfaces => True,
- Declared_In_Interfaces => False,
- Alternate_Languages => null,
- Kind => Spec,
- Unit => No_Unit_Index,
- Index => 0,
- Locally_Removed => False,
- Suppressed => False,
- Compilable => Unknown,
- In_The_Queue => False,
- Replaced_By => No_Source,
- File => No_File,
- Display_File => No_File,
- Path => No_Path_Information,
- Source_TS => Empty_Time_Stamp,
- Object_Project => No_Project,
- Object => No_File,
- Current_Object_Path => No_Path,
- Object_Path => No_Path,
- Object_TS => Empty_Time_Stamp,
- Dep_Name => No_File,
- Current_Dep_Path => No_Path,
- Dep_Path => No_Path,
- Dep_TS => Osint.Unknown_Attributes,
- Switches => No_File,
- Switches_Path => No_Path,
- Switches_TS => Empty_Time_Stamp,
- Naming_Exception => No,
- Duplicate_Unit => False,
- Next_In_Lang => No_Source,
- Next_With_File_Name => No_Source,
- Roots => null);
-
- package Source_Files_Htable is new Simple_HTable
- (Header_Num => Header_Num,
- Element => Source_Id,
- No_Element => No_Source,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- Mapping of source file names to source ids
-
- package Source_Paths_Htable is new Simple_HTable
- (Header_Num => Header_Num,
- Element => Source_Id,
- No_Element => No_Source,
- Key => Path_Name_Type,
- Hash => Hash,
- Equal => "=");
- -- Mapping of source paths to source ids
-
- type Lib_Kind is (Static, Dynamic, Relocatable);
-
- type Policy is (Autonomous, Compliant, Controlled, Restricted, Direct);
- -- Type to specify the symbol policy, when symbol control is supported.
- -- See full explanation about this type in package Symbols.
- -- Autonomous: Create a symbol file without considering any reference
- -- Compliant: Try to be as compatible as possible with an existing ref
- -- Controlled: Fail if symbols are not the same as those in the reference
- -- Restricted: Restrict the symbols to those in the symbol file
- -- Direct: The symbol file is used as is
-
- type Symbol_Record is record
- Symbol_File : Path_Name_Type := No_Path;
- Reference : Path_Name_Type := No_Path;
- Symbol_Policy : Policy := Autonomous;
- end record;
- -- Type to keep the symbol data to be used when building a shared library
-
- No_Symbols : constant Symbol_Record :=
- (Symbol_File => No_Path,
- Reference => No_Path,
- Symbol_Policy => Autonomous);
- -- The default value of the symbol data
-
- function Image (The_Casing : Casing_Type) return String;
- -- Similar to 'Image (but avoid use of this attribute in compiler)
-
- function Value (Image : String) return Casing_Type;
- -- Similar to 'Value (but avoid use of this attribute in compiler)
- -- Raises Constraint_Error if not a Casing_Type image.
-
- -- The following record contains data for a naming scheme
-
- function Get_Object_Directory
- (Project : Project_Id;
- Including_Libraries : Boolean;
- Only_If_Ada : Boolean := False) return Path_Name_Type;
- -- Return the object directory to use for the project. This depends on
- -- whether we have a library project or a standard project. This function
- -- might return No_Name when no directory applies. If the project is a
- -- library project file and Including_Libraries is True then the library
- -- ALI dir is returned instead of the object dir, except when there is no
- -- ALI files in the Library ALI dir and the object directory exists. If
- -- Only_If_Ada is True, then No_Name is returned when the project doesn't
- -- include any Ada source.
-
- procedure Compute_All_Imported_Projects
- (Root_Project : Project_Id;
- Tree : Project_Tree_Ref);
- -- For all projects in the tree, compute the list of the projects imported
- -- directly or indirectly by project Root_Project. The result is stored in
- -- Project.All_Imported_Projects for each project
-
- function Ultimate_Extending_Project_Of
- (Proj : Project_Id) return Project_Id;
- -- Returns the ultimate extending project of project Proj. If project Proj
- -- is not extended, returns Proj.
-
- type Project_List_Element;
- type Project_List is access all Project_List_Element;
- type Project_List_Element is record
- Project : Project_Id := No_Project;
- From_Encapsulated_Lib : Boolean := False;
- Next : Project_List := null;
- end record;
- -- A list of projects
-
- procedure Free_List
- (List : in out Project_List;
- Free_Project : Boolean);
- -- Free the list of projects, if Free_Project, each project is also freed
-
- type Response_File_Format is
- (None,
- GNU,
- Object_List,
- Option_List,
- GCC,
- GCC_GNU,
- GCC_Object_List,
- GCC_Option_List);
- -- The format of the different response files
-
- type Project_Configuration is record
- Target : Name_Id := No_Name;
- -- The target of the configuration, when specified
-
- Run_Path_Option : Name_List_Index := No_Name_List;
- -- The option to use when linking to specify the path where to look for
- -- libraries.
-
- Run_Path_Origin : Name_Id := No_Name;
- -- Specify the string (such as "$ORIGIN") to indicate paths relative to
- -- the directory of the executable in the run path option.
-
- Library_Install_Name_Option : Name_Id := No_Name;
- -- When this is not an empty list, this option, followed by the single
- -- name of the shared library file is used when linking a shared
- -- library.
-
- Separate_Run_Path_Options : Boolean := False;
- -- True if each directory needs to be specified in a separate run path
- -- option.
-
- Executable_Suffix : Name_Id := No_Name;
- -- The suffix of executables, when specified in the configuration or in
- -- package Builder of the main project. When this is not specified, the
- -- executable suffix is the default for the platform.
-
- -- Linking
-
- Linker : Path_Name_Type := No_Path;
- -- Path name of the linker driver. Specified in the configuration or in
- -- the package Builder of the main project.
-
- Map_File_Option : Name_Id := No_Name;
- -- Option to use when invoking the linker to build a map file
-
- Trailing_Linker_Required_Switches : Name_List_Index := No_Name_List;
- -- The minimum options for the linker driver. Specified in the
- -- configuration.
-
- Linker_Executable_Option : Name_List_Index := No_Name_List;
- -- The option(s) to indicate the name of the executable in the linker
- -- command. Specified in the configuration. When not specified, default
- -- to -o <executable name>.
-
- Linker_Lib_Dir_Option : Name_Id := No_Name;
- -- The option to specify where to find a library for linking. Specified
- -- in the configuration. When not specified, defaults to "-L".
-
- Linker_Lib_Name_Option : Name_Id := No_Name;
- -- The option to specify the name of a library for linking. Specified in
- -- the configuration. When not specified, defaults to "-l".
-
- Max_Command_Line_Length : Natural := 0;
- -- When positive and when Resp_File_Format (see below) is not None,
- -- if the command line for the invocation of the linker would be greater
- -- than this value, a response file is used to invoke the linker.
-
- Resp_File_Format : Response_File_Format := None;
- -- The format of a response file, when linking with a response file is
- -- supported.
-
- Resp_File_Options : Name_List_Index := No_Name_List;
- -- The switches, if any, that precede the path name of the response
- -- file in the invocation of the linker.
-
- -- Libraries
-
- Library_Builder : Path_Name_Type := No_Path;
- -- The executable to build library (specified in the configuration)
-
- Lib_Support : Library_Support := None;
- -- The level of library support. Specified in the configuration. Support
- -- is none, static libraries only or both static and shared libraries.
-
- Lib_Encapsulated_Supported : Boolean := False;
- -- True when building fully standalone libraries supported on the target
-
- Archive_Builder : Name_List_Index := No_Name_List;
- -- The name of the executable to build archives, with the minimum
- -- switches. Specified in the configuration.
-
- Archive_Builder_Append_Option : Name_List_Index := No_Name_List;
- -- The options to append object files to an archive
-
- Archive_Indexer : Name_List_Index := No_Name_List;
- -- The name of the executable to index archives, with the minimum
- -- switches. Specified in the configuration.
-
- Archive_Suffix : File_Name_Type := No_File;
- -- The suffix of archives. Specified in the configuration. When not
- -- specified, defaults to ".a".
-
- Lib_Partial_Linker : Name_List_Index := No_Name_List;
-
- -- Shared libraries
-
- Shared_Lib_Driver : File_Name_Type := No_File;
- -- The driver to link shared libraries. Set with attribute Library_GCC.
- -- Default to gcc.
-
- Shared_Lib_Prefix : File_Name_Type := No_File;
- -- Part of a shared library file name that precedes the name of the
- -- library. Specified in the configuration. When not specified, defaults
- -- to "lib".
-
- Shared_Lib_Suffix : File_Name_Type := No_File;
- -- Suffix of shared libraries, after the library name in the shared
- -- library name. Specified in the configuration. When not specified,
- -- default to ".so".
-
- Shared_Lib_Min_Options : Name_List_Index := No_Name_List;
- -- The minimum options to use when building a shared library
-
- Lib_Version_Options : Name_List_Index := No_Name_List;
- -- The options to use to specify a library version
-
- Symbolic_Link_Supported : Boolean := False;
- -- True if the platform supports symbolic link files
-
- Lib_Maj_Min_Id_Supported : Boolean := False;
- -- True if platform supports library major and minor options, such as
- -- libname.so -> libname.so.2 -> libname.so.2.4
-
- Auto_Init_Supported : Boolean := False;
- -- True if automatic initialisation is supported for shared stand-alone
- -- libraries.
-
- -- Cleaning
-
- Artifacts_In_Exec_Dir : Name_List_Index := No_Name_List;
- -- List of regexp file names to be cleaned in the exec directory of the
- -- main project.
-
- Artifacts_In_Object_Dir : Name_List_Index := No_Name_List;
- -- List of regexp file names to be cleaned in the object directory of
- -- all projects.
-
- end record;
-
- Default_Project_Config : constant Project_Configuration :=
- (Target => No_Name,
- Run_Path_Option => No_Name_List,
- Run_Path_Origin => No_Name,
- Library_Install_Name_Option => No_Name,
- Separate_Run_Path_Options => False,
- Executable_Suffix => No_Name,
- Linker => No_Path,
- Map_File_Option => No_Name,
- Trailing_Linker_Required_Switches =>
- No_Name_List,
- Linker_Executable_Option => No_Name_List,
- Linker_Lib_Dir_Option => No_Name,
- Linker_Lib_Name_Option => No_Name,
- Library_Builder => No_Path,
- Max_Command_Line_Length => 0,
- Resp_File_Format => None,
- Resp_File_Options => No_Name_List,
- Lib_Support => None,
- Lib_Encapsulated_Supported => False,
- Archive_Builder => No_Name_List,
- Archive_Builder_Append_Option => No_Name_List,
- Archive_Indexer => No_Name_List,
- Archive_Suffix => No_File,
- Lib_Partial_Linker => No_Name_List,
- Shared_Lib_Driver => No_File,
- Shared_Lib_Prefix => No_File,
- Shared_Lib_Suffix => No_File,
- Shared_Lib_Min_Options => No_Name_List,
- Lib_Version_Options => No_Name_List,
- Symbolic_Link_Supported => False,
- Lib_Maj_Min_Id_Supported => False,
- Auto_Init_Supported => False,
- Artifacts_In_Exec_Dir => No_Name_List,
- Artifacts_In_Object_Dir => No_Name_List);
-
- -------------------------
- -- Aggregated projects --
- -------------------------
-
- type Aggregated_Project;
- type Aggregated_Project_List is access all Aggregated_Project;
- type Aggregated_Project is record
- Path : Path_Name_Type;
- Tree : Project_Tree_Ref;
- Project : Project_Id;
- Next : Aggregated_Project_List;
- end record;
-
- 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
-
- pragma Warnings (Off);
- type Standalone is
- (No,
-
- -- The following clash with Standard is OK, and justified by the context
- -- which really wants to use the same set of qualifiers.
-
- Standard,
-
- Encapsulated);
- pragma Warnings (On);
-
- type Project_Data (Qualifier : Project_Qualifier := Unspecified) is record
-
- -------------
- -- General --
- -------------
-
- Name : Name_Id := No_Name;
- -- The name of the project
-
- Display_Name : Name_Id := No_Name;
- -- The name of the project with the spelling of its declaration
-
- Externally_Built : Boolean := False;
- -- True if the project is externally built. In such case, the Project
- -- Manager will not modify anything in this project.
-
- Config : Project_Configuration;
-
- Path : Path_Information := No_Path_Information;
- -- The path name of the project file. This include base name of the
- -- project file.
-
- Virtual : Boolean := False;
- -- True for virtual extending projects
-
- Location : Source_Ptr := No_Location;
- -- The location in the project file source of the project name that
- -- immediately follows the reserved word "project".
-
- ---------------
- -- Languages --
- ---------------
-
- Languages : Language_Ptr := No_Language_Index;
- -- First index of the language data in the project. Traversing the list
- -- gives access to all the languages supported by the project.
-
- --------------
- -- Projects --
- --------------
-
- Mains : String_List_Id := Nil_String;
- -- List of mains specified by attribute Main
-
- Extends : Project_Id := No_Project;
- -- The reference of the project file, if any, that this project file
- -- extends.
-
- Extended_By : Project_Id := No_Project;
- -- The reference of the project file, if any, that extends this project
- -- file.
-
- Decl : Declarations := No_Declarations;
- -- The declarations (variables, attributes and packages) of this project
- -- file.
-
- Imported_Projects : Project_List := null;
- -- The list of all directly imported projects, if any
-
- All_Imported_Projects : Project_List := null;
- -- The list of all projects imported directly or indirectly, if any.
- -- This does not include the project itself.
-
- -----------------
- -- Directories --
- -----------------
-
- Directory : Path_Information := No_Path_Information;
- -- Path name of the directory where the project file resides
-
- Object_Directory : Path_Information := No_Path_Information;
- -- The path name of the object directory of this project file
-
- Exec_Directory : Path_Information := No_Path_Information;
- -- The path name of the exec directory of this project file. Default is
- -- equal to Object_Directory.
-
- Object_Path_File : Path_Name_Type := No_Path;
- -- Store the name of the temporary file that contains the list of object
- -- directories, when attribute Object_Path_Switches is declared.
-
- -------------
- -- Library --
- -------------
-
- Library : Boolean := False;
- -- True if this is a library project
-
- Library_Name : Name_Id := No_Name;
- -- If a library project, name of the library
-
- Library_Kind : Lib_Kind := Static;
- -- If a library project, kind of library
-
- Library_Dir : Path_Information := No_Path_Information;
- -- If a library project, path name of the directory where the library
- -- resides.
-
- Library_TS : Time_Stamp_Type := Empty_Time_Stamp;
- -- The timestamp of a library file in a library project
-
- Library_Src_Dir : Path_Information := No_Path_Information;
- -- If a Stand-Alone Library project, path name of the directory where
- -- the sources of the interfaces of the library are copied. By default,
- -- if attribute Library_Src_Dir is not specified, sources of the
- -- interfaces are not copied anywhere.
-
- Library_ALI_Dir : Path_Information := No_Path_Information;
- -- In a library project, path name of the directory where the ALI files
- -- are copied. If attribute Library_ALI_Dir is not specified, ALI files
- -- are copied in the Library_Dir.
-
- Lib_Internal_Name : Name_Id := No_Name;
- -- If a library project, internal name store inside the library
-
- Standalone_Library : Standalone := No;
- -- Indicate that this is a Standalone Library Project File
-
- Lib_Interface_ALIs : String_List_Id := Nil_String;
- -- For Standalone Library Project Files, list of Interface ALI files
-
- Other_Interfaces : String_List_Id := Nil_String;
- -- List of non unit based sources in attribute Interfaces
-
- Lib_Auto_Init : Boolean := False;
- -- For non static Stand-Alone Library Project Files, True if the library
- -- initialisation should be automatic.
-
- Symbol_Data : Symbol_Record := No_Symbols;
- -- Symbol file name, reference symbol file name, symbol policy
-
- Need_To_Build_Lib : Boolean := False;
- -- True if the library of a Library Project needs to be built or rebuilt
-
- -------------
- -- Sources --
- -------------
- -- The sources for all languages including Ada are accessible through
- -- the Source_Iterator type
-
- Interfaces_Defined : Boolean := False;
- -- True if attribute Interfaces is declared for the project or any
- -- project it extends.
-
- Include_Path_File : Path_Name_Type := No_Path;
- -- The path name of the of the source search directory file.
- -- This is only used by gnatmake
-
- Source_Dirs : String_List_Id := Nil_String;
- -- The list of all the source directories
-
- Source_Dir_Ranks : Number_List_Index := No_Number_List;
-
- Ada_Include_Path : String_Access := null;
- -- The cached value of source search path for this project file. Set by
- -- the first call to Prj.Env.Ada_Include_Path for the project. Do not
- -- use this field directly outside of the project manager, use
- -- Prj.Env.Ada_Include_Path instead.
-
- Has_Multi_Unit_Sources : Boolean := False;
- -- Whether there is at least one source file containing multiple units
-
- -------------------
- -- Miscellaneous --
- -------------------
-
- Ada_Objects_Path : String_Access := null;
- -- The cached value of ADA_OBJECTS_PATH for this project file, with
- -- library ALI directories for library projects instead of object
- -- directories. Do not use this field directly outside of the
- -- compiler, use Prj.Env.Ada_Objects_Path instead.
-
- Ada_Objects_Path_No_Libs : String_Access := null;
- -- The cached value of ADA_OBJECTS_PATH for this project file with all
- -- object directories (no library ALI dir for library projects).
-
- Libgnarl_Needed : Yes_No_Unknown := Unknown;
- -- Set to True when libgnarl is needed to link
-
- Objects_Path : String_Access := null;
- -- The cached value of the object dir path, used during the binding
- -- phase of gprbuild.
-
- Objects_Path_File_With_Libs : Path_Name_Type := No_Path;
- -- The cached value of the object path temp file (including library
- -- dirs) for this project file.
-
- Objects_Path_File_Without_Libs : Path_Name_Type := No_Path;
- -- The cached value of the object path temp file (excluding library
- -- dirs) for this project file.
-
- Config_File_Name : Path_Name_Type := No_Path;
- -- The path name of the configuration pragmas file, if any
-
- Config_File_Temp : Boolean := False;
- -- True if the configuration pragmas file is a temporary file that must
- -- be deleted at the end.
-
- Config_Checked : Boolean := False;
- -- A flag to avoid checking repetitively the configuration pragmas file
-
- Depth : Natural := 0;
- -- The maximum depth of a project in the project graph. Depth of main
- -- project is 0.
-
- Unkept_Comments : Boolean := False;
- -- 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 | Aggregate_Library =>
- Aggregated_Projects : Aggregated_Project_List := null;
- -- List of aggregated projects (which could themselves be
- -- aggregate projects).
-
- when others =>
- null;
- end case;
- end record;
-
- function Empty_Project (Qualifier : Project_Qualifier) return Project_Data;
- -- Return the representation of an empty project
-
- function Is_Extending
- (Extending : Project_Id;
- Extended : Project_Id) return Boolean;
- -- Return True if Extending is extending the Extended project
-
- function Is_Ext
- (Extending : Project_Id;
- Extended : Project_Id) return Boolean renames Is_Extending;
-
- function Has_Ada_Sources (Data : Project_Id) return Boolean;
- -- Return True if the project has Ada sources
-
- Project_Error : exception;
- -- Raised by some subprograms in Prj.Attr
-
- package Units_Htable is new Simple_HTable
- (Header_Num => Header_Num,
- Element => Unit_Index,
- No_Element => No_Unit_Index,
- Key => Name_Id,
- Hash => Hash,
- Equal => "=");
- -- Mapping of unit names to indexes in the Units table
-
- ---------------------
- -- Source_Iterator --
- ---------------------
-
- type Source_Iterator is private;
-
- function For_Each_Source
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id := No_Project;
- Language : Name_Id := No_Name;
- Encapsulated_Libs : Boolean := True;
- Locally_Removed : Boolean := True) return Source_Iterator;
- -- Returns an iterator for all the sources of a project tree, or a specific
- -- project, or a specific language. Include sources from aggregated libs if
- -- Aggregated_Libs is True. If Locally_Removed is set to False the
- -- Locally_Removed files won't be reported.
-
- function Element (Iter : Source_Iterator) return Source_Id;
- -- Return the current source (or No_Source if there are no more sources)
-
- procedure Next (Iter : in out Source_Iterator);
- -- Move on to the next source
-
- function Find_Source
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- In_Imported_Only : Boolean := False;
- In_Extended_Only : Boolean := False;
- Base_Name : File_Name_Type;
- Index : Int := 0) return Source_Id;
- -- Find the first source file with the given name.
- -- If In_Extended_Only is True, it will search in project and the project
- -- it extends, but not in the imported projects.
- -- Elsif In_Imported_Only is True, it will search in project and the
- -- projects it imports, but not in the others or in aggregated projects.
- -- Else it searches in the whole tree.
- -- If Index is specified, this only search for a source with that index.
-
- type Source_Ids is array (Positive range <>) of Source_Id;
- No_Sources : constant Source_Ids := (1 .. 0 => No_Source);
-
- function Find_All_Sources
- (In_Tree : Project_Tree_Ref;
- Project : Project_Id;
- In_Imported_Only : Boolean := False;
- In_Extended_Only : Boolean := False;
- Base_Name : File_Name_Type;
- Index : Int := 0) return Source_Ids;
- -- Find all source files with the given name:
- --
- -- If In_Extended_Only is True, it will search in project and the project
- -- it extends, but not in the imported projects.
- --
- -- If Extended_Only is False, and In_Imported_Only is True, it will
- -- search in project and the projects it imports, but not in the others
- -- or in aggregated projects.
- --
- -- If both Extended_Only and In_Imported_Only are False (the default)
- -- then it searches the whole tree.
- --
- -- If Index is specified, this only search for sources with that index.
-
- -----------------------
- -- Project_Tree_Data --
- -----------------------
-
- package Replaced_Source_HTable is new Simple_HTable
- (Header_Num => Header_Num,
- Element => File_Name_Type,
- No_Element => No_File,
- Key => File_Name_Type,
- Hash => Hash,
- Equal => "=");
-
- type Private_Project_Tree_Data is private;
- -- Data for a project tree that is used only by the Project Manager
-
- type Shared_Project_Tree_Data is record
- Name_Lists : Name_List_Table.Instance;
- Number_Lists : Number_List_Table.Instance;
- String_Elements : String_Element_Table.Instance;
- Variable_Elements : Variable_Element_Table.Instance;
- Array_Elements : Array_Element_Table.Instance;
- Arrays : Array_Table.Instance;
- Packages : Package_Table.Instance;
- Private_Part : Private_Project_Tree_Data;
- Dot_String_List : String_List_Id := Nil_String;
- end record;
- type Shared_Project_Tree_Data_Access is access all Shared_Project_Tree_Data;
- -- The data that is shared among multiple trees, when these trees are
- -- loaded through the same aggregate project.
- -- To avoid ambiguities, limit the number of parameters to the
- -- subprograms (we would have to parse the "root project tree" since this
- -- is where the configuration file was loaded, in addition to the project's
- -- own tree) and make the comparison of projects easier, all trees store
- -- the lists in the same tables.
-
- type Project_Tree_Appdata is tagged null record;
- type Project_Tree_Appdata_Access is access all Project_Tree_Appdata'Class;
- -- Application-specific data that can be associated with a project tree.
- -- We do not make the Project_Tree_Data itself tagged for several reasons:
- -- - it couldn't have a default value for its discriminant
- -- - it would require a "factory" to allocate such data, because trees
- -- are created automatically when parsing aggregate projects.
-
- procedure Free (Tree : in out Project_Tree_Appdata);
- -- Should be overridden if your derive your own data
-
- type Project_Tree_Data (Is_Root_Tree : Boolean := True) is record
- -- The root tree is the one loaded by the user from the command line.
- -- Is_Root_Tree is only false for projects aggregated within a root
- -- aggregate project.
-
- Projects : Project_List;
- -- List of projects in this tree
-
- Replaced_Sources : Replaced_Source_HTable.Instance;
- -- The list of sources that have been replaced by sources with
- -- different file names.
-
- Replaced_Source_Number : Natural := 0;
- -- The number of entries in Replaced_Sources
-
- Units_HT : Units_Htable.Instance;
- -- Unit name to Unit_Index (and from there to Source_Id)
-
- Source_Files_HT : Source_Files_Htable.Instance;
- -- Base source file names to Source_Id list
-
- Source_Paths_HT : Source_Paths_Htable.Instance;
- -- Full path to Source_Id
- -- ??? What is behavior for multi-unit source files, where there are
- -- several source_id per file ?
-
- Source_Info_File_Name : String_Access := null;
- -- The name of the source info file, if specified by the builder
-
- Source_Info_File_Exists : Boolean := False;
- -- True when a source info file has been successfully read
-
- Shared : Shared_Project_Tree_Data_Access;
- -- The shared data for this tree and all aggregated trees
-
- Appdata : Project_Tree_Appdata_Access;
- -- Application-specific data for this tree
-
- case Is_Root_Tree is
- when True =>
- Shared_Data : aliased Shared_Project_Tree_Data;
- -- Do not access directly, only through Shared
-
- when False =>
- null;
- end case;
- end record;
- -- Data for a project tree
-
- function Debug_Name (Tree : Project_Tree_Ref) return Name_Id;
- -- If debug traces are activated, return an identitier for the project
- -- tree. This modifies Name_Buffer.
-
- procedure Expect (The_Token : Token_Type; Token_Image : String);
- -- Check that the current token is The_Token. If it is not, then output
- -- an error message.
-
- procedure Initialize (Tree : Project_Tree_Ref);
- -- This procedure must be called before using any services from the Prj
- -- hierarchy. Namet.Initialize must be called before Prj.Initialize.
-
- procedure Reset (Tree : Project_Tree_Ref);
- -- This procedure resets all the tables that are used when processing a
- -- project file tree. Initialize must be called before the call to Reset.
-
- package Project_Boolean_Htable is new Simple_HTable
- (Header_Num => Header_Num,
- Element => Boolean,
- No_Element => False,
- Key => Project_Id,
- Hash => Hash,
- Equal => "=");
- -- A table that associates a project to a boolean. This is used to detect
- -- whether a project was already processed for instance.
-
- generic
- with procedure Action (Project : Project_Id; Tree : Project_Tree_Ref);
- procedure For_Project_And_Aggregated
- (Root_Project : Project_Id;
- Root_Tree : Project_Tree_Ref);
- -- Execute Action for Root_Project and all its aggregated projects
- -- recursively.
-
- generic
- type State is limited private;
- with procedure Action
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out State);
- procedure For_Every_Project_Imported
- (By : Project_Id;
- Tree : Project_Tree_Ref;
- 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.
- --
- -- The order of processing depends on Imported_First:
- --
- -- If False, Action is called according to the order of importation: if A
- -- imports B, directly or indirectly, Action will be called for A before
- -- it is called for B. If two projects import each other directly or
- -- indirectly (using at least one "limited with"), it is not specified
- -- for which of these two projects Action will be called first.
- --
- -- The order is reversed if Imported_First is True
- --
- -- 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.
- --
- -- In_Aggregate_Lib is True if the project is in an aggregate library
- --
- -- The Tree argument passed to the callback is required in the case of
- -- aggregated projects, since they might not be using the same tree as 'By'
-
- type Project_Context is record
- In_Aggregate_Lib : Boolean;
- -- True if the project is part of an aggregate library
-
- From_Encapsulated_Lib : Boolean;
- -- True if the project is imported from an encapsulated library
- end record;
-
- generic
- type State is limited private;
- with procedure Action
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context;
- With_State : in out State);
- procedure For_Every_Project_Imported_Context
- (By : Project_Id;
- Tree : Project_Tree_Ref;
- With_State : in out State;
- Include_Aggregated : Boolean := True;
- Imported_First : Boolean := False);
- -- As for For_Every_Project_Imported but with an associated context
-
- generic
- with procedure Action
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Context : Project_Context);
- procedure For_Project_And_Aggregated_Context
- (Root_Project : Project_Id;
- Root_Tree : Project_Tree_Ref);
- -- As for For_Project_And_Aggregated but with an associated context
-
- function Extend_Name
- (File : File_Name_Type;
- With_Suffix : String) return File_Name_Type;
- -- Replace the extension of File with With_Suffix
-
- function Object_Name
- (Source_File_Name : File_Name_Type;
- Object_File_Suffix : Name_Id := No_Name) return File_Name_Type;
- -- Returns the object file name corresponding to a source file name
-
- function Object_Name
- (Source_File_Name : File_Name_Type;
- Source_Index : Int;
- Index_Separator : Character;
- Object_File_Suffix : Name_Id := No_Name) return File_Name_Type;
- -- Returns the object file name corresponding to a unit in a multi-source
- -- file.
-
- function Dependency_Name
- (Source_File_Name : File_Name_Type;
- Dependency : Dependency_File_Kind) return File_Name_Type;
- -- Returns the dependency file name corresponding to a source file name
-
- function Switches_Name
- (Source_File_Name : File_Name_Type) return File_Name_Type;
- -- Returns the switches file name corresponding to a source file name
-
- procedure Set_Path_File_Var (Name : String; Value : String);
- -- Call Setenv, after calling To_Host_File_Spec
-
- function Current_Source_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type;
- -- Get the current include path file name
-
- procedure Set_Current_Source_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access;
- To : Path_Name_Type);
- -- Record the current include path file name
-
- function Current_Object_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type;
- -- Get the current object path file name
-
- procedure Set_Current_Object_Path_File_Of
- (Shared : Shared_Project_Tree_Data_Access;
- To : Path_Name_Type);
- -- Record the current object path file name
-
- -----------
- -- Flags --
- -----------
-
- type Processing_Flags is private;
- -- 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
-
- type Error_Warning is (Silent, Warning, Error);
- -- Severity of some situations, such as: no Ada sources in a project where
- -- Ada is one of the language.
- --
- -- When the situation occurs, the behavior depends on the setting:
- --
- -- - Silent: no action
- -- - Warning: issue a warning, does not cause the tool to fail
- -- - Error: issue an error, causes the tool to fail
-
- type Error_Handler is access procedure
- (Project : Project_Id;
- Is_Warning : Boolean);
- -- This warns when an error was found when parsing a project. The error
- -- itself is handled through Prj.Err (and Prj.Err.Finalize should be called
- -- to actually print the error). This ensures that duplicate error messages
- -- are always correctly removed, that errors msgs are sorted, and that all
- -- tools will report the same error to the user.
-
- function Create_Flags
- (Report_Error : Error_Handler;
- When_No_Sources : Error_Warning;
- Require_Sources_Other_Lang : Boolean := True;
- Allow_Duplicate_Basenames : Boolean := True;
- Compiler_Driver_Mandatory : Boolean := False;
- Error_On_Unknown_Language : Boolean := True;
- Require_Obj_Dirs : Error_Warning := Error;
- Allow_Invalid_External : Error_Warning := Error;
- Missing_Source_Files : Error_Warning := Error;
- Ignore_Missing_With : Boolean := False)
- 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).
- --
- -- 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). When this parameter is set to False, we do not check
- -- that a proper naming scheme is defined for languages other than Ada.
- --
- -- 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
- --
- -- If Require_Obj_Dirs is true, then all object directories must exist
- -- (possibly after they have been created automatically if the appropriate
- -- switches were specified), or an error is raised.
- --
- -- If Allow_Invalid_External is Silent, then no error is reported when an
- -- invalid value is used for an external variable (and it doesn't match its
- -- type). Instead, the first possible value is used.
- --
- -- Missing_Source_Files indicates whether it is an error or a warning that
- -- a source file mentioned in the Source_Files attributes is not actually
- -- found in the source directories. This also impacts errors for missing
- -- source directories.
- --
- -- If Ignore_Missing_With is True, then a "with" statement that cannot be
- -- resolved will simply be ignored. However, in such a case, the flag
- -- Incomplete_With in the project tree will be set to True.
- -- This is meant for use by tools so that they can properly set the
- -- project path in such a case:
- -- * no "gnatls" found (so no default project path)
- -- * user project sets Project.IDE'gnatls attribute to a cross gnatls
- -- * user project also includes a "with" that can only be resolved
- -- once we have found the gnatls
-
- procedure Set_Ignore_Missing_With
- (Flags : in out Processing_Flags;
- Value : Boolean);
- -- Set the value of component Ignore_Missing_With in Flags to Value
-
- Gprbuild_Flags : constant Processing_Flags;
- Gprinstall_Flags : constant Processing_Flags;
- Gprclean_Flags : constant Processing_Flags;
- Gprexec_Flags : constant Processing_Flags;
- Gnatmake_Flags : constant Processing_Flags;
- -- Flags used by the various tools. They all display the error messages
- -- through Prj.Err.
-
- ----------------
- -- Temp Files --
- ----------------
-
- procedure Record_Temp_File
- (Shared : Shared_Project_Tree_Data_Access;
- Path : Path_Name_Type);
- -- Record the path of a newly created temporary file, so that it can be
- -- deleted later.
-
- procedure Delete_All_Temp_Files
- (Shared : Shared_Project_Tree_Data_Access);
- -- Delete all recorded temporary files.
- -- Does nothing if Debug.Debug_Flag_N is set
-
- procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref);
- -- Delete all temporary config files. Does nothing if Debug.Debug_Flag_N is
- -- set or if Project_Tree is null. This initially came from gnatmake
- -- ??? Should this be combined with Delete_All_Temp_Files above
-
- procedure Delete_Temporary_File
- (Shared : Shared_Project_Tree_Data_Access := null;
- Path : Path_Name_Type);
- -- Delete a temporary file from the disk. The file is also removed from the
- -- list of temporary files to delete at the end of the program, in case
- -- another program running on the same machine has recreated it. Does
- -- nothing if Debug.Debug_Flag_N is set
-
- Virtual_Prefix : constant String := "v$";
- -- The prefix for virtual extending projects. Because of the '$', which is
- -- normally forbidden for project names, there cannot be any name clash.
-
- -----------
- -- Debug --
- -----------
-
- type Verbosity is (Default, Medium, High);
- pragma Ordered (Verbosity);
- -- Verbosity when parsing GNAT Project Files
- -- Default is default (very quiet, if no errors).
- -- Medium is more verbose.
- -- High is extremely verbose.
-
- Current_Verbosity : Verbosity := Default;
- -- The current value of the verbosity the project files are parsed with
-
- procedure Debug_Indent;
- -- Inserts a series of blanks depending on the current indentation level
-
- procedure Debug_Output (Str : String);
- procedure Debug_Output (Str : String; Str2 : Name_Id);
- -- If Current_Verbosity is not Default, outputs Str.
- -- This indents Str based on the current indentation level for traces
- -- Debug_Error is intended to be used to report an error in the traces.
-
- procedure Debug_Increase_Indent
- (Str : String := ""; Str2 : Name_Id := No_Name);
- procedure Debug_Decrease_Indent (Str : String := "");
- -- Increase or decrease the indentation level for debug traces. This
- -- indentation level only affects output done through Debug_Output.
-
-private
- All_Packages : constant String_List_Access := null;
-
- No_Project_Tree : constant Project_Tree_Ref := null;
-
- Ignored : constant Variable_Kind := Single;
-
- Nil_Variable_Value : constant Variable_Value :=
- (Project => No_Project,
- Kind => Undefined,
- Location => No_Location,
- Default => False);
-
- type Source_Iterator is record
- In_Tree : Project_Tree_Ref;
-
- Project : Project_List;
- All_Projects : Boolean;
- -- Current project and whether we should move on to the next
-
- Language : Language_Ptr;
- -- Current language processed
-
- Language_Name : Name_Id;
- -- Only sources of this language will be returned (or all if No_Name)
-
- Current : Source_Id;
-
- Encapsulated_Libs : Boolean;
- -- True if we want to include the sources from encapsulated libs
-
- Locally_Removed : Boolean;
- end record;
-
- procedure Add_To_Buffer
- (S : String;
- To : in out String_Access;
- Last : in out Natural);
- -- Append a String to the Buffer
-
- -- Table used to store the path name of all the created temporary files, so
- -- that they can be deleted at the end, or when the program is interrupted.
-
- package Temp_Files_Table is new GNAT.Dynamic_Tables
- (Table_Component_Type => Path_Name_Type,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 10);
-
- -- The following type is used to represent the part of a project tree which
- -- is private to the Project Manager.
-
- type Private_Project_Tree_Data is record
- Temp_Files : Temp_Files_Table.Instance;
- -- Temporary files created as part of running tools (pragma files,
- -- mapping files,...)
-
- Current_Source_Path_File : Path_Name_Type := No_Path;
- -- Current value of project source path file env var. Used to avoid
- -- setting the env var to the same value. When different from No_Path,
- -- this indicates that environment variables were created and should be
- -- deassigned to avoid polluting the environment. For gnatmake only.
-
- Current_Object_Path_File : Path_Name_Type := No_Path;
- -- Current value of project object path file env var. Used to avoid
- -- setting the env var to the same value.
- -- gnatmake only
- end record;
-
- -- The following type is used to hold processing flags which show what
- -- functions are required for the various tools that are handled.
-
- type Processing_Flags is record
- Require_Sources_Other_Lang : Boolean;
- Report_Error : Error_Handler;
- When_No_Sources : Error_Warning;
- Allow_Duplicate_Basenames : Boolean;
- Compiler_Driver_Mandatory : Boolean;
- Error_On_Unknown_Language : Boolean;
- Require_Obj_Dirs : Error_Warning;
- Allow_Invalid_External : Error_Warning;
- Missing_Source_Files : Error_Warning;
- Ignore_Missing_With : Boolean;
-
- Incomplete_Withs : Boolean := False;
- -- This flag is set to True when the projects are parsed while ignoring
- -- missing withed project and some withed projects are not found.
-
- end record;
-
- Gprbuild_Flags : constant Processing_Flags :=
- (Report_Error => null,
- When_No_Sources => Warning,
- Require_Sources_Other_Lang => True,
- Allow_Duplicate_Basenames => False,
- Compiler_Driver_Mandatory => True,
- Error_On_Unknown_Language => True,
- Require_Obj_Dirs => Error,
- Allow_Invalid_External => Error,
- Missing_Source_Files => Error,
- Ignore_Missing_With => False,
- Incomplete_Withs => False);
-
- Gprinstall_Flags : constant Processing_Flags :=
- (Report_Error => null,
- When_No_Sources => Warning,
- Require_Sources_Other_Lang => True,
- Allow_Duplicate_Basenames => False,
- Compiler_Driver_Mandatory => True,
- Error_On_Unknown_Language => True,
- Require_Obj_Dirs => Silent,
- Allow_Invalid_External => Error,
- Missing_Source_Files => Error,
- Ignore_Missing_With => False,
- Incomplete_Withs => False);
-
- Gprclean_Flags : constant Processing_Flags :=
- (Report_Error => null,
- When_No_Sources => Warning,
- Require_Sources_Other_Lang => True,
- Allow_Duplicate_Basenames => False,
- Compiler_Driver_Mandatory => True,
- Error_On_Unknown_Language => True,
- Require_Obj_Dirs => Warning,
- Allow_Invalid_External => Error,
- Missing_Source_Files => Error,
- Ignore_Missing_With => False,
- Incomplete_Withs => False);
-
- Gprexec_Flags : constant Processing_Flags :=
- (Report_Error => null,
- When_No_Sources => Silent,
- Require_Sources_Other_Lang => False,
- Allow_Duplicate_Basenames => False,
- Compiler_Driver_Mandatory => False,
- Error_On_Unknown_Language => True,
- Require_Obj_Dirs => Silent,
- Allow_Invalid_External => Error,
- Missing_Source_Files => Silent,
- Ignore_Missing_With => False,
- Incomplete_Withs => False);
-
- Gnatmake_Flags : constant Processing_Flags :=
- (Report_Error => null,
- When_No_Sources => Error,
- Require_Sources_Other_Lang => False,
- Allow_Duplicate_Basenames => False,
- Compiler_Driver_Mandatory => False,
- Error_On_Unknown_Language => False,
- Require_Obj_Dirs => Error,
- Allow_Invalid_External => Error,
- Missing_Source_Files => Error,
- Ignore_Missing_With => False,
- Incomplete_Withs => False);
-
-end Prj;
Nkind_In (Kind, N_Formal_Object_Declaration,
N_Formal_Type_Declaration)
or else Is_Formal_Subprogram (E)
-
or else
(Ekind (E) = E_Package
and then Nkind (Original_Node (Unit_Declaration_Node (E))) =
- N_Formal_Package_Declaration);
+ N_Formal_Package_Declaration);
end if;
end Is_Generic_Formal;
Set_Parent_Spec (Pack_Decl, Parent_Spec (N));
end if;
- -- If the context of the instance is subject to SPARK_Mode "off" or
- -- the annotation is altogether missing, set the global flag which
- -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
- -- the instance.
-
- if SPARK_Mode /= On then
- Ignore_SPARK_Mode_Pragmas_In_Instance := True;
- end if;
-
Analyze (Pack_Decl);
Check_Formal_Packages (Pack_Id);
Set_Is_Generic_Instance (Pack_Id, False);
(Original_Node (Gen_Decl), Renaming_List);
Build_Subprogram_Renaming;
+
+ -- If the context of the instance is subject to SPARK_Mode "off" or
+ -- the annotation is altogether missing, set the global flag which
+ -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
+ -- the instance. This should be done prior to analyzing the instance.
+
+ if SPARK_Mode /= On then
+ Ignore_SPARK_Mode_Pragmas_In_Instance := True;
+ end if;
+
Analyze_Instance_And_Renamings;
-- If the generic is marked Import (Intrinsic), then so is the
Set_Has_Pragma_Inline_Always
(Anon_Id, Has_Pragma_Inline_Always (Gen_Unit));
- -- If the context of the instance is subject to SPARK_Mode "off" or
- -- the annotation is altogether missing, set the global flag which
- -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within
- -- the instance.
+ -- Mark both the instance spec and the anonymous package in case the
+ -- body is instantiated at a later pass. This preserves the original
+ -- context in effect for the body.
if SPARK_Mode /= On then
- Ignore_SPARK_Mode_Pragmas_In_Instance := True;
-
- -- Mark both the instance spec and the anonymous package in case
- -- the body is instantiated at a later pass. This preserves the
- -- original context in effect for the body.
-
Set_Ignore_SPARK_Mode_Pragmas (Act_Decl_Id);
Set_Ignore_SPARK_Mode_Pragmas (Anon_Id);
end if;
Adjust_Decl;
- -- If the current scope is a generic subprogram body. skip
- -- the generic formal parameters that are not frozen here.
+ -- If the current scope is a generic subprogram body. Skip the
+ -- generic formal parameters that are not frozen here.
if Is_Subprogram (Current_Scope)
- and then Nkind (Unit_Declaration_Node (Current_Scope))
- = N_Generic_Subprogram_Declaration
+ and then Nkind (Unit_Declaration_Node (Current_Scope)) =
+ N_Generic_Subprogram_Declaration
and then Present (First_Entity (Current_Scope))
then
while Is_Generic_Formal (Freeze_From) loop
Set_Assignment_Type (Lhs, T1);
- Resolve (Rhs, T1);
+ -- If the target of the assignment is an entity of a mutable type
+ -- and the expression is a conditional expression, its alternatives
+ -- can be of different subtypes of the nominal type of the LHS, so
+ -- they must be resolved with the base type, given that their subtype
+ -- may differ frok that of the target mutable object.
+
+ if Is_Entity_Name (Lhs)
+ and then Ekind_In (Entity (Lhs),
+ E_Variable,
+ E_Out_Parameter,
+ E_In_Out_Parameter)
+ and then Is_Composite_Type (T1)
+ and then not Is_Constrained (Etype (Entity (Lhs)))
+ and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression)
+ then
+ Resolve (Rhs, Base_Type (T1));
+
+ else
+ Resolve (Rhs, T1);
+ end if;
-- This is the point at which we check for an unset reference
-- synchronized type itself, with minimal semantic
-- attributes, to catch other errors in some ACATS tests.
- pragma Assert (Serious_Errors_Detected > 0);
+ pragma Assert (Serious_Errors_Detected /= 0);
Make_Class_Wide_Type (T);
C := Class_Wide_Type (T);
Set_First_Entity (C, First_Entity (T));
-- Unconstrained and tagged items are not part of the explicit
-- input set of the related subprogram, they do not have to be
-- present in a dependence relation and should not be flagged
- -- (SPARK RM 6.1.5(8)).
+ -- (SPARK RM 6.1.5(5)).
if not Is_Unconstrained_Or_Tagged_Item (Item_Id) then
Name_Len := 0;
Global_Seen => Dummy);
-- The item is classified as In_Out or Output but appears as
- -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
+ -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
if Appears_In (Inputs, Item_Id)
and then not Appears_In (Outputs, Item_Id)
-- are themselves expression functions.
if Present (Current_Subprogram)
- and then
- Is_Expression_Function_Or_Completion (Current_Subprogram)
+ and then Is_Expression_Function_Or_Completion
+ (Current_Subprogram)
then
if Present (Body_Id)
and then Present (Body_To_Inline (Nam_Decl))
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S I N P U T . P --
--- --
--- B o d y --
--- --
--- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-with Unchecked_Conversion;
-with Unchecked_Deallocation;
-
-with Prj.Err;
-with Sinput.C;
-
-package body Sinput.P is
-
- First : Boolean := True;
- -- Flag used when Load_Project_File is called the first time,
- -- to set Main_Source_File.
- -- The flag is reset to False at the first call to Load_Project_File.
- -- Calling Reset_First sets it back to True.
-
- procedure Free is new Unchecked_Deallocation
- (Lines_Table_Type, Lines_Table_Ptr);
-
- procedure Free is new Unchecked_Deallocation
- (Logical_Lines_Table_Type, Logical_Lines_Table_Ptr);
-
- -----------------------------
- -- Clear_Source_File_Table --
- -----------------------------
-
- procedure Clear_Source_File_Table is
- begin
- for X in 1 .. Source_File.Last loop
- declare
- S : Source_File_Record renames Source_File.Table (X);
- begin
- if S.Instance = No_Instance_Id then
- Free_Source_Buffer (S.Source_Text);
- else
- Free_Dope (S.Source_Text'Address);
- S.Source_Text := null;
- end if;
-
- Free (S.Lines_Table);
- Free (S.Logical_Lines_Table);
- end;
- end loop;
-
- Source_File.Free;
- Sinput.Initialize;
- end Clear_Source_File_Table;
-
- -----------------------
- -- Load_Project_File --
- -----------------------
-
- function Load_Project_File (Path : String) return Source_File_Index is
- X : Source_File_Index;
-
- begin
- X := Sinput.C.Load_File (Path);
-
- if First then
- Main_Source_File := X;
- First := False;
- end if;
-
- return X;
- end Load_Project_File;
-
- -----------------
- -- Reset_First --
- -----------------
-
- procedure Reset_First is
- begin
- First := True;
- end Reset_First;
-
- --------------------------------
- -- Restore_Project_Scan_State --
- --------------------------------
-
- procedure Restore_Project_Scan_State
- (Saved_State : Saved_Project_Scan_State)
- is
- begin
- Restore_Scan_State (Saved_State.Scan_State);
- Source := Saved_State.Source;
- Current_Source_File := Saved_State.Current_Source_File;
- end Restore_Project_Scan_State;
-
- -----------------------------
- -- Save_Project_Scan_State --
- -----------------------------
-
- procedure Save_Project_Scan_State
- (Saved_State : out Saved_Project_Scan_State)
- is
- begin
- Save_Scan_State (Saved_State.Scan_State);
- Saved_State.Source := Source;
- Saved_State.Current_Source_File := Current_Source_File;
- end Save_Project_Scan_State;
-
- ----------------------------
- -- Source_File_Is_Subunit --
- ----------------------------
-
- function Source_File_Is_Subunit (X : Source_File_Index) return Boolean is
- begin
- -- Nothing to do if X is no source file, so simply return False
-
- if X = No_Source_File then
- return False;
- end if;
-
- Prj.Err.Scanner.Initialize_Scanner (X);
-
- -- No error for special characters that are used for preprocessing
-
- Prj.Err.Scanner.Set_Special_Character ('#');
- Prj.Err.Scanner.Set_Special_Character ('$');
-
- Check_For_BOM;
-
- -- We scan past junk to the first interesting compilation unit token, to
- -- see if it is SEPARATE. We ignore WITH keywords during this and also
- -- PRIVATE. The reason for ignoring PRIVATE is that it handles some
- -- error situations, and also to handle PRIVATE WITH in Ada 2005 mode.
-
- while Token = Tok_With
- or else Token = Tok_Private
- or else (Token not in Token_Class_Cunit and then Token /= Tok_EOF)
- loop
- Prj.Err.Scanner.Scan;
- end loop;
-
- Prj.Err.Scanner.Reset_Special_Characters;
-
- return Token = Tok_Separate;
- end Source_File_Is_Subunit;
-
-end Sinput.P;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S I N P U T . P --
--- --
--- S p e c --
--- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
--- This child package contains the routines used to actually load a project
--- file and create entries in the source file table. It also contains two
--- routines to save and restore a project scan context.
-
-with Scans; use Scans;
-
-package Sinput.P is
-
- procedure Clear_Source_File_Table;
- -- This procedure frees memory allocated in the Source_File table (in the
- -- private part of package Sinput). It should only be used when it is
- -- guaranteed that all source files that have been loaded so far will not
- -- be accessed before being reloaded. It is intended for tools that parse
- -- several times sources, to avoid memory leaks.
-
- function Load_Project_File (Path : String) return Source_File_Index;
- -- Load the source of a project source file into memory and initialize the
- -- Scans state.
-
- procedure Reset_First;
- -- Indicate that the next project loaded should be considered as the first
- -- one, so that Sinput.Main_Source_File is set for this project file. This
- -- is to get the correct number of lines when error finalization is called.
-
- function Source_File_Is_Subunit (X : Source_File_Index) return Boolean;
- -- This function determines if a source file represents a subunit. It works
- -- by scanning for the first compilation unit token, and returning True if
- -- it is the token SEPARATE. It will return False otherwise, meaning that
- -- the file cannot possibly be a legal subunit. This function does NOT do a
- -- complete parse of the file, or build a tree. It is used in gnatmake and
- -- gprbuild to decide if a body without a spec in a project file needs to
- -- be compiled or not. Returns False if X = No_Source_File.
-
- type Saved_Project_Scan_State is limited private;
- -- Used to save project scan state in following two routines
-
- procedure Save_Project_Scan_State
- (Saved_State : out Saved_Project_Scan_State);
- pragma Inline (Save_Project_Scan_State);
- -- Save the Scans state, as well as the values of Source and
- -- Current_Source_File.
-
- procedure Restore_Project_Scan_State
- (Saved_State : Saved_Project_Scan_State);
- pragma Inline (Restore_Project_Scan_State);
- -- Restore the Scans state and the values of Source and
- -- Current_Source_File.
-
-private
-
- type Saved_Project_Scan_State is record
- Scan_State : Saved_Scan_State;
- Source : Source_Buffer_Ptr;
- Current_Source_File : Source_File_Index;
- end record;
-
-end Sinput.P;
projects / gcc.git / commitdiff