From: Arnaud Charlet Date: Wed, 6 Sep 2017 13:21:31 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=c48e0f27232aa6604b80e0d15b6ecb50604400a7;p=gcc.git [multiple changes] 2017-09-06 Hristian Kirtchev * sem_ch3.adb, sem_aux.adb, sem_res.adb: Minor reformatting. 2017-09-06 Yannick Moy * 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 * sem_ch8.adb: Change Assert to be consistent with other similar ones. 2017-09-06 Bob Duff * 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 * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Fix reference to SPARK RM. 2017-09-06 Eric Botcazou * layout.adb: Use SSU short hand consistently throughout the file. 2017-09-06 Eric Botcazou * freeze.adb (Freeze_Record_Type) : 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 * 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 * 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. From-SVN: r251797 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b746bff0527..81c3e14df0c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,78 @@ +2017-09-06 Hristian Kirtchev + + * sem_ch3.adb, sem_aux.adb, sem_res.adb: Minor reformatting. + +2017-09-06 Yannick Moy + + * 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 + + * sem_ch8.adb: Change Assert to be consistent with + other similar ones. + +2017-09-06 Bob Duff + + * 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 + + * sem_prag.adb (Check_Mode_Restriction_In_Enclosing_Context): Fix + reference to SPARK RM. + +2017-09-06 Eric Botcazou + + * layout.adb: Use SSU short hand consistently throughout the file. + +2017-09-06 Eric Botcazou + + * freeze.adb (Freeze_Record_Type) + : 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 + + * 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 + + * 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 * checks.adb (Apply_Predicate_Check): If the expression is an diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads index 8950298b7a9..e15a1c455bd 100644 --- a/gcc/ada/ali.ads +++ b/gcc/ada/ali.ads @@ -361,7 +361,7 @@ package ALI is -- 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. diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb index 869cc4347d6..329c6ca395f 100644 --- a/gcc/ada/binde.adb +++ b/gcc/ada/binde.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -229,7 +229,7 @@ package body Binde is -- 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. @@ -279,7 +279,7 @@ package body Binde is -- 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 ----------------------- @@ -329,7 +329,8 @@ package body Binde is -- 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. @@ -984,7 +985,9 @@ package body Binde is -- 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; @@ -993,7 +996,7 @@ package body Binde is 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, @@ -1081,7 +1084,18 @@ package body Binde is 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; @@ -1099,7 +1113,8 @@ package body Binde is then null; else - Choose (Elab_Order, Corresponding_Body (Chosen)); + Choose (Elab_Order, Corresponding_Body (Chosen), + " [Elaborate_Body]"); end if; end if; end Choose; @@ -1196,7 +1211,7 @@ package body Binde is -- 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 @@ -1213,7 +1228,7 @@ package body Binde is 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; @@ -1591,7 +1606,7 @@ package body Binde is 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; @@ -1602,13 +1617,14 @@ package body Binde is 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 @@ -1623,119 +1639,129 @@ package body Binde is 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; @@ -2927,7 +2953,7 @@ package body Binde is -- 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; @@ -2979,7 +3005,7 @@ package body Binde is -- 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 @@ -3007,7 +3033,8 @@ package body Binde 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; @@ -3027,7 +3054,7 @@ package body Binde is 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; @@ -3074,7 +3101,7 @@ package body Binde is 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; @@ -3125,7 +3152,7 @@ package body Binde is -- 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; @@ -3173,7 +3200,7 @@ package body Binde is -- 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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 619c921b76c..66e8e85a458 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -3818,6 +3818,10 @@ package body Freeze is -- 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 @@ -4123,21 +4127,31 @@ package body Freeze is -- 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; @@ -4603,12 +4617,13 @@ package body Freeze is 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 diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index 4373a970ec4..577cf0403d9 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -6,7 +6,7 @@ -- -- -- 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- -- @@ -2728,8 +2728,8 @@ package body Layout is -- 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 @@ -2741,7 +2741,7 @@ package body Layout is -- 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)); @@ -2971,11 +2971,11 @@ package body Layout is -- 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 @@ -2983,11 +2983,11 @@ package body Layout is -- 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; @@ -2998,14 +2998,14 @@ package body Layout is -- 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; @@ -3034,10 +3034,10 @@ package body Layout is -- 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, @@ -3068,8 +3068,7 @@ package body Layout is (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; @@ -3088,9 +3087,9 @@ package body Layout is 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; diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb deleted file mode 100644 index 53233a02e30..00000000000 --- a/gcc/ada/makeutl.adb +++ /dev/null @@ -1,3595 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 (). - - 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; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads deleted file mode 100644 index c13a151dcb2..00000000000 --- a/gcc/ada/makeutl.ads +++ /dev/null @@ -1,615 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-fil.adb b/gcc/ada/mlib-fil.adb deleted file mode 100644 index 8632ef3caa9..00000000000 --- a/gcc/ada/mlib-fil.adb +++ /dev/null @@ -1,149 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-fil.ads b/gcc/ada/mlib-fil.ads deleted file mode 100644 index dd5edfeb366..00000000000 --- a/gcc/ada/mlib-fil.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb deleted file mode 100644 index d830b668378..00000000000 --- a/gcc/ada/mlib-prj.adb +++ /dev/null @@ -1,2481 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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~.adb -L_" - - 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 -c b__.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- (7 + version'length chars) - -- -lgnarl- (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; diff --git a/gcc/ada/mlib-prj.ads b/gcc/ada/mlib-prj.ads deleted file mode 100644 index 6a32dd35210..00000000000 --- a/gcc/ada/mlib-prj.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-aix.adb b/gcc/ada/mlib-tgt-specific-aix.adb deleted file mode 100644 index 9fb8b1593f9..00000000000 --- a/gcc/ada/mlib-tgt-specific-aix.adb +++ /dev/null @@ -1,225 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-darwin.adb b/gcc/ada/mlib-tgt-specific-darwin.adb deleted file mode 100644 index bc54dbfb918..00000000000 --- a/gcc/ada/mlib-tgt-specific-darwin.adb +++ /dev/null @@ -1,171 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-hpux.adb b/gcc/ada/mlib-tgt-specific-hpux.adb deleted file mode 100644 index 57e40841a80..00000000000 --- a/gcc/ada/mlib-tgt-specific-hpux.adb +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-linux.adb b/gcc/ada/mlib-tgt-specific-linux.adb deleted file mode 100644 index 8559966bfe5..00000000000 --- a/gcc/ada/mlib-tgt-specific-linux.adb +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-mingw.adb b/gcc/ada/mlib-tgt-specific-mingw.adb deleted file mode 100644 index f1eedf5f234..00000000000 --- a/gcc/ada/mlib-tgt-specific-mingw.adb +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-solaris.adb b/gcc/ada/mlib-tgt-specific-solaris.adb deleted file mode 100644 index d7cdfcc49af..00000000000 --- a/gcc/ada/mlib-tgt-specific-solaris.adb +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-vxworks.adb b/gcc/ada/mlib-tgt-specific-vxworks.adb deleted file mode 100644 index 29abd80147f..00000000000 --- a/gcc/ada/mlib-tgt-specific-vxworks.adb +++ /dev/null @@ -1,217 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific-xi.adb b/gcc/ada/mlib-tgt-specific-xi.adb deleted file mode 100644 index ac64be4b837..00000000000 --- a/gcc/ada/mlib-tgt-specific-xi.adb +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific.adb b/gcc/ada/mlib-tgt-specific.adb deleted file mode 100644 index 16988b3d6e7..00000000000 --- a/gcc/ada/mlib-tgt-specific.adb +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt-specific.ads b/gcc/ada/mlib-tgt-specific.ads deleted file mode 100644 index 7cc891bd7e7..00000000000 --- a/gcc/ada/mlib-tgt-specific.ads +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt.adb b/gcc/ada/mlib-tgt.adb deleted file mode 100644 index 4d8597c1f73..00000000000 --- a/gcc/ada/mlib-tgt.adb +++ /dev/null @@ -1,505 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-tgt.ads b/gcc/ada/mlib-tgt.ads deleted file mode 100644 index 0260159bfeb..00000000000 --- a/gcc/ada/mlib-tgt.ads +++ /dev/null @@ -1,270 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-utl.adb b/gcc/ada/mlib-utl.adb deleted file mode 100644 index 91890a15dc4..00000000000 --- a/gcc/ada/mlib-utl.adb +++ /dev/null @@ -1,644 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib-utl.ads b/gcc/ada/mlib-utl.ads deleted file mode 100644 index f91eebf7f51..00000000000 --- a/gcc/ada/mlib-utl.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib.adb b/gcc/ada/mlib.adb deleted file mode 100644 index c4faea0e4a1..00000000000 --- a/gcc/ada/mlib.adb +++ /dev/null @@ -1,464 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/mlib.ads b/gcc/ada/mlib.ads deleted file mode 100644 index e370fa48de9..00000000000 --- a/gcc/ada/mlib.ads +++ /dev/null @@ -1,95 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-attr-pm.adb b/gcc/ada/prj-attr-pm.adb deleted file mode 100644 index f9f41b16283..00000000000 --- a/gcc/ada/prj-attr-pm.adb +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-attr-pm.ads b/gcc/ada/prj-attr-pm.ads deleted file mode 100644 index 0c6ce2e0fed..00000000000 --- a/gcc/ada/prj-attr-pm.ads +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-attr.adb b/gcc/ada/prj-attr.adb deleted file mode 100644 index 767fdb9a384..00000000000 --- a/gcc/ada/prj-attr.adb +++ /dev/null @@ -1,1107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-attr.ads b/gcc/ada/prj-attr.ads deleted file mode 100644 index ad2f033e7ad..00000000000 --- a/gcc/ada/prj-attr.ads +++ /dev/null @@ -1,368 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 => ); - -- Att : constant Attribute_Node_Id := - -- Prj.Attr.Attribute_Node_Id_Of - -- (Name => , - -- Starting_At => First_Attribute_Of (Pkg)); - -- Kind : constant Attribute_Kind := Attribute_Kind_Of (Att); - -- - -- However, do not use this function once you have an already parsed - -- project tree. Instead, given a Project_Node_Id corresponding to the - -- attribute declaration ("for Attr (index) use ..."), use for example: - -- - -- if Case_Insensitive (Attr, Tree) then ... - - procedure Set_Attribute_Kind_Of - (Attribute : Attribute_Node_Id; - To : Attribute_Kind); - -- Set the attribute kind of a known attribute. Does nothing if - -- Attribute is Empty_Attribute. - - function Attribute_Name_Of (Attribute : Attribute_Node_Id) return Name_Id; - -- Returns the name of a known attribute. Returns No_Name if Attribute is - -- Empty_Attribute. - - function Variable_Kind_Of - (Attribute : Attribute_Node_Id) return Variable_Kind; - -- Returns the variable kind of a known attribute. Returns Undefined if - -- Attribute is Empty_Attribute. - - procedure Set_Variable_Kind_Of - (Attribute : Attribute_Node_Id; - To : Variable_Kind); - -- Set the variable kind of a known attribute. Does nothing if Attribute is - -- Empty_Attribute. - - function 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; diff --git a/gcc/ada/prj-com.ads b/gcc/ada/prj-com.ads deleted file mode 100644 index f5f2fa689f9..00000000000 --- a/gcc/ada/prj-com.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-conf.adb b/gcc/ada/prj-conf.adb deleted file mode 100644 index e48b7fba016..00000000000 --- a/gcc/ada/prj-conf.adb +++ /dev/null @@ -1,2314 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 () 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; - - <> - - 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 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; diff --git a/gcc/ada/prj-conf.ads b/gcc/ada/prj-conf.ads deleted file mode 100644 index 41ef5eb858c..00000000000 --- a/gcc/ada/prj-conf.ads +++ /dev/null @@ -1,223 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb deleted file mode 100644 index 9c9472cc61e..00000000000 --- a/gcc/ada/prj-dect.adb +++ /dev/null @@ -1,1809 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 is ( { , } ) ; - - procedure Parse_Variable_Declaration - (In_Tree : Project_Node_Tree_Ref; - Variable : out Project_Node_Id; - Current_Project : Project_Node_Id; - Current_Package : Project_Node_Id; - Flags : Processing_Flags); - -- Parse a variable assignment - -- := ; OR - -- : := ; - - ----------- - -- Parse -- - ----------- - - procedure Parse - (In_Tree : Project_Node_Tree_Ref; - Declarations : out Project_Node_Id; - Current_Project : Project_Node_Id; - Extends : Project_Node_Id; - Packages_To_Check : String_List_Access; - Is_Config_File : Boolean; - Flags : Processing_Flags) - is - First_Declarative_Item : Project_Node_Id := Empty_Node; - - begin - Declarations := - Default_Project_Node - (Of_Kind => N_Project_Declaration, In_Tree => In_Tree); - Set_Location_Of (Declarations, In_Tree, To => Token_Ptr); - Set_Extended_Project_Of (Declarations, In_Tree, To => Extends); - Set_Project_Declaration_Of (Current_Project, In_Tree, Declarations); - Parse_Declarative_Items - (Declarations => First_Declarative_Item, - In_Tree => In_Tree, - In_Zone => In_Project, - First_Attribute => Prj.Attr.Attribute_First, - Current_Project => Current_Project, - Current_Package => Empty_Node, - Packages_To_Check => Packages_To_Check, - Is_Config_File => Is_Config_File, - Flags => Flags); - Set_First_Declarative_Item_Of - (Declarations, In_Tree, To => First_Declarative_Item); - end Parse; - - ----------------------------------- - -- Rename_Obsolescent_Attributes -- - ----------------------------------- - - procedure Rename_Obsolescent_Attributes - (In_Tree : Project_Node_Tree_Ref; - Attribute : Project_Node_Id; - Current_Package : Project_Node_Id) - is - begin - if Present (Current_Package) - and then Expression_Kind_Of (Current_Package, In_Tree) /= Ignored - then - case Name_Of (Attribute, In_Tree) is - when Snames.Name_Specification => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec); - - when Snames.Name_Specification_Suffix => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Spec_Suffix); - - when Snames.Name_Implementation => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body); - - when Snames.Name_Implementation_Suffix => - Set_Name_Of (Attribute, In_Tree, To => Snames.Name_Body_Suffix); - - when others => - null; - end case; - end if; - end Rename_Obsolescent_Attributes; - - --------------------------- - -- Check_Package_Allowed -- - --------------------------- - - procedure Check_Package_Allowed - (In_Tree : Project_Node_Tree_Ref; - Project : Project_Node_Id; - Current_Package : Project_Node_Id; - Flags : Processing_Flags) - is - Qualif : constant Project_Qualifier := - Project_Qualifier_Of (Project, In_Tree); - Name : constant Name_Id := Name_Of (Current_Package, In_Tree); - begin - if 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 ', or - -- .' - - declare - The_Project : Project_Node_Id := Empty_Node; - -- The node of the project where the associative array is - -- declared. - - The_Package : Project_Node_Id := Empty_Node; - -- The node of the package where the associative array is - -- declared, if any. - - Project_Name : Name_Id := No_Name; - -- The name of the project where the associative array is - -- declared. - - Location : Source_Ptr := No_Location; - -- The location of the project name - - begin - Expect (Tok_Identifier, "identifier"); - - if Token = Tok_Identifier then - Location := Token_Ptr; - - -- Find the project node in the imported project or - -- in the project being extended. - - The_Project := Imported_Or_Extended_Project_Of - (Current_Project, In_Tree, Token_Name); - - if No (The_Project) 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 ' - - 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; diff --git a/gcc/ada/prj-dect.ads b/gcc/ada/prj-dect.ads deleted file mode 100644 index 2af6e27fd0b..00000000000 --- a/gcc/ada/prj-dect.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb deleted file mode 100644 index 18741be7917..00000000000 --- a/gcc/ada/prj-env.adb +++ /dev/null @@ -1,2429 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 :/ 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 /. - - if not Has_Dot then - Result := - Try_Path_Name - (Self, - Directory & Directory_Separator - & File & Project_File_Extension); - end if; - - -- Then we try / - - if Result = null then - Result := - Try_Path_Name (Self, Directory & Directory_Separator & File); - end if; - end if; - - -- If we found the path in the cache, this is the one - - if Result = null and then Cached_Path /= No_Path then - Path := Cached_Path; - Debug_Decrease_Indent; - return; - end if; - - -- Then we try . - - if Result = null and then not Has_Dot then - Result := Try_Path_Name (Self, File & Project_File_Extension); - end if; - - -- Then we try - - if Result = null then - Result := Try_Path_Name (Self, File); - end if; - - -- If we cannot find the project file, we return an empty string - - if Result = null then - Path := Namet.No_Path; - return; - - else - declare - Final_Result : constant String := - GNAT.OS_Lib.Normalize_Pathname - (Result.all, - Directory => Directory, - Resolve_Links => Opt.Follow_Links_For_Files, - Case_Sensitive => True); - begin - Free (Result); - Name_Len := Final_Result'Length; - Name_Buffer (1 .. Name_Len) := Final_Result; - Path := Name_Find; - Projects_Paths.Set (Self.Cache, Key, Path); - end; - end if; - - Debug_Decrease_Indent; - end Find_Project; - - ---------- - -- Free -- - ---------- - - procedure Free (Self : in out Project_Search_Path) is - begin - Free (Self.Path); - Projects_Paths.Reset (Self.Cache); - end Free; - - ---------- - -- Copy -- - ---------- - - procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is - begin - Free (To); - - if From.Path /= null then - To.Path := new String'(From.Path.all); - end if; - - -- No need to copy the Cache, it will be recomputed as needed - end Copy; - -end Prj.Env; diff --git a/gcc/ada/prj-env.ads b/gcc/ada/prj-env.ads deleted file mode 100644 index a7617afab90..00000000000 --- a/gcc/ada/prj-env.ads +++ /dev/null @@ -1,275 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-err.adb b/gcc/ada/prj-err.adb deleted file mode 100644 index 44ad905c21a..00000000000 --- a/gcc/ada/prj-err.adb +++ /dev/null @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-err.ads b/gcc/ada/prj-err.ads deleted file mode 100644 index 3f6b684130c..00000000000 --- a/gcc/ada/prj-err.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb deleted file mode 100644 index 127438d8a24..00000000000 --- a/gcc/ada/prj-ext.adb +++ /dev/null @@ -1,290 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-ext.ads b/gcc/ada/prj-ext.ads deleted file mode 100644 index ca01959789e..00000000000 --- a/gcc/ada/prj-ext.ads +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 = 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; diff --git a/gcc/ada/prj-makr.adb b/gcc/ada/prj-makr.adb deleted file mode 100644 index 06cb64b32e8..00000000000 --- a/gcc/ada/prj-makr.adb +++ /dev/null @@ -1,1571 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-makr.ads b/gcc/ada/prj-makr.ads deleted file mode 100644 index 91543a2ff79..00000000000 --- a/gcc/ada/prj-makr.ads +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb deleted file mode 100644 index a224e7d0384..00000000000 --- a/gcc/ada/prj-nmsc.adb +++ /dev/null @@ -1,8697 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 () - - Lang_Index.Config.Binder_Driver := - File_Name_Type (Element.Value.Value); - - when Name_Required_Switches => - Put - (Into_List => - Lang_Index.Config.Binder_Required_Switches, - From_List => Element.Value.Values, - In_Tree => Data.Tree); - - when Name_Prefix => - - -- Attribute Prefix () - - Lang_Index.Config.Binder_Prefix := - Element.Value.Value; - - when Name_Objects_Path => - - -- Attribute Objects_Path () - - Lang_Index.Config.Objects_Path := - Element.Value.Value; - - when Name_Objects_Path_File => - - -- Attribute Objects_Path () - - Lang_Index.Config.Objects_Path_File := - Element.Value.Value; - - when others => - null; - end case; - end if; - end if; - - Element_Id := Element.Next; - end loop; - - Current_Array_Id := Current_Array.Next; - end loop; - end Process_Binder; - - --------------------- - -- Process_Builder -- - --------------------- - - procedure Process_Builder (Attributes : Variable_Id) is - Attribute_Id : Variable_Id; - Attribute : Variable; - - begin - -- Process non associated array attribute from package Builder - - Attribute_Id := Attributes; - while Attribute_Id /= No_Variable loop - Attribute := Shared.Variable_Elements.Table (Attribute_Id); - - if not Attribute.Value.Default then - if Attribute.Name = Name_Executable_Suffix then - - -- Attribute Executable_Suffix: the suffix of the - -- executables. - - Project.Config.Executable_Suffix := - Attribute.Value.Value; - end if; - end if; - - Attribute_Id := Attribute.Next; - end loop; - end Process_Builder; - - ------------------- - -- Process_Clean -- - ------------------- - - procedure Process_Clean (Attributes : Variable_Id) is - Attribute_Id : Variable_Id; - Attribute : Variable; - List : String_List_Id; - - begin - -- Process non associated array attributes from package Clean - - Attribute_Id := Attributes; - while Attribute_Id /= No_Variable loop - Attribute := Shared.Variable_Elements.Table (Attribute_Id); - - if not Attribute.Value.Default then - if Attribute.Name = Name_Artifacts_In_Exec_Dir then - - -- Attribute Artifacts_In_Exec_Dir: the list of file - -- names to be cleaned in the exec dir of the main - -- project. - - List := Attribute.Value.Values; - - if List /= Nil_String then - Put (Into_List => - Project.Config.Artifacts_In_Exec_Dir, - From_List => List, - In_Tree => Data.Tree); - end if; - - elsif Attribute.Name = Name_Artifacts_In_Object_Dir then - - -- Attribute Artifacts_In_Exec_Dir: the list of file - -- names to be cleaned in the object dir of every - -- project. - - List := Attribute.Value.Values; - - if List /= Nil_String then - Put (Into_List => - Project.Config.Artifacts_In_Object_Dir, - From_List => List, - In_Tree => Data.Tree); - end if; - end if; - end if; - - Attribute_Id := Attribute.Next; - end loop; - end Process_Clean; - - procedure Process_Clean (Arrays : Array_Id) is - Current_Array_Id : Array_Id; - Current_Array : Array_Data; - Element_Id : Array_Element_Id; - Element : Array_Element; - List : String_List_Id; - - begin - -- Process the associated array attributes of package Clean - - Current_Array_Id := Arrays; - while Current_Array_Id /= No_Array loop - Current_Array := Shared.Arrays.Table (Current_Array_Id); - - Element_Id := Current_Array.Value; - while Element_Id /= No_Array_Element loop - Element := Shared.Array_Elements.Table (Element_Id); - - -- Get the name of the language - - Lang_Index := - Get_Language_From_Name - (Project, Get_Name_String (Element.Index)); - - if Lang_Index /= No_Language_Index then - case Current_Array.Name is - - -- Attribute Object_Artifact_Extensions () - - when Name_Object_Artifact_Extensions => - List := Element.Value.Values; - - if List /= Nil_String then - Put (Into_List => - Lang_Index.Config.Clean_Object_Artifacts, - From_List => List, - In_Tree => Data.Tree); - end if; - - -- Attribute Source_Artifact_Extensions () - - when Name_Source_Artifact_Extensions => - List := Element.Value.Values; - - if List /= Nil_String then - Put (Into_List => - Lang_Index.Config.Clean_Source_Artifacts, - From_List => List, - In_Tree => Data.Tree); - end if; - - when others => - null; - end case; - end if; - - Element_Id := Element.Next; - end loop; - - Current_Array_Id := Current_Array.Next; - end loop; - end Process_Clean; - - ---------------------- - -- Process_Compiler -- - ---------------------- - - procedure Process_Compiler (Arrays : Array_Id) is - Current_Array_Id : Array_Id; - Current_Array : Array_Data; - Element_Id : Array_Element_Id; - Element : Array_Element; - List : String_List_Id; - - begin - -- Process the associative array attribute of package Compiler - - Current_Array_Id := Arrays; - while Current_Array_Id /= No_Array loop - Current_Array := Shared.Arrays.Table (Current_Array_Id); - - Element_Id := Current_Array.Value; - while Element_Id /= No_Array_Element loop - Element := Shared.Array_Elements.Table (Element_Id); - - if Element.Index /= All_Other_Names then - - -- Get the name of the language - - Lang_Index := Get_Language_From_Name - (Project, Get_Name_String (Element.Index)); - - if Lang_Index /= No_Language_Index then - case Current_Array.Name is - - -- Attribute Dependency_Kind () - - when Name_Dependency_Kind => - Get_Name_String (Element.Value.Value); - - begin - Lang_Index.Config.Dependency_Kind := - Dependency_File_Kind'Value - (Name_Buffer (1 .. Name_Len)); - - exception - when Constraint_Error => - Error_Msg - (Data.Flags, - "illegal value for Dependency_Kind", - Element.Value.Location, - Project); - end; - - -- Attribute Dependency_Switches () - - when Name_Dependency_Switches => - if Lang_Index.Config.Dependency_Kind = None then - Lang_Index.Config.Dependency_Kind := Makefile; - end if; - - List := Element.Value.Values; - - if List /= Nil_String then - Put (Into_List => - Lang_Index.Config.Dependency_Option, - From_List => List, - In_Tree => Data.Tree); - end if; - - -- Attribute Dependency_Driver () - - when Name_Dependency_Driver => - if Lang_Index.Config.Dependency_Kind = None then - Lang_Index.Config.Dependency_Kind := Makefile; - end if; - - List := Element.Value.Values; - - if List /= Nil_String then - Put (Into_List => - Lang_Index.Config.Compute_Dependency, - From_List => List, - In_Tree => Data.Tree); - end if; - - -- Attribute Language_Kind () - - when Name_Language_Kind => - Get_Name_String (Element.Value.Value); - - begin - Lang_Index.Config.Kind := - Language_Kind'Value - (Name_Buffer (1 .. Name_Len)); - - exception - when Constraint_Error => - Error_Msg - (Data.Flags, - "illegal value for Language_Kind", - Element.Value.Location, - Project); - end; - - -- Attribute Include_Switches () - - when Name_Include_Switches => - List := Element.Value.Values; - - if List = Nil_String then - Error_Msg - (Data.Flags, "include option cannot be null", - Element.Value.Location, Project); - end if; - - Put (Into_List => Lang_Index.Config.Include_Option, - From_List => List, - In_Tree => Data.Tree); - - -- Attribute Include_Path () - - when Name_Include_Path => - Lang_Index.Config.Include_Path := - Element.Value.Value; - - -- Attribute Include_Path_File () - - when Name_Include_Path_File => - Lang_Index.Config.Include_Path_File := - Element.Value.Value; - - -- Attribute Driver () - - when Name_Driver => - Lang_Index.Config.Compiler_Driver := - File_Name_Type (Element.Value.Value); - - when Name_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 () - - when Name_Pic_Option => - List := Element.Value.Values; - - if List = Nil_String then - Error_Msg - (Data.Flags, - "compiler PIC option cannot be null", - Element.Value.Location, Project); - end if; - - Put (Into_List => - Lang_Index.Config.Compilation_PIC_Option, - From_List => List, - In_Tree => Data.Tree); - - -- Attribute Mapping_File_Switches () - - when Name_Mapping_File_Switches => - List := Element.Value.Values; - - if List = Nil_String then - Error_Msg - (Data.Flags, - "mapping file switches cannot be null", - Element.Value.Location, Project); - end if; - - Put (Into_List => - Lang_Index.Config.Mapping_File_Switches, - From_List => List, - In_Tree => Data.Tree); - - -- Attribute Mapping_Spec_Suffix () - - when Name_Mapping_Spec_Suffix => - Lang_Index.Config.Mapping_Spec_Suffix := - File_Name_Type (Element.Value.Value); - - -- Attribute Mapping_Body_Suffix () - - when Name_Mapping_Body_Suffix => - Lang_Index.Config.Mapping_Body_Suffix := - File_Name_Type (Element.Value.Value); - - -- Attribute Config_File_Switches () - - 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 () - - when Name_Objects_Path => - Lang_Index.Config.Objects_Path := - Element.Value.Value; - - -- Attribute Objects_Path_File () - - when Name_Objects_Path_File => - Lang_Index.Config.Objects_Path_File := - Element.Value.Value; - - -- Attribute Config_Body_File_Name () - - 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() - - when Name_Config_Body_File_Name_Pattern => - Lang_Index.Config.Config_Body_Pattern := - Element.Value.Value; - - -- Attribute Config_Spec_File_Name () - - when Name_Config_Spec_File_Name => - Lang_Index.Config.Config_Spec := - Element.Value.Value; - - -- Attribute Config_Spec_File_Name_Index () - - when Name_Config_Spec_File_Name_Index => - Lang_Index.Config.Config_Spec_Index := - Element.Value.Value; - - -- Attribute Config_Spec_File_Name_Pattern() - - when Name_Config_Spec_File_Name_Pattern => - Lang_Index.Config.Config_Spec_Pattern := - Element.Value.Value; - - -- Attribute Config_File_Unique () - - 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 () - - 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 () - - 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 () - - Lang_Index.Config.Toolchain_Description := - Element.Value.Value; - - when Name_Toolchain_Version => - - -- Attribute Toolchain_Version () - - 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 () - - Lang_Index.Config.Runtime_Library_Dir := - Element.Value.Value; - - when Name_Runtime_Source_Dir => - - -- Attribute Runtime_Source_Dir () - - 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, - " 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 := - " - 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; diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads deleted file mode 100644 index fd45ba91e7f..00000000000 --- a/gcc/ada/prj-nmsc.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-pars.adb b/gcc/ada/prj-pars.adb deleted file mode 100644 index a37e13aec93..00000000000 --- a/gcc/ada/prj-pars.adb +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-pars.ads b/gcc/ada/prj-pars.ads deleted file mode 100644 index 23f3347d700..00000000000 --- a/gcc/ada/prj-pars.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-part.adb b/gcc/ada/prj-part.adb deleted file mode 100644 index 7afe8c0a3d0..00000000000 --- a/gcc/ada/prj-part.adb +++ /dev/null @@ -1,2213 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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$ extends is - - -- for Source_Dirs use (); - - -- end V$; - - -- 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; diff --git a/gcc/ada/prj-part.ads b/gcc/ada/prj-part.ads deleted file mode 100644 index 1bf1366fb5c..00000000000 --- a/gcc/ada/prj-part.ads +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb deleted file mode 100644 index 6da5ae2325d..00000000000 --- a/gcc/ada/prj-pp.adb +++ /dev/null @@ -1,1010 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-pp.ads b/gcc/ada/prj-pp.ads deleted file mode 100644 index 771b4c3f2d4..00000000000 --- a/gcc/ada/prj-pp.ads +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb deleted file mode 100644 index ec52c2340e2..00000000000 --- a/gcc/ada/prj-proc.adb +++ /dev/null @@ -1,3179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 'Name and - -- '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 - <> - 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; diff --git a/gcc/ada/prj-proc.ads b/gcc/ada/prj-proc.ads deleted file mode 100644 index face045b5f4..00000000000 --- a/gcc/ada/prj-proc.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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() when Runtime () is not declared. - -end Prj.Proc; diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb deleted file mode 100644 index eb7aaa3f4df..00000000000 --- a/gcc/ada/prj-strt.adb +++ /dev/null @@ -1,1597 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-strt.ads b/gcc/ada/prj-strt.ads deleted file mode 100644 index ab43346ef57..00000000000 --- a/gcc/ada/prj-strt.ads +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb deleted file mode 100644 index ea852d110c7..00000000000 --- a/gcc/ada/prj-tree.adb +++ /dev/null @@ -1,3261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads deleted file mode 100644 index f2290bb20ab..00000000000 --- a/gcc/ada/prj-tree.ads +++ /dev/null @@ -1,1563 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 " 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; diff --git a/gcc/ada/prj-util.adb b/gcc/ada/prj-util.adb deleted file mode 100644 index 3f3b358311e..00000000000 --- a/gcc/ada/prj-util.adb +++ /dev/null @@ -1,1432 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj-util.ads b/gcc/ada/prj-util.ads deleted file mode 100644 index 3cdd0c73aed..00000000000 --- a/gcc/ada/prj-util.ads +++ /dev/null @@ -1,269 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb deleted file mode 100644 index e14f63e7feb..00000000000 --- a/gcc/ada/prj.adb +++ /dev/null @@ -1,2177 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 (" "); - 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; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads deleted file mode 100644 index 8920890dcfc..00000000000 --- a/gcc/ada/prj.ads +++ /dev/null @@ -1,2135 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 /** 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 . - - 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; diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 7d0fe3babdb..82548bdf7fb 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1055,11 +1055,10 @@ package body Sem_Aux is 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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index fdf45db0a92..38180dd469c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5089,15 +5089,6 @@ package body Sem_Ch12 is 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); @@ -5407,6 +5398,16 @@ package body Sem_Ch12 is (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 @@ -5461,18 +5462,11 @@ package body Sem_Ch12 is 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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 958e733cf57..75348c7b267 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2650,12 +2650,12 @@ package body Sem_Ch3 is 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 diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 12ca7a0c291..7c33e381b5f 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -580,7 +580,26 @@ package body Sem_Ch5 is 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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 783ff1afa74..621de0315ec 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -7385,7 +7385,7 @@ package body Sem_Ch8 is -- 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)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 692975b5fd7..1cea29aa8a6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -1447,7 +1447,7 @@ package body Sem_Prag is -- 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; @@ -2443,7 +2443,7 @@ package body Sem_Prag is 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) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index eef4016ac7c..2d8751c459b 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6664,8 +6664,8 @@ package body Sem_Res is -- 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)) diff --git a/gcc/ada/sinput-p.adb b/gcc/ada/sinput-p.adb deleted file mode 100644 index d643d6466ec..00000000000 --- a/gcc/ada/sinput-p.adb +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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; diff --git a/gcc/ada/sinput-p.ads b/gcc/ada/sinput-p.ads deleted file mode 100644 index 112a6f7d5da..00000000000 --- a/gcc/ada/sinput-p.ads +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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;