From fccd42a9a5dca36c6c126b0f9fa632e8dd5f30e7 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 3 Aug 2011 17:27:54 +0200 Subject: [PATCH] [multiple changes] 2011-08-03 Yannick Moy * sem_ch4.adb (Analyze_Conditional_Expression): only allow boolean conditional expression in ALFA. * sem_res.adb (Resolve_Conditional_Expression): mark non-boolean expressions as not in ALFA. 2011-08-03 Robert Dewar * a-cofove.adb: Minor reformatting. 2011-08-03 Emmanuel Briot * make.adb, prj.adb, prj.ads, makeutl.adb, makeutl.ads (Insert_Project_Sources, Insert_withed_Sources_For): moved from the gprbuild sources. These packages are more logically placed in the Queue package, since they manipulate the queue. It is also likely that they can be adapted for gnatmake, thus sharing more code. (Finish_Program, Fail_Program): moved from the gprbuild sources, so that we could move the above. 2011-08-03 Emmanuel Briot * errutil.adb (Finalize): clean up the list of error messages on exit. Calling this subprogram multiple times will no longer show duplicate error messages on stderr. 2011-08-03 Emmanuel Briot * g-comlin.adb, g-comlin.ads (Set_Command_Line): ignore the parameter Getopt_Switches when we have already define a command line configuration. From-SVN: r177286 --- gcc/ada/ChangeLog | 34 +++ gcc/ada/a-cofove.adb | 161 ++++------- gcc/ada/errutil.adb | 6 +- gcc/ada/g-comlin.adb | 82 ++++-- gcc/ada/g-comlin.ads | 23 +- gcc/ada/make.adb | 90 +------ gcc/ada/makeutl.adb | 629 ++++++++++++++++++++++++++++++++++++++----- gcc/ada/makeutl.ads | 116 ++++++-- gcc/ada/prj.adb | 40 ++- gcc/ada/prj.ads | 12 +- gcc/ada/sem_ch4.adb | 8 +- gcc/ada/sem_res.adb | 4 + 12 files changed, 894 insertions(+), 311 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b4f495c1427..f7498abff7c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2011-08-03 Yannick Moy + + * sem_ch4.adb (Analyze_Conditional_Expression): only allow boolean + conditional expression in ALFA. + * sem_res.adb (Resolve_Conditional_Expression): mark non-boolean + expressions as not in ALFA. + +2011-08-03 Robert Dewar + + * a-cofove.adb: Minor reformatting. + +2011-08-03 Emmanuel Briot + + * make.adb, prj.adb, prj.ads, makeutl.adb, makeutl.ads + (Insert_Project_Sources, Insert_withed_Sources_For): moved from the + gprbuild sources. + These packages are more logically placed in the Queue package, since + they manipulate the queue. It is also likely that they can be adapted + for gnatmake, thus sharing more code. + (Finish_Program, Fail_Program): moved from the gprbuild sources, so + that we could move the above. + +2011-08-03 Emmanuel Briot + + * errutil.adb (Finalize): clean up the list of error messages on exit. + Calling this subprogram multiple times will no longer show duplicate + error messages on stderr. + +2011-08-03 Emmanuel Briot + + * g-comlin.adb, g-comlin.ads (Set_Command_Line): ignore the parameter + Getopt_Switches when we have already define a command line + configuration. + 2011-08-03 Yannick Moy * sem_ch11.adb (Analyze_Raise_xxx_Error): do not mark such nodes as not diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 86b827f421d..3533c2a4096 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -44,8 +44,8 @@ package body Ada.Containers.Formal_Vectors is function "&" (Left, Right : Vector) return Vector is LN : constant Count_Type := Length (Left); RN : constant Count_Type := Length (Right); - begin + begin if LN = 0 then if RN = 0 then return Empty_Vector; @@ -53,22 +53,19 @@ package body Ada.Containers.Formal_Vectors is declare E : constant Elements_Array (1 .. Length (Right)) := - Right.Elements (1 .. RN); + Right.Elements (1 .. RN); begin - return (Length (Right), E, - Last => Right.Last, others => <>); + return (Length (Right), E, Last => Right.Last, others => <>); end; end if; if RN = 0 then declare E : constant Elements_Array (1 .. Length (Left)) := - Left.Elements (1 .. LN); + Left.Elements (1 .. LN); begin - return (Length (Left), E, - Last => Left.Last, others => <>); + return (Length (Left), E, Last => Left.Last, others => <>); end; - end if; declare @@ -91,16 +88,13 @@ package body Ada.Containers.Formal_Vectors is declare Last : constant Index_Type := Index_Type (Last_As_Int); - LE : constant Elements_Array (1 .. LN) := - Left.Elements (1 .. LN); - + LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); RE : Elements_Array renames Right.Elements (1 .. RN); Capacity : constant Count_Type := Length (Left) + Length (Right); begin - return (Capacity, LE & RE, - Last => Last, others => <>); + return (Capacity, LE & RE, Last => Last, others => <>); end; end; end "&"; @@ -111,8 +105,7 @@ package body Ada.Containers.Formal_Vectors is begin if LN = 0 then - return (1, (1 .. 1 => Right), - Index_Type'First, others => <>); + return (1, (1 .. 1 => Right), Index_Type'First, others => <>); end if; if Int (Index_Type'First) > Int'Last - Int (LN) then @@ -127,17 +120,13 @@ package body Ada.Containers.Formal_Vectors is declare Last : constant Index_Type := Index_Type (Last_As_Int); - - LE : constant Elements_Array (1 .. LN) := - Left.Elements (1 .. LN); + LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN); Capacity : constant Count_Type := Length (Left) + 1; begin - return (Capacity, LE & Right, - Last => Last, others => <>); + return (Capacity, LE & Right, Last => Last, others => <>); end; - end "&"; function "&" (Left : Element_Type; Right : Vector) return Vector is @@ -161,15 +150,11 @@ package body Ada.Containers.Formal_Vectors is end if; declare - Last : constant Index_Type := Index_Type (Last_As_Int); - - RE : Elements_Array renames Right.Elements (1 .. RN); - + Last : constant Index_Type := Index_Type (Last_As_Int); + RE : Elements_Array renames Right.Elements (1 .. RN); Capacity : constant Count_Type := 1 + Length (Right); - begin - return (Capacity, Left & RE, - Last => Last, others => <>); + return (Capacity, Left & RE, Last => Last, others => <>); end; end "&"; @@ -181,10 +166,8 @@ package body Ada.Containers.Formal_Vectors is declare Last : constant Index_Type := Index_Type'First + 1; - begin - return (2, (Left, Right), - Last => Last, others => <>); + return (2, (Left, Right), Last => Last, others => <>); end; end "&"; @@ -217,7 +200,6 @@ package body Ada.Containers.Formal_Vectors is procedure Append (Container : in out Vector; New_Item : Vector) is begin - if Is_Empty (New_Item) then return; end if; @@ -226,10 +208,7 @@ package body Ada.Containers.Formal_Vectors is raise Constraint_Error with "vector is already at its maximum length"; end if; - Insert - (Container, - Container.Last + 1, - New_Item); + Insert (Container, Container.Last + 1, New_Item); end Append; procedure Append @@ -238,7 +217,6 @@ package body Ada.Containers.Formal_Vectors is Count : Count_Type := 1) is begin - if Count = 0 then return; end if; @@ -249,11 +227,7 @@ package body Ada.Containers.Formal_Vectors is -- TODO: should check whether length > max capacity (cnt_t'last) ??? - Insert - (Container, - Container.Last + 1, - New_Item, - Count); + Insert (Container, Container.Last + 1, New_Item, Count); end Append; ------------ @@ -262,8 +236,8 @@ package body Ada.Containers.Formal_Vectors is procedure Assign (Target : in out Vector; Source : Vector) is LS : constant Count_Type := Length (Source); - begin + begin if Target'Address = Source'Address then return; end if; @@ -274,10 +248,8 @@ package body Ada.Containers.Formal_Vectors is Target.Clear; - Target.Elements (1 .. LS) := - Source.Elements (1 .. LS); - Target.Last := Source.Last; - + Target.Elements (1 .. LS) := Source.Elements (1 .. LS); + Target.Last := Source.Last; end Assign; -------------- @@ -295,7 +267,6 @@ package body Ada.Containers.Formal_Vectors is procedure Clear (Container : in out Vector) is begin - if Container.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -330,19 +301,15 @@ package body Ada.Containers.Formal_Vectors is begin if Capacity = 0 then C := LS; - elsif Capacity >= LS then C := Capacity; - else raise Constraint_Error; end if; - return Target : Vector (C) do - Target.Elements (1 .. LS) := - Source.Elements (1 .. LS); + return Target : Vector (C) do + Target.Elements (1 .. LS) := Source.Elements (1 .. LS); Target.Last := Source.Last; - end return; end Copy; @@ -356,7 +323,6 @@ package body Ada.Containers.Formal_Vectors is Count : Count_Type := 1) is begin - if Index < Index_Type'First then raise Constraint_Error with "Index is out of range (too small)"; end if; @@ -380,8 +346,7 @@ package body Ada.Containers.Formal_Vectors is declare I_As_Int : constant Int := Int (Index); - Old_Last_As_Int : constant Int := - Index_Type'Pos (Container.Last); + Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); Count1 : constant Int'Base := Count_Type'Pos (Count); Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; @@ -424,7 +389,6 @@ package body Ada.Containers.Formal_Vectors is Count : Count_Type := 1) is begin - if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; @@ -446,7 +410,6 @@ package body Ada.Containers.Formal_Vectors is Count : Count_Type := 1) is begin - if Count = 0 then return; end if; @@ -470,7 +433,6 @@ package body Ada.Containers.Formal_Vectors is Index : Int'Base; begin - if Count = 0 then return; end if; @@ -505,9 +467,7 @@ package body Ada.Containers.Formal_Vectors is declare II : constant Int'Base := Int (Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); - begin - return Get_Element (Container, I); end; end Element; @@ -517,6 +477,7 @@ package body Ada.Containers.Formal_Vectors is Position : Cursor) return Element_Type is Lst : constant Index_Type := Last_Index (Container); + begin if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; @@ -529,9 +490,7 @@ package body Ada.Containers.Formal_Vectors is declare II : constant Int'Base := Int (Position.Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); - begin - return Get_Element (Container, I); end; end Element; @@ -549,7 +508,6 @@ package body Ada.Containers.Formal_Vectors is Last : constant Index_Type := Last_Index (Container); begin - if Position.Valid then if Position.Index > Last_Index (Container) then raise Program_Error with "Position index is out of range"; @@ -562,11 +520,11 @@ package body Ada.Containers.Formal_Vectors is if Get_Element (Container, K) = Item then return Cursor'(Index => J, others => <>); end if; + K := K + 1; end loop; return No_Element; - end Find; ---------------- @@ -588,6 +546,7 @@ package body Ada.Containers.Formal_Vectors is if Get_Element (Container, K) = Item then return Indx; end if; + K := K + 1; end loop; @@ -642,8 +601,8 @@ package body Ada.Containers.Formal_Vectors is function Is_Sorted (Container : Vector) return Boolean is Last : constant Index_Type := Last_Index (Container); - begin + begin if Container.Last <= Last then return True; end if; @@ -651,10 +610,10 @@ package body Ada.Containers.Formal_Vectors is declare L : constant Capacity_Subtype := Length (Container); begin - for J in Count_Type range 1 .. L - 1 loop - if Get_Element (Container, J + 1) - < Get_Element (Container, J) then + if Get_Element (Container, J + 1) < + Get_Element (Container, J) + then return False; end if; end loop; @@ -692,6 +651,7 @@ package body Ada.Containers.Formal_Vectors is end if; -- I think we're missing this check in a-convec.adb... ??? + if Target.Busy > 0 then raise Program_Error with "attempt to tamper with elements (vector is busy)"; @@ -717,8 +677,7 @@ package body Ada.Containers.Formal_Vectors is return; end if; - pragma Assert (I <= 1 - or else not (TA (I) < TA (I - 1))); + pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1))); if SA (Length (Source)) < TA (I) then TA (J) := TA (I); @@ -746,8 +705,8 @@ package body Ada.Containers.Formal_Vectors is Element_Type => Element_Type, Array_Type => Elements_Array, "<" => "<"); - begin + begin if Container.Last <= Index_Type'First then return; end if; @@ -768,11 +727,10 @@ package body Ada.Containers.Formal_Vectors is function Get_Element (Container : Vector; - Position : Count_Type) return Element_Type is + Position : Count_Type) return Element_Type + is begin - return Container.Elements (Position); - end Get_Element; ----------------- @@ -781,13 +739,14 @@ package body Ada.Containers.Formal_Vectors is function Has_Element (Container : Vector; - Position : Cursor) return Boolean is + Position : Cursor) return Boolean + is begin if not Position.Valid then return False; + else + return Position.Index <= Last_Index (Container); end if; - - return Position.Index <= Last_Index (Container); end Has_Element; ------------ @@ -809,7 +768,6 @@ package body Ada.Containers.Formal_Vectors is Max_Length : constant UInt := UInt (Container.Capacity); begin - if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; @@ -870,7 +828,6 @@ package body Ada.Containers.Formal_Vectors is declare II : constant Int'Base := BB + N; I : constant Count_Type := Count_Type (II); - begin EA (I .. L) := EA (B .. Length (Container)); EA (B .. I - 1) := (others => New_Item); @@ -892,7 +849,6 @@ package body Ada.Containers.Formal_Vectors is N : constant Count_Type := Length (New_Item); begin - if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; @@ -921,11 +877,8 @@ package body Ada.Containers.Formal_Vectors is B : constant Count_Type := Count_Type (BB); begin - if Container'Address /= New_Item'Address then - Container.Elements (B .. Dst_Last) := - New_Item.Elements (1 .. N); - + Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N); return; end if; @@ -948,8 +901,7 @@ package body Ada.Containers.Formal_Vectors is declare Src : Elements_Array renames - Container.Elements - (Dst_Last + 1 .. Length (Container)); + Container.Elements (Dst_Last + 1 .. Length (Container)); Index_As_Int : constant Int'Base := Dst_Last_As_Int - Src'Length + 1; @@ -973,7 +925,6 @@ package body Ada.Containers.Formal_Vectors is Index : Index_Type'Base; begin - if Is_Empty (New_Item) then return; end if; @@ -1004,7 +955,6 @@ package body Ada.Containers.Formal_Vectors is Index : Index_Type'Base; begin - if Is_Empty (New_Item) then if not Before.Valid or else Before.Index > Container.Last @@ -1045,7 +995,6 @@ package body Ada.Containers.Formal_Vectors is Index : Index_Type'Base; begin - if Count = 0 then return; end if; @@ -1077,7 +1026,6 @@ package body Ada.Containers.Formal_Vectors is Index : Index_Type'Base; begin - if Count = 0 then if not Before.Valid or else Before.Index > Container.Last @@ -1129,7 +1077,6 @@ package body Ada.Containers.Formal_Vectors is is New_Item : Element_Type; -- Default-initialized value pragma Warnings (Off, New_Item); - begin Insert (Container, Before, New_Item, Position, Count); end Insert; @@ -1152,7 +1099,6 @@ package body Ada.Containers.Formal_Vectors is Max_Length : constant UInt := UInt (Count_Type'Last); begin - if Before < Index_Type'First then raise Constraint_Error with "Before index is out of range (too small)"; @@ -1213,7 +1159,6 @@ package body Ada.Containers.Formal_Vectors is declare II : constant Int'Base := BB + N; I : constant Count_Type := Count_Type (II); - begin EA (I .. L) := EA (B .. Length (Container)); end; @@ -1232,7 +1177,6 @@ package body Ada.Containers.Formal_Vectors is Index : Index_Type'Base; begin - if Count = 0 then if not Before.Valid or else Before.Index > Container.Last @@ -1354,12 +1298,13 @@ package body Ada.Containers.Formal_Vectors is ---------- function Left (Container : Vector; Position : Cursor) return Vector is - C : Vector (Container.Capacity) := - Copy (Container, Container.Capacity); + C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); + begin if Position = No_Element then return C; end if; + if not Has_Element (Container, Position) then raise Constraint_Error; end if; @@ -1640,7 +1585,6 @@ package body Ada.Containers.Formal_Vectors is declare II : constant Int'Base := Int (Position.Index) - Int (No_Index); I : constant Count_Type := Count_Type (II); - begin Container.Elements (I) := New_Item; end; @@ -1655,7 +1599,6 @@ package body Ada.Containers.Formal_Vectors is Capacity : Capacity_Subtype) is begin - if Capacity > Container.Capacity then raise Constraint_Error; -- ??? end if; @@ -1667,7 +1610,6 @@ package body Ada.Containers.Formal_Vectors is procedure Reverse_Elements (Container : in out Vector) is begin - if Length (Container) <= 1 then return; end if; @@ -1687,7 +1629,6 @@ package body Ada.Containers.Formal_Vectors is while I < J loop declare EI : constant Element_Type := E (I); - begin E (I) := E (J); E (J) := EI; @@ -1712,7 +1653,6 @@ package body Ada.Containers.Formal_Vectors is K : Count_Type; begin - if not Position.Valid or else Position.Index > Last_Index (Container) then @@ -1726,6 +1666,7 @@ package body Ada.Containers.Formal_Vectors is if Get_Element (Container, K) = Item then return (True, Indx); end if; + K := K - 1; end loop; @@ -1756,6 +1697,7 @@ package body Ada.Containers.Formal_Vectors is if Get_Element (Container, K) = Item then return Indx; end if; + K := K - 1; end loop; @@ -1768,8 +1710,8 @@ package body Ada.Containers.Formal_Vectors is procedure Reverse_Iterate (Container : Vector; - Process : - not null access procedure (Container : Vector; Position : Cursor)) + Process : not null access procedure (Container : Vector; + Position : Cursor)) is V : Vector renames Container'Unrestricted_Access.all; B : Natural renames V.Busy; @@ -1795,13 +1737,14 @@ package body Ada.Containers.Formal_Vectors is ----------- function Right (Container : Vector; Position : Cursor) return Vector is - C : Vector (Container.Capacity) := - Copy (Container, Container.Capacity); + C : Vector (Container.Capacity) := Copy (Container, Container.Capacity); + begin if Position = No_Element then Clear (C); return C; end if; + if not Has_Element (Container, Position) then raise Constraint_Error; end if; @@ -1809,6 +1752,7 @@ package body Ada.Containers.Formal_Vectors is while C.Last /= Container.Last - Position.Index + 1 loop Delete_First (C); end loop; + return C; end Right; @@ -1821,7 +1765,6 @@ package body Ada.Containers.Formal_Vectors is Length : Capacity_Subtype) is begin - if Length = Formal_Vectors.Length (Container) then return; end if; @@ -1849,7 +1792,6 @@ package body Ada.Containers.Formal_Vectors is procedure Swap (Container : in out Vector; I, J : Index_Type) is begin - if I > Container.Last then raise Constraint_Error with "I index is out of range"; end if; @@ -1884,7 +1826,6 @@ package body Ada.Containers.Formal_Vectors is procedure Swap (Container : in out Vector; I, J : Cursor) is begin - if not I.Valid then raise Constraint_Error with "I cursor has no element"; end if; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 6a5bb692d6d..cf6e9ef2b3d 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-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- -- @@ -571,6 +571,10 @@ package body Errutil is Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; Warnings_Detected := 0; end if; + + -- Prevent displaying the same messages again in the future + + First_Error_Msg := No_Error_Msg; end Finalize; ---------------- diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index 1963520cf79..51321b56694 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -19,10 +19,10 @@ -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -200,7 +200,8 @@ package body GNAT.Command_Line is (Config : Command_Line_Configuration; Section : String); -- Iterate over all switches defined in Config, for a specific section. - -- Index is set to the index in Config.Switches + -- Index is set to the index in Config.Switches. + -- Stop iterating when Callback returns False. -------------- -- Argument -- @@ -1238,6 +1239,10 @@ package body GNAT.Command_Line is Unchecked_Free (Tmp); end if; + if Switch.Switch /= null and then Switch.Switch.all = "*" then + Config.Star_Switch := True; + end if; + Config.Switches (Config.Switches'Last) := Switch; end Add; @@ -1592,9 +1597,28 @@ package body GNAT.Command_Line is loop begin - S := Getopt (Switches => "* " & Getopt_Description, - Concatenate => False, - Parser => Parser); + if Cmd.Config /= null then + -- Do not use Getopt_Description in this case. Otherwise, + -- if we have defined a prefix -gnaty, and two switches + -- -gnatya and -gnatyL!, we would have a different behavior + -- depending on the order of switches: + -- -gnatyL1a => -gnatyL with argument "1a" + -- -gnatyaL1 => -gnatya and -gnatyL with argument "1" + -- This is because the call to Getopt below knows nothing + -- about prefixes, and in the first case finds a valid + -- switch with arguments, so returns it without analyzing + -- the argument. In the second case, the switch matches "*", + -- and is then decomposed below. + + S := Getopt (Switches => "*", + Concatenate => False, + Parser => Parser); + else + S := Getopt (Switches => "* " & Getopt_Description, + Concatenate => False, + Parser => Parser); + end if; + exit when S = ASCII.NUL; declare @@ -1761,6 +1785,8 @@ package body GNAT.Command_Line is function Analyze_Simple_Switch (Switch : String; Index : Integer) return Boolean; + -- "Switches" is one of the switch definitions passed to the + -- configuration, not one of the switches found on the command line. --------------------------- -- Analyze_Simple_Switch -- @@ -1772,26 +1798,26 @@ package body GNAT.Command_Line is pragma Unreferenced (Index); Full : constant String := Prefix & Group (Idx .. Group'Last); + Sw : constant String := Actual_Switch (Switch); + -- Switches definition minus argument definition + Last : Natural; Param : Natural; begin - if Sw'Length >= Prefix'Length - - -- Verify that sw starts with Prefix - - and then Looking_At (Sw, Sw'First, Prefix) - - -- Verify that the group starts with sw + if + -- Verify that sw starts with Prefix + Looking_At (Sw, Sw'First, Prefix) + -- Verify that the group starts with sw and then Looking_At (Full, Full'First, Sw) + then Last := Idx + Sw'Length - Prefix'Length - 1; Param := Last + 1; if Can_Have_Parameter (Switch) then - -- Include potential parameter to the recursive call. -- Only numbers are allowed. @@ -1989,8 +2015,10 @@ package body GNAT.Command_Line is -- First determine if the switch corresponds to one belonging to the -- configuration. If so, run callback and exit. - Foreach_In_Config (Config, Section); + -- ??? Is this necessary. On simple tests, we seem to have the same + -- results with or without this call. + Foreach_In_Config (Config, Section); if Found_In_Config then return; end if; @@ -2127,10 +2155,17 @@ package body GNAT.Command_Line is Param : String; Index : Integer) is - pragma Unreferenced (Index); Sep : Character; begin + if Index = -1 + and then Cmd.Config /= null + and then not Cmd.Config.Star_Switch + then + raise Invalid_Switch + with "Invalid switch " & Simple; + end if; + if Separator = "" then Sep := ASCII.NUL; else @@ -2808,13 +2843,8 @@ package body GNAT.Command_Line is if Iter.List = null then Iter.Current := Integer'Last; else - Iter.Current := Iter.List'First; - - while Iter.Current <= Iter.List'Last - and then Iter.List (Iter.Current) = null - loop - Iter.Current := Iter.Current + 1; - end loop; + Iter.Current := Iter.List'First - 1; + Next (Iter); end if; end Start; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads index abb4287474d..0544854d52e 100644 --- a/gcc/ada/g-comlin.ads +++ b/gcc/ada/g-comlin.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2010, AdaCore -- +-- Copyright (C) 1999-2011, 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- -- @@ -583,6 +583,10 @@ package GNAT.Command_Line is -- assumed that the remainder of the switch ("uv") is a set of characters -- whose order is irrelevant. In fact, this package will sort them -- alphabetically. + -- When grouping switches that accept arguments (for instance "-gnatyL!" + -- as the definition, and "-gnatyaL12b" as the command line), only + -- numerical arguments are accepted. The above is equivalent to + -- "-gnatya -gnatyL12 -gnatyb". procedure Define_Switch (Config : in out Command_Line_Configuration; @@ -768,7 +772,9 @@ package GNAT.Command_Line is Config : Command_Line_Configuration); function Get_Configuration (Cmd : Command_Line) return Command_Line_Configuration; - -- Set or retrieve the configuration used for that command line + -- Set or retrieve the configuration used for that command line. + -- The Config must have been initialized first, by calling one of the + -- Define_Switches subprograms. procedure Set_Command_Line (Cmd : in out Command_Line; @@ -781,6 +787,8 @@ package GNAT.Command_Line is -- The parsing of Switches is done through calls to Getopt, by passing -- Getopt_Description as an argument. (A "*" is automatically prepended so -- that all switches and command line arguments are accepted). + -- If a config was defined via Set_Configuration, the Getopt_Description + -- parameter will be ignored. -- -- To properly handle switches that take parameters, you should document -- them in Getopt_Description. Otherwise, the switch and its parameter will @@ -792,6 +800,12 @@ package GNAT.Command_Line is -- should be listed in the Sections parameter (as "-bargs -cargs"). -- -- This function can be used to reset Cmd by passing an empty string. + -- + -- If an invalid switch is found on the command line (ie wasn't defined in + -- the configuration via Define_Switch), and the configuration wasn't set + -- to accept all switches (by defining "*" as a valid switch), then an + -- exception Invalid_Switch is raised. The exception message indicates the + -- invalid switch. procedure Add_Switch (Cmd : in out Command_Line; @@ -1084,6 +1098,11 @@ private Sections : GNAT.OS_Lib.Argument_List_Access; -- The list of sections + Star_Switch : Boolean := False; + -- Whether switches not described in this configuration should be + -- returned to the user (True). If False, an exception Invalid_Switch + -- is raised. + Aliases : Alias_Definitions_List; Usage : GNAT.OS_Lib.String_Access; Help : GNAT.OS_Lib.String_Access; diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index c8eabf1f932..684bccfd936 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -411,6 +411,8 @@ package body Make is -- Delete all temp files created by Gnatmake and call Osint.Fail, with the -- parameter S (see osint.ads). This is called from the Prj hierarchy and -- the MLib hierarchy. + -- This subprogram also prints current error messages on stdout (ie + -- finalizes errout) -------------------------- -- Obsolete Executables -- @@ -795,15 +797,6 @@ package body Make is -- mappings, when using project file(s). The out parameter File_Index is -- the index to the name of the file in the array The_Mapping_File_Names. - procedure Delete_Temp_Config_Files; - -- Delete all temporary config files. Must not be called if Debug_Flag_N - -- is False. - - procedure Delete_All_Temp_Files; - -- Delete all temp files (config files, mapping files, path files), unless - -- Debug_Flag_N is True (in which case all temp files are left for user - -- examination). - ------------------------------------------------- -- Subprogram declarations moved from the spec -- ------------------------------------------------- @@ -1267,7 +1260,6 @@ package body Make is """ is not a gnatmake switch. Consider moving " & "it to Global_Compilation_Switches.", Element.Location); - Errutil.Finalize; Make_Failed ("*** illegal switch """ & Argv & """"); end if; end; @@ -3719,7 +3711,7 @@ package body Make is -- Delete any temporary configuration pragma file if not Debug.Debug_Flag_N then - Delete_Temp_Config_Files; + Delete_Temp_Config_Files (Project_Tree); end if; end Compile_Sources; @@ -3911,53 +3903,6 @@ package body Make is Debug_Msg (S, Name_Id (N)); end Debug_Msg; - --------------------------- - -- Delete_All_Temp_Files -- - --------------------------- - - procedure Delete_All_Temp_Files is - begin - if not Debug.Debug_Flag_N then - Delete_Temp_Config_Files; - Prj.Delete_All_Temp_Files (Project_Tree.Shared); - end if; - end Delete_All_Temp_Files; - - ------------------------------ - -- Delete_Temp_Config_Files -- - ------------------------------ - - procedure Delete_Temp_Config_Files is - Success : Boolean; - Proj : Project_List; - pragma Warnings (Off, Success); - - begin - -- The caller is responsible for ensuring that Debug_Flag_N is False - - pragma Assert (not Debug.Debug_Flag_N); - - if Main_Project /= No_Project 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 Delete_Temp_Config_Files; - ------------- -- Display -- ------------- @@ -4470,8 +4415,7 @@ package body Make is Write_Line (": no sources to compile"); end if; - Delete_All_Temp_Files; - Exit_Program (E_Success); + Finish_Program (Project_Tree, E_Success); end if; end if; @@ -4619,8 +4563,7 @@ package body Make is Bind => Bind_Only, Link => Link_Only); - Delete_All_Temp_Files; - Exit_Program (E_Success); + Finish_Program (Project_Tree, E_Success); else -- Call Get_Target_Parameters to ensure that VM_Target and @@ -4631,7 +4574,7 @@ package body Make is -- Output usage information if no files to compile Usage; - Exit_Program (E_Fatal); + Finish_Program (Project_Tree, E_Success); end if; end if; @@ -4809,7 +4752,6 @@ package body Make is "Global_Compilation_Switches. Use Switches instead.", Project_Tree.Shared.Arrays.Table (Default_Switches_Array).Location); - Errutil.Finalize; Make_Failed ("*** illegal combination of Builder attributes"); end if; @@ -6505,14 +6447,7 @@ package body Make is Report_Compilation_Failed; end if; - -- Delete the temporary mapping file that was created if we are - -- using project files. - - Delete_All_Temp_Files; - - -- Output Namet statistics - - Namet.Finalize; + Finish_Program (Project_Tree, E_Success); exception when X : others => @@ -7292,8 +7227,7 @@ package body Make is procedure Make_Failed (S : String) is begin - Delete_All_Temp_Files; - Osint.Fail (S); + Fail_Program (Project_Tree, S); end Make_Failed; -------------------- @@ -7531,8 +7465,7 @@ package body Make is procedure Report_Compilation_Failed is begin - Delete_All_Temp_Files; - Exit_Program (E_Fatal); + Fail_Program (Project_Tree, ""); end Report_Compilation_Failed; ------------------------ @@ -7552,10 +7485,7 @@ package body Make is Kill (Running_Compile (J).Pid, SIGINT, 1); end loop; - Delete_All_Temp_Files; - OS_Exit (1); - -- ??? OS_Exit (1) is equivalent to Exit_Program (E_No_Compile), - -- shouldn't that be Exit_Program (E_Abort) instead? + Finish_Program (Project_Tree, E_No_Compile); end Sigint_Intercepted; ------------------- diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index d63a5452dab..e253d35eee1 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -25,6 +25,8 @@ with ALI; use ALI; with Debug; +with Err_Vars; use Err_Vars; +with Errutil; with Fname; with Hostparm; with Osint; use Osint; @@ -32,6 +34,7 @@ with Output; use Output; with Opt; use Opt; with Prj.Ext; with Prj.Util; +with Sinput.P; with Snames; use Snames; with Table; with Tempdir; @@ -580,6 +583,58 @@ package body Makeutl is 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 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 + Osint.Fail (S); + else + Write_Str (S); + end if; + end if; + + -- Output Namet statistics + + Namet.Finalize; + + Exit_Program (Exit_Code); + end Finish_Program; + -------------------------- -- File_Not_A_Source_Of -- -------------------------- @@ -819,6 +874,169 @@ package body Makeutl is 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 + 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; + + Obj_Proj := Obj_Proj.Extended_By; + end; + 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 -- ---------------------------- @@ -851,6 +1069,36 @@ package body Makeutl is 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 -- ----------------------------- @@ -963,14 +1211,8 @@ package body Makeutl is package body Mains is - type File_And_Loc is record - File_Name : File_Name_Type; - Index : Int := 0; - Location : Source_Ptr := No_Location; - end record; - package Names is new Table.Table - (Table_Component_Type => File_And_Loc, + (Table_Component_Type => Main_Info, Table_Index_Type => Integer, Table_Low_Bound => 1, Table_Initial => 10, @@ -985,14 +1227,46 @@ package body Makeutl is -- Add_Main -- -------------- - procedure Add_Main (Name : String) is + procedure Add_Main + (Name : String; + Index : Int := 0; + Location : Source_Ptr := No_Location) + is begin 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, 0, No_Location); + Names.Table (Names.Last) := (Name_Find, Index, Location, No_Source); end Add_Main; + -------------------------- + -- 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; + ------------ -- Delete -- ------------ @@ -1003,43 +1277,167 @@ package body Makeutl is Mains.Reset; end Delete; - --------------- - -- Get_Index -- - --------------- + ----------------------- + -- FIll_From_Project -- + ----------------------- - function Get_Index return Int is + procedure Fill_From_Project + (Root_Project : Project_Id; + Project_Tree : Project_Tree_Ref) is begin - if Current in Names.First .. Names.Last then - return Names.Table (Current).Index; - else - return 0; + if Number_Of_Mains = 0 then + declare + List : String_List_Id := Root_Project.Mains; + Element : String_Element; + + begin + 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 := + Project_Tree.Shared.String_Elements.Table (List); + + Add_Main (Name => Get_Name_String (Element.Value), + Index => Element.Index, + Location => Element.Location); + List := Element.Next; + end loop; + end if; + end; end if; - end Get_Index; - ------------------ - -- Get_Location -- - ------------------ + -- If there are mains, check that they are sources of the main + -- project + + if Mains.Number_Of_Mains > 0 then + for J in Names.First .. Names.Last loop + declare + File : constant Main_Info := Names.Table (J); + Main_Id : File_Name_Type := File.File; + Main : constant String := Get_Name_String (Main_Id); + Project : Project_Id; + Source : Prj.Source_Id := No_Source; + Suffix : File_Name_Type; + Iter : Source_Iterator; + + begin + if Base_Name (Main) /= Main then + if Is_Absolute_Path (Main) then + Main_Id := Create_Name (Base_Name (Main)); - function Get_Location return Source_Ptr is + else + Fail_Program + (Project_Tree, + "mains cannot include directory information (""" & + Main & """)"); + end if; + end if; + + -- First, look for the main as specified. + + Source := Find_Source + (In_Tree => Project_Tree, + Project => Project, + Base_Name => File.File, + Index => File.Index); + + if Source = No_Source then + -- Now look for the main with a body suffix + + declare + -- Main already has a canonical casing + Main : constant String := Get_Name_String (Main_Id); + begin + Project := Root_Project; + while Source = No_Source + and then Project /= No_Project + loop + Iter := For_Each_Source (Project_Tree, Project); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + -- Only consider bodies + + if Source.Kind = Impl then + Get_Name_String (Source.File); + + if Name_Len > Main'Length + and then + Name_Buffer (1 .. Main'Length) = Main + then + Suffix := + Source.Language + .Config.Naming_Data.Body_Suffix; + + exit when Suffix /= No_File and then + Name_Buffer (Main'Length + 1 .. Name_Len) + = Get_Name_String (Suffix); + end if; + end if; + + Next (Iter); + end loop; + + Project := Project.Extends; + end loop; + end; + end if; + + if Source /= No_Source then + Names.Table (J).File := Source.File; + Names.Table (J).Source := Source; + + 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 := Root_Project.Name; + Errutil.Error_Msg ("{ is not a source of project %%", + File.Location); + end if; + end; + end loop; + end if; + + if Total_Errors_Detected > 0 then + Fail_Program (Project_Tree, "problems with main sources"); + end if; + end Fill_From_Project; + + --------------- + -- Next_Main -- + --------------- + + function Next_Main return String is + Info : Main_Info; begin - if Current in Names.First .. Names.Last then - return Names.Table (Current).Location; + Info := Next_Main; + if Info = No_Main_Info then + return ""; else - return No_Location; + return Get_Name_String (Info.File); end if; - end Get_Location; + end Next_Main; --------------- -- Next_Main -- --------------- - function Next_Main return String is + function Next_Main return Main_Info is begin if Current >= Names.Last then - return ""; + return No_Main_Info; else Current := Current + 1; - return Get_Name_String (Names.Table (Current).File_Name); + return Names.Table (Current); end if; end Next_Main; @@ -1060,41 +1458,6 @@ package body Makeutl is begin Current := 0; end Reset; - - --------------- - -- Set_Index -- - --------------- - - procedure Set_Index (Index : Int) is - begin - if Names.Last > 0 then - Names.Table (Names.Last).Index := Index; - end if; - end Set_Index; - - ------------------ - -- Set_Location -- - ------------------ - - procedure Set_Location (Location : Source_Ptr) is - begin - if Names.Last > 0 then - Names.Table (Names.Last).Location := Location; - end if; - end Set_Location; - - ----------------- - -- Update_Main -- - ----------------- - - procedure Update_Main (Name : String) is - begin - if Current in Names.First .. Names.Last then - Name_Len := 0; - Add_Str_To_Name_Buffer (Name); - Names.Table (Current).File_Name := Name_Find; - end if; - end Update_Main; end Mains; ----------------------- @@ -1727,6 +2090,144 @@ package body Makeutl is Marks.Reset; end Remove_Marks; + ---------------------------- + -- Insert_Project_Sources -- + ---------------------------- + + procedure Insert_Project_Sources + (Project : Project_Id; + Project_Tree : Project_Tree_Ref; + All_Projects : Boolean; + Unit_Based : Boolean) + is + Iter : Source_Iterator; + Source : Prj.Source_Id; + begin + Iter := For_Each_Source (Project_Tree); + loop + Source := Prj.Element (Iter); + exit when Source = No_Source; + + if 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) + and then not Is_Subunit (Source) + then + Queue.Insert + (Source => (Format => Format_Gprbuild, + Id => Source)); + end if; + end if; + end if; + + Next (Iter); + end loop; + 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 + not Src_Id.Project.Standalone_Library or else + Src_Id.Project.Library_Kind = Static) + then + Queue.Insert + (Source => (Format => Format_Gprbuild, + Id => Src_Id)); + end if; + end if; + end loop; + end loop; + end Insert_Withed_Sources_For; + end Queue; end Makeutl; diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 4ae63cabb33..52ee9001a6f 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -30,7 +30,8 @@ with ALI; with Namet; use Namet; with Opt; -with Prj; use Prj; +with Osint; +with Prj; use Prj; with Prj.Tree; with Types; use Types; @@ -111,6 +112,13 @@ package Makeutl is -- source files are still associated with the same units). Return True -- if everything is still valid. + 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, the object and + -- dependency file, as well as their timestamps. This includes timestamps. + function Is_External_Assignment (Env : Prj.Tree.Environment; Argv : String) return Boolean; @@ -204,6 +212,24 @@ package Makeutl is function Path_Or_File_Name (Path : Path_Name_Type) return String; -- Returns a file name if -df is used, otherwise return a path name + ------------------------- + -- 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 + ----------- -- Mains -- ----------- @@ -215,38 +241,62 @@ package Makeutl is -- Mains are stored in a table. An index is used to retrieve the mains -- from the table. - package Mains is - - procedure Add_Main (Name : String); - -- Add one main to 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; + end record; + No_Main_Info : constant Main_Info := (No_File, 0, No_Location, No_Source); - procedure Set_Index (Index : Int); - - procedure Set_Location (Location : Source_Ptr); - -- Set the location of the last main added. By default, the location is - -- No_Location. + package Mains is + procedure Add_Main + (Name : String; + Index : Int := 0; + Location : Source_Ptr := No_Location); + -- 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 + -- within the source is concerned. + -- Location is the location within the project file (if a project file + -- is used). procedure Delete; -- Empty the table procedure Reset; - -- Reset the index to the beginning of the table - - function Next_Main return String; - -- Increase the index and return the next main. If table is exhausted, - -- return an empty string. + -- Reset the cursor to the beginning of the table - function Get_Index return Int; + 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 not 0. + -- This subprogram is used for the handling of the command line switch. - function Get_Location return Source_Ptr; - -- Get the location of the current main - - procedure Update_Main (Name : String); - -- Update the file name of the current main + function Next_Main return String; + function Next_Main return Main_Info; + -- Moves the cursor forward and returns the new current entry. + -- Returns No_File_And_Loc if there are no more mains in the table. function Number_Of_Mains return Natural; - -- Returns the number of mains added with Add_Main since the last call - -- to Delete. + -- Returns the number of mains in the table. + + 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). + -- + -- 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 + -- full paths rather than (partial) base names (e.g. no body suffix was + -- specified). end Mains; @@ -308,6 +358,26 @@ package Makeutl is -- The second version returns False if the Source was already marked in -- the queue. + procedure Insert_Project_Sources + (Project : Project_Id; + Project_Tree : Project_Tree_Ref; + All_Projects : Boolean; + Unit_Based : 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. + -- When Unit_Based is True, put in the queue 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. + + 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); diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index b98bb130959..7640bcfcdbb 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -144,6 +144,39 @@ package body Prj is end if; end Delete_Temporary_File; + ------------------------------ + -- Delete_Temp_Config_Files -- + ------------------------------ + + procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is + Success : Boolean; + Proj : Project_List; + pragma Warnings (Off, Success); + + begin + if not Debug.Debug_Flag_N 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 -- --------------------------- @@ -493,7 +526,8 @@ package body Prj is Project : Project_Id; In_Imported_Only : Boolean := False; In_Extended_Only : Boolean := False; - Base_Name : File_Name_Type) return Source_Id + Base_Name : File_Name_Type; + Index : Int := 0) return Source_Id is Result : Source_Id := No_Source; @@ -517,7 +551,9 @@ package body Prj is begin Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); while Element (Iterator) /= No_Source loop - if Element (Iterator).File = Base_Name then + if Element (Iterator).File = Base_Name + and then (Index = 0 or else Element (Iterator).Index = Index) + then Src := Element (Iterator); return; end if; diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads index f9360902ede..c57f37246e4 100644 --- a/gcc/ada/prj.ads +++ b/gcc/ada/prj.ads @@ -1380,11 +1380,13 @@ package Prj is Project : Project_Id; In_Imported_Only : Boolean := False; In_Extended_Only : Boolean := False; - Base_Name : File_Name_Type) return Source_Id; + Base_Name : File_Name_Type; + Index : Int := 0) return Source_Id; -- Find the first source file with the given name either in the whole tree -- (if In_Imported_Only is False) or in the projects imported or extended -- by Project otherwise. In_Extended_Only implies In_Imported_Only, and - -- will only look in Project and the projects it extends + -- will only look in Project and the projects it extends. + -- If Index is specified, this only search for a source with that index. ----------------------- -- Project_Tree_Data -- @@ -1647,6 +1649,12 @@ package Prj is -- 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); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 1e4945646ae..e04773a1a44 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1524,15 +1524,21 @@ package body Sem_Ch4 is Else_Expr := Next (Then_Expr); - -- In ALFA, conditional expressions are allowed: + -- In ALFA, boolean conditional expressions are allowed: -- * if they have no ELSE part, in which case the expression is -- equivalent to + -- NOT Condition OR ELSE Then_Expr + -- * in pre- and postconditions, where the Condition cannot have side- -- effects (in ALFA) and thus the expression is equivalent to + -- (Condition AND THEN Then_Expr) -- and (NOT Condition AND THEN Then_Expr) + -- Non-boolean conditional expressions are marked as not in ALFA during + -- resolution. + if Present (Else_Expr) and then not In_Pre_Post_Expression then Mark_Non_ALFA_Subprogram; end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 95080c3f947..3286e3aa57c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5860,6 +5860,10 @@ package body Sem_Res is Append_To (Expressions (N), Error); end if; + if Root_Type (Typ) /= Standard_Boolean then + Mark_Non_ALFA_Subprogram; + end if; + Set_Etype (N, Typ); Eval_Conditional_Expression (N); end Resolve_Conditional_Expression; -- 2.30.2