diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 34 | ||||
| -rw-r--r-- | gcc/ada/a-cofove.adb | 161 | ||||
| -rw-r--r-- | gcc/ada/errutil.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/g-comlin.adb | 82 | ||||
| -rw-r--r-- | gcc/ada/g-comlin.ads | 23 | ||||
| -rw-r--r-- | gcc/ada/make.adb | 90 | ||||
| -rw-r--r-- | gcc/ada/makeutl.adb | 629 | ||||
| -rw-r--r-- | gcc/ada/makeutl.ads | 116 | ||||
| -rw-r--r-- | gcc/ada/prj.adb | 40 | ||||
| -rw-r--r-- | gcc/ada/prj.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 4 |
12 files changed, 894 insertions, 311 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b4f495c..f7498ab 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,39 @@ 2011-08-03 Yannick Moy <moy@adacore.com> + * 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 <dewar@adacore.com> + + * a-cofove.adb: Minor reformatting. + +2011-08-03 Emmanuel Briot <briot@adacore.com> + + * 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 <briot@adacore.com> + + * 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 <briot@adacore.com> + + * 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 <moy@adacore.com> + * sem_ch11.adb (Analyze_Raise_xxx_Error): do not mark such nodes as not in ALFA. Instead, they are considered as assertions to prove. * sem_ch4.adb (Analyze_Conditional_Expression): do not always mark such diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 86b827f..3533c2a 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 6a5bb69..cf6e9ef 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 1963520..51321b5 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 -- --- <http://www.gnu.org/licenses/>. -- +-- 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 abb4287..0544854 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 c8eabf1..684bccf 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 d63a545..e253d35 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 4ae63ca..52ee900 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 b98bb13..7640bcf 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 f936090..c57f372 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 1e49456..e04773a 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 95080c3..3286e3a 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; |