Skip to content

R
riscv-gcc-1
Commit fccd42a9 by Arnaud Charlet
Options

[multiple changes] 

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.

From-SVN: r177286
parent 5e8c8e44
Showing with 894 additions and 311 deletions
gcc/ada/ChangeLog
2011-08-03 Yannick Moy <moy@adacore.com> 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 * sem_ch11.adb (Analyze_Raise_xxx_Error): do not mark such nodes as not
in ALFA. Instead, they are considered as assertions to prove. in ALFA. Instead, they are considered as assertions to prove.
* sem_ch4.adb (Analyze_Conditional_Expression): do not always mark such * sem_ch4.adb (Analyze_Conditional_Expression): do not always mark such
......
gcc/ada/a-cofove.adb
...@@ -44,8 +44,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -44,8 +44,8 @@ package body Ada.Containers.Formal_Vectors is
function "&" (Left, Right : Vector) return Vector is function "&" (Left, Right : Vector) return Vector is
LN : constant Count_Type := Length (Left); LN : constant Count_Type := Length (Left);
RN : constant Count_Type := Length (Right); RN : constant Count_Type := Length (Right);
begin
begin
if LN = 0 then if LN = 0 then
if RN = 0 then if RN = 0 then
return Empty_Vector; return Empty_Vector;
...@@ -53,22 +53,19 @@ package body Ada.Containers.Formal_Vectors is ...@@ -53,22 +53,19 @@ package body Ada.Containers.Formal_Vectors is
declare declare
E : constant Elements_Array (1 .. Length (Right)) := E : constant Elements_Array (1 .. Length (Right)) :=
Right.Elements (1 .. RN); Right.Elements (1 .. RN);
begin begin
return (Length (Right), E, return (Length (Right), E, Last => Right.Last, others => <>);
Last => Right.Last, others => <>);
end; end;
end if; end if;
if RN = 0 then if RN = 0 then
declare declare
E : constant Elements_Array (1 .. Length (Left)) := E : constant Elements_Array (1 .. Length (Left)) :=
Left.Elements (1 .. LN); Left.Elements (1 .. LN);
begin begin
return (Length (Left), E, return (Length (Left), E, Last => Left.Last, others => <>);
Last => Left.Last, others => <>);
end; end;
end if; end if;
declare declare
...@@ -91,16 +88,13 @@ package body Ada.Containers.Formal_Vectors is ...@@ -91,16 +88,13 @@ package body Ada.Containers.Formal_Vectors is
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); Last : constant Index_Type := Index_Type (Last_As_Int);
LE : constant Elements_Array (1 .. LN) := LE : constant Elements_Array (1 .. LN) := Left.Elements (1 .. LN);
Left.Elements (1 .. LN);
RE : Elements_Array renames Right.Elements (1 .. RN); RE : Elements_Array renames Right.Elements (1 .. RN);
Capacity : constant Count_Type := Length (Left) + Length (Right); Capacity : constant Count_Type := Length (Left) + Length (Right);
begin begin
return (Capacity, LE & RE, return (Capacity, LE & RE, Last => Last, others => <>);
Last => Last, others => <>);
end; end;
end; end;
end "&"; end "&";
...@@ -111,8 +105,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -111,8 +105,7 @@ package body Ada.Containers.Formal_Vectors is
begin begin
if LN = 0 then if LN = 0 then
return (1, (1 .. 1 => Right), return (1, (1 .. 1 => Right), Index_Type'First, others => <>);
Index_Type'First, others => <>);
end if; end if;
if Int (Index_Type'First) > Int'Last - Int (LN) then if Int (Index_Type'First) > Int'Last - Int (LN) then
...@@ -127,17 +120,13 @@ package body Ada.Containers.Formal_Vectors is ...@@ -127,17 +120,13 @@ package body Ada.Containers.Formal_Vectors is
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); 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; Capacity : constant Count_Type := Length (Left) + 1;
begin begin
return (Capacity, LE & Right, return (Capacity, LE & Right, Last => Last, others => <>);
Last => Last, others => <>);
end; end;
end "&"; end "&";
function "&" (Left : Element_Type; Right : Vector) return Vector is function "&" (Left : Element_Type; Right : Vector) return Vector is
...@@ -161,15 +150,11 @@ package body Ada.Containers.Formal_Vectors is ...@@ -161,15 +150,11 @@ package body Ada.Containers.Formal_Vectors is
end if; end if;
declare declare
Last : constant Index_Type := Index_Type (Last_As_Int); Last : constant Index_Type := Index_Type (Last_As_Int);
RE : Elements_Array renames Right.Elements (1 .. RN);
RE : Elements_Array renames Right.Elements (1 .. RN);
Capacity : constant Count_Type := 1 + Length (Right); Capacity : constant Count_Type := 1 + Length (Right);
begin begin
return (Capacity, Left & RE, return (Capacity, Left & RE, Last => Last, others => <>);
Last => Last, others => <>);
end; end;
end "&"; end "&";
...@@ -181,10 +166,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -181,10 +166,8 @@ package body Ada.Containers.Formal_Vectors is
declare declare
Last : constant Index_Type := Index_Type'First + 1; Last : constant Index_Type := Index_Type'First + 1;
begin begin
return (2, (Left, Right), return (2, (Left, Right), Last => Last, others => <>);
Last => Last, others => <>);
end; end;
end "&"; end "&";
...@@ -217,7 +200,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -217,7 +200,6 @@ package body Ada.Containers.Formal_Vectors is
procedure Append (Container : in out Vector; New_Item : Vector) is procedure Append (Container : in out Vector; New_Item : Vector) is
begin begin
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
return; return;
end if; end if;
...@@ -226,10 +208,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -226,10 +208,7 @@ package body Ada.Containers.Formal_Vectors is
raise Constraint_Error with "vector is already at its maximum length"; raise Constraint_Error with "vector is already at its maximum length";
end if; end if;
Insert Insert (Container, Container.Last + 1, New_Item);
(Container,
Container.Last + 1,
New_Item);
end Append; end Append;
procedure Append procedure Append
...@@ -238,7 +217,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -238,7 +217,6 @@ package body Ada.Containers.Formal_Vectors is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if; end if;
...@@ -249,11 +227,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -249,11 +227,7 @@ package body Ada.Containers.Formal_Vectors is
-- TODO: should check whether length > max capacity (cnt_t'last) ??? -- TODO: should check whether length > max capacity (cnt_t'last) ???
Insert Insert (Container, Container.Last + 1, New_Item, Count);
(Container,
Container.Last + 1,
New_Item,
Count);
end Append; end Append;
------------ ------------
...@@ -262,8 +236,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -262,8 +236,8 @@ package body Ada.Containers.Formal_Vectors is
procedure Assign (Target : in out Vector; Source : Vector) is procedure Assign (Target : in out Vector; Source : Vector) is
LS : constant Count_Type := Length (Source); LS : constant Count_Type := Length (Source);
begin
begin
if Target'Address = Source'Address then if Target'Address = Source'Address then
return; return;
end if; end if;
...@@ -274,10 +248,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -274,10 +248,8 @@ package body Ada.Containers.Formal_Vectors is
Target.Clear; Target.Clear;
Target.Elements (1 .. LS) := Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
Source.Elements (1 .. LS); Target.Last := Source.Last;
Target.Last := Source.Last;
end Assign; end Assign;
-------------- --------------
...@@ -295,7 +267,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -295,7 +267,6 @@ package body Ada.Containers.Formal_Vectors is
procedure Clear (Container : in out Vector) is procedure Clear (Container : in out Vector) is
begin begin
if Container.Busy > 0 then if Container.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (vector is busy)"; "attempt to tamper with elements (vector is busy)";
...@@ -330,19 +301,15 @@ package body Ada.Containers.Formal_Vectors is ...@@ -330,19 +301,15 @@ package body Ada.Containers.Formal_Vectors is
begin begin
if Capacity = 0 then if Capacity = 0 then
C := LS; C := LS;
elsif Capacity >= LS then elsif Capacity >= LS then
C := Capacity; C := Capacity;
else else
raise Constraint_Error; raise Constraint_Error;
end if; end if;
return Target : Vector (C) do return Target : Vector (C) do
Target.Elements (1 .. LS) := Target.Elements (1 .. LS) := Source.Elements (1 .. LS);
Source.Elements (1 .. LS);
Target.Last := Source.Last; Target.Last := Source.Last;
end return; end return;
end Copy; end Copy;
...@@ -356,7 +323,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -356,7 +323,6 @@ package body Ada.Containers.Formal_Vectors is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
begin begin
if Index < Index_Type'First then if Index < Index_Type'First then
raise Constraint_Error with "Index is out of range (too small)"; raise Constraint_Error with "Index is out of range (too small)";
end if; end if;
...@@ -380,8 +346,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -380,8 +346,7 @@ package body Ada.Containers.Formal_Vectors is
declare declare
I_As_Int : constant Int := Int (Index); I_As_Int : constant Int := Int (Index);
Old_Last_As_Int : constant Int := Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last);
Index_Type'Pos (Container.Last);
Count1 : constant Int'Base := Count_Type'Pos (Count); Count1 : constant Int'Base := Count_Type'Pos (Count);
Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1;
...@@ -424,7 +389,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -424,7 +389,6 @@ package body Ada.Containers.Formal_Vectors is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
begin begin
if not Position.Valid then if not Position.Valid then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
end if; end if;
...@@ -446,7 +410,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -446,7 +410,6 @@ package body Ada.Containers.Formal_Vectors is
Count : Count_Type := 1) Count : Count_Type := 1)
is is
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if; end if;
...@@ -470,7 +433,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -470,7 +433,6 @@ package body Ada.Containers.Formal_Vectors is
Index : Int'Base; Index : Int'Base;
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if; end if;
...@@ -505,9 +467,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -505,9 +467,7 @@ package body Ada.Containers.Formal_Vectors is
declare declare
II : constant Int'Base := Int (Index) - Int (No_Index); II : constant Int'Base := Int (Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II); I : constant Count_Type := Count_Type (II);
begin begin
return Get_Element (Container, I); return Get_Element (Container, I);
end; end;
end Element; end Element;
...@@ -517,6 +477,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -517,6 +477,7 @@ package body Ada.Containers.Formal_Vectors is
Position : Cursor) return Element_Type Position : Cursor) return Element_Type
is is
Lst : constant Index_Type := Last_Index (Container); Lst : constant Index_Type := Last_Index (Container);
begin begin
if not Position.Valid then if not Position.Valid then
raise Constraint_Error with "Position cursor has no element"; raise Constraint_Error with "Position cursor has no element";
...@@ -529,9 +490,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -529,9 +490,7 @@ package body Ada.Containers.Formal_Vectors is
declare declare
II : constant Int'Base := Int (Position.Index) - Int (No_Index); II : constant Int'Base := Int (Position.Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II); I : constant Count_Type := Count_Type (II);
begin begin
return Get_Element (Container, I); return Get_Element (Container, I);
end; end;
end Element; end Element;
...@@ -549,7 +508,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -549,7 +508,6 @@ package body Ada.Containers.Formal_Vectors is
Last : constant Index_Type := Last_Index (Container); Last : constant Index_Type := Last_Index (Container);
begin begin
if Position.Valid then if Position.Valid then
if Position.Index > Last_Index (Container) then if Position.Index > Last_Index (Container) then
raise Program_Error with "Position index is out of range"; raise Program_Error with "Position index is out of range";
...@@ -562,11 +520,11 @@ package body Ada.Containers.Formal_Vectors is ...@@ -562,11 +520,11 @@ package body Ada.Containers.Formal_Vectors is
if Get_Element (Container, K) = Item then if Get_Element (Container, K) = Item then
return Cursor'(Index => J, others => <>); return Cursor'(Index => J, others => <>);
end if; end if;
K := K + 1; K := K + 1;
end loop; end loop;
return No_Element; return No_Element;
end Find; end Find;
---------------- ----------------
...@@ -588,6 +546,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -588,6 +546,7 @@ package body Ada.Containers.Formal_Vectors is
if Get_Element (Container, K) = Item then if Get_Element (Container, K) = Item then
return Indx; return Indx;
end if; end if;
K := K + 1; K := K + 1;
end loop; end loop;
...@@ -642,8 +601,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -642,8 +601,8 @@ package body Ada.Containers.Formal_Vectors is
function Is_Sorted (Container : Vector) return Boolean is function Is_Sorted (Container : Vector) return Boolean is
Last : constant Index_Type := Last_Index (Container); Last : constant Index_Type := Last_Index (Container);
begin
begin
if Container.Last <= Last then if Container.Last <= Last then
return True; return True;
end if; end if;
...@@ -651,10 +610,10 @@ package body Ada.Containers.Formal_Vectors is ...@@ -651,10 +610,10 @@ package body Ada.Containers.Formal_Vectors is
declare declare
L : constant Capacity_Subtype := Length (Container); L : constant Capacity_Subtype := Length (Container);
begin begin
for J in Count_Type range 1 .. L - 1 loop for J in Count_Type range 1 .. L - 1 loop
if Get_Element (Container, J + 1) if Get_Element (Container, J + 1) <
< Get_Element (Container, J) then Get_Element (Container, J)
then
return False; return False;
end if; end if;
end loop; end loop;
...@@ -692,6 +651,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -692,6 +651,7 @@ package body Ada.Containers.Formal_Vectors is
end if; end if;
-- I think we're missing this check in a-convec.adb... ??? -- I think we're missing this check in a-convec.adb... ???
if Target.Busy > 0 then if Target.Busy > 0 then
raise Program_Error with raise Program_Error with
"attempt to tamper with elements (vector is busy)"; "attempt to tamper with elements (vector is busy)";
...@@ -717,8 +677,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -717,8 +677,7 @@ package body Ada.Containers.Formal_Vectors is
return; return;
end if; end if;
pragma Assert (I <= 1 pragma Assert (I <= 1 or else not (TA (I) < TA (I - 1)));
or else not (TA (I) < TA (I - 1)));
if SA (Length (Source)) < TA (I) then if SA (Length (Source)) < TA (I) then
TA (J) := TA (I); TA (J) := TA (I);
...@@ -746,8 +705,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -746,8 +705,8 @@ package body Ada.Containers.Formal_Vectors is
Element_Type => Element_Type, Element_Type => Element_Type,
Array_Type => Elements_Array, Array_Type => Elements_Array,
"<" => "<"); "<" => "<");
begin
begin
if Container.Last <= Index_Type'First then if Container.Last <= Index_Type'First then
return; return;
end if; end if;
...@@ -768,11 +727,10 @@ package body Ada.Containers.Formal_Vectors is ...@@ -768,11 +727,10 @@ package body Ada.Containers.Formal_Vectors is
function Get_Element function Get_Element
(Container : Vector; (Container : Vector;
Position : Count_Type) return Element_Type is Position : Count_Type) return Element_Type
is
begin begin
return Container.Elements (Position); return Container.Elements (Position);
end Get_Element; end Get_Element;
----------------- -----------------
...@@ -781,13 +739,14 @@ package body Ada.Containers.Formal_Vectors is ...@@ -781,13 +739,14 @@ package body Ada.Containers.Formal_Vectors is
function Has_Element function Has_Element
(Container : Vector; (Container : Vector;
Position : Cursor) return Boolean is Position : Cursor) return Boolean
is
begin begin
if not Position.Valid then if not Position.Valid then
return False; return False;
else
return Position.Index <= Last_Index (Container);
end if; end if;
return Position.Index <= Last_Index (Container);
end Has_Element; end Has_Element;
------------ ------------
...@@ -809,7 +768,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -809,7 +768,6 @@ package body Ada.Containers.Formal_Vectors is
Max_Length : constant UInt := UInt (Container.Capacity); Max_Length : constant UInt := UInt (Container.Capacity);
begin begin
if Before < Index_Type'First then if Before < Index_Type'First then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too small)"; "Before index is out of range (too small)";
...@@ -870,7 +828,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -870,7 +828,6 @@ package body Ada.Containers.Formal_Vectors is
declare declare
II : constant Int'Base := BB + N; II : constant Int'Base := BB + N;
I : constant Count_Type := Count_Type (II); I : constant Count_Type := Count_Type (II);
begin begin
EA (I .. L) := EA (B .. Length (Container)); EA (I .. L) := EA (B .. Length (Container));
EA (B .. I - 1) := (others => New_Item); EA (B .. I - 1) := (others => New_Item);
...@@ -892,7 +849,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -892,7 +849,6 @@ package body Ada.Containers.Formal_Vectors is
N : constant Count_Type := Length (New_Item); N : constant Count_Type := Length (New_Item);
begin begin
if Before < Index_Type'First then if Before < Index_Type'First then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too small)"; "Before index is out of range (too small)";
...@@ -921,11 +877,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -921,11 +877,8 @@ package body Ada.Containers.Formal_Vectors is
B : constant Count_Type := Count_Type (BB); B : constant Count_Type := Count_Type (BB);
begin begin
if Container'Address /= New_Item'Address then if Container'Address /= New_Item'Address then
Container.Elements (B .. Dst_Last) := Container.Elements (B .. Dst_Last) := New_Item.Elements (1 .. N);
New_Item.Elements (1 .. N);
return; return;
end if; end if;
...@@ -948,8 +901,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -948,8 +901,7 @@ package body Ada.Containers.Formal_Vectors is
declare declare
Src : Elements_Array renames Src : Elements_Array renames
Container.Elements Container.Elements (Dst_Last + 1 .. Length (Container));
(Dst_Last + 1 .. Length (Container));
Index_As_Int : constant Int'Base := Index_As_Int : constant Int'Base :=
Dst_Last_As_Int - Src'Length + 1; Dst_Last_As_Int - Src'Length + 1;
...@@ -973,7 +925,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -973,7 +925,6 @@ package body Ada.Containers.Formal_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
return; return;
end if; end if;
...@@ -1004,7 +955,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1004,7 +955,6 @@ package body Ada.Containers.Formal_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Is_Empty (New_Item) then if Is_Empty (New_Item) then
if not Before.Valid if not Before.Valid
or else Before.Index > Container.Last or else Before.Index > Container.Last
...@@ -1045,7 +995,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1045,7 +995,6 @@ package body Ada.Containers.Formal_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Count = 0 then if Count = 0 then
return; return;
end if; end if;
...@@ -1077,7 +1026,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1077,7 +1026,6 @@ package body Ada.Containers.Formal_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Count = 0 then if Count = 0 then
if not Before.Valid if not Before.Valid
or else Before.Index > Container.Last or else Before.Index > Container.Last
...@@ -1129,7 +1077,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1129,7 +1077,6 @@ package body Ada.Containers.Formal_Vectors is
is is
New_Item : Element_Type; -- Default-initialized value New_Item : Element_Type; -- Default-initialized value
pragma Warnings (Off, New_Item); pragma Warnings (Off, New_Item);
begin begin
Insert (Container, Before, New_Item, Position, Count); Insert (Container, Before, New_Item, Position, Count);
end Insert; end Insert;
...@@ -1152,7 +1099,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1152,7 +1099,6 @@ package body Ada.Containers.Formal_Vectors is
Max_Length : constant UInt := UInt (Count_Type'Last); Max_Length : constant UInt := UInt (Count_Type'Last);
begin begin
if Before < Index_Type'First then if Before < Index_Type'First then
raise Constraint_Error with raise Constraint_Error with
"Before index is out of range (too small)"; "Before index is out of range (too small)";
...@@ -1213,7 +1159,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1213,7 +1159,6 @@ package body Ada.Containers.Formal_Vectors is
declare declare
II : constant Int'Base := BB + N; II : constant Int'Base := BB + N;
I : constant Count_Type := Count_Type (II); I : constant Count_Type := Count_Type (II);
begin begin
EA (I .. L) := EA (B .. Length (Container)); EA (I .. L) := EA (B .. Length (Container));
end; end;
...@@ -1232,7 +1177,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1232,7 +1177,6 @@ package body Ada.Containers.Formal_Vectors is
Index : Index_Type'Base; Index : Index_Type'Base;
begin begin
if Count = 0 then if Count = 0 then
if not Before.Valid if not Before.Valid
or else Before.Index > Container.Last or else Before.Index > Container.Last
...@@ -1354,12 +1298,13 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1354,12 +1298,13 @@ package body Ada.Containers.Formal_Vectors is
---------- ----------
function Left (Container : Vector; Position : Cursor) return Vector is function Left (Container : Vector; Position : Cursor) return Vector is
C : Vector (Container.Capacity) := C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
Copy (Container, Container.Capacity);
begin begin
if Position = No_Element then if Position = No_Element then
return C; return C;
end if; end if;
if not Has_Element (Container, Position) then if not Has_Element (Container, Position) then
raise Constraint_Error; raise Constraint_Error;
end if; end if;
...@@ -1640,7 +1585,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1640,7 +1585,6 @@ package body Ada.Containers.Formal_Vectors is
declare declare
II : constant Int'Base := Int (Position.Index) - Int (No_Index); II : constant Int'Base := Int (Position.Index) - Int (No_Index);
I : constant Count_Type := Count_Type (II); I : constant Count_Type := Count_Type (II);
begin begin
Container.Elements (I) := New_Item; Container.Elements (I) := New_Item;
end; end;
...@@ -1655,7 +1599,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1655,7 +1599,6 @@ package body Ada.Containers.Formal_Vectors is
Capacity : Capacity_Subtype) Capacity : Capacity_Subtype)
is is
begin begin
if Capacity > Container.Capacity then if Capacity > Container.Capacity then
raise Constraint_Error; -- ??? raise Constraint_Error; -- ???
end if; end if;
...@@ -1667,7 +1610,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1667,7 +1610,6 @@ package body Ada.Containers.Formal_Vectors is
procedure Reverse_Elements (Container : in out Vector) is procedure Reverse_Elements (Container : in out Vector) is
begin begin
if Length (Container) <= 1 then if Length (Container) <= 1 then
return; return;
end if; end if;
...@@ -1687,7 +1629,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1687,7 +1629,6 @@ package body Ada.Containers.Formal_Vectors is
while I < J loop while I < J loop
declare declare
EI : constant Element_Type := E (I); EI : constant Element_Type := E (I);
begin begin
E (I) := E (J); E (I) := E (J);
E (J) := EI; E (J) := EI;
...@@ -1712,7 +1653,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1712,7 +1653,6 @@ package body Ada.Containers.Formal_Vectors is
K : Count_Type; K : Count_Type;
begin begin
if not Position.Valid if not Position.Valid
or else Position.Index > Last_Index (Container) or else Position.Index > Last_Index (Container)
then then
...@@ -1726,6 +1666,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1726,6 +1666,7 @@ package body Ada.Containers.Formal_Vectors is
if Get_Element (Container, K) = Item then if Get_Element (Container, K) = Item then
return (True, Indx); return (True, Indx);
end if; end if;
K := K - 1; K := K - 1;
end loop; end loop;
...@@ -1756,6 +1697,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1756,6 +1697,7 @@ package body Ada.Containers.Formal_Vectors is
if Get_Element (Container, K) = Item then if Get_Element (Container, K) = Item then
return Indx; return Indx;
end if; end if;
K := K - 1; K := K - 1;
end loop; end loop;
...@@ -1768,8 +1710,8 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1768,8 +1710,8 @@ package body Ada.Containers.Formal_Vectors is
procedure Reverse_Iterate procedure Reverse_Iterate
(Container : Vector; (Container : Vector;
Process : Process : not null access procedure (Container : Vector;
not null access procedure (Container : Vector; Position : Cursor)) Position : Cursor))
is is
V : Vector renames Container'Unrestricted_Access.all; V : Vector renames Container'Unrestricted_Access.all;
B : Natural renames V.Busy; B : Natural renames V.Busy;
...@@ -1795,13 +1737,14 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1795,13 +1737,14 @@ package body Ada.Containers.Formal_Vectors is
----------- -----------
function Right (Container : Vector; Position : Cursor) return Vector is function Right (Container : Vector; Position : Cursor) return Vector is
C : Vector (Container.Capacity) := C : Vector (Container.Capacity) := Copy (Container, Container.Capacity);
Copy (Container, Container.Capacity);
begin begin
if Position = No_Element then if Position = No_Element then
Clear (C); Clear (C);
return C; return C;
end if; end if;
if not Has_Element (Container, Position) then if not Has_Element (Container, Position) then
raise Constraint_Error; raise Constraint_Error;
end if; end if;
...@@ -1809,6 +1752,7 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1809,6 +1752,7 @@ package body Ada.Containers.Formal_Vectors is
while C.Last /= Container.Last - Position.Index + 1 loop while C.Last /= Container.Last - Position.Index + 1 loop
Delete_First (C); Delete_First (C);
end loop; end loop;
return C; return C;
end Right; end Right;
...@@ -1821,7 +1765,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1821,7 +1765,6 @@ package body Ada.Containers.Formal_Vectors is
Length : Capacity_Subtype) Length : Capacity_Subtype)
is is
begin begin
if Length = Formal_Vectors.Length (Container) then if Length = Formal_Vectors.Length (Container) then
return; return;
end if; end if;
...@@ -1849,7 +1792,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1849,7 +1792,6 @@ package body Ada.Containers.Formal_Vectors is
procedure Swap (Container : in out Vector; I, J : Index_Type) is procedure Swap (Container : in out Vector; I, J : Index_Type) is
begin begin
if I > Container.Last then if I > Container.Last then
raise Constraint_Error with "I index is out of range"; raise Constraint_Error with "I index is out of range";
end if; end if;
...@@ -1884,7 +1826,6 @@ package body Ada.Containers.Formal_Vectors is ...@@ -1884,7 +1826,6 @@ package body Ada.Containers.Formal_Vectors is
procedure Swap (Container : in out Vector; I, J : Cursor) is procedure Swap (Container : in out Vector; I, J : Cursor) is
begin begin
if not I.Valid then if not I.Valid then
raise Constraint_Error with "I cursor has no element"; raise Constraint_Error with "I cursor has no element";
end if; end if;
......
gcc/ada/errutil.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -571,6 +571,10 @@ package body Errutil is ...@@ -571,6 +571,10 @@ package body Errutil is
Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected; Total_Errors_Detected := Total_Errors_Detected + Warnings_Detected;
Warnings_Detected := 0; Warnings_Detected := 0;
end if; end if;
-- Prevent displaying the same messages again in the future
First_Error_Msg := No_Error_Msg;
end Finalize; end Finalize;
---------------- ----------------
......
gcc/ada/g-comlin.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -19,10 +19,10 @@ ...@@ -19,10 +19,10 @@
-- additional permissions described in the GCC Runtime Library Exception, -- -- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. -- -- version 3.1, as published by the Free Software Foundation. --
-- -- -- --
-- You should have received a copy of the GNU General Public License and -- -- In particular, you can freely distribute your programs built with the --
-- a copy of the GCC Runtime Library Exception along with this program; -- -- GNAT Pro compiler, including any required library run-time units, using --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- any licensing terms of your choosing. See the AdaCore Software License --
-- <http://www.gnu.org/licenses/>. -- -- for full details. --
-- -- -- --
-- GNAT was originally developed by the GNAT team at New York University. -- -- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- Extensive contributions were provided by Ada Core Technologies Inc. --
...@@ -200,7 +200,8 @@ package body GNAT.Command_Line is ...@@ -200,7 +200,8 @@ package body GNAT.Command_Line is
(Config : Command_Line_Configuration; (Config : Command_Line_Configuration;
Section : String); Section : String);
-- Iterate over all switches defined in Config, for a specific section. -- 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 -- -- Argument --
...@@ -1238,6 +1239,10 @@ package body GNAT.Command_Line is ...@@ -1238,6 +1239,10 @@ package body GNAT.Command_Line is
Unchecked_Free (Tmp); Unchecked_Free (Tmp);
end if; end if;
if Switch.Switch /= null and then Switch.Switch.all = "*" then
Config.Star_Switch := True;
end if;
Config.Switches (Config.Switches'Last) := Switch; Config.Switches (Config.Switches'Last) := Switch;
end Add; end Add;
...@@ -1592,9 +1597,28 @@ package body GNAT.Command_Line is ...@@ -1592,9 +1597,28 @@ package body GNAT.Command_Line is
loop loop
begin begin
S := Getopt (Switches => "* " & Getopt_Description, if Cmd.Config /= null then
Concatenate => False, -- Do not use Getopt_Description in this case. Otherwise,
Parser => Parser); -- 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; exit when S = ASCII.NUL;
declare declare
...@@ -1761,6 +1785,8 @@ package body GNAT.Command_Line is ...@@ -1761,6 +1785,8 @@ package body GNAT.Command_Line is
function Analyze_Simple_Switch function Analyze_Simple_Switch
(Switch : String; Index : Integer) return Boolean; (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 -- -- Analyze_Simple_Switch --
...@@ -1772,26 +1798,26 @@ package body GNAT.Command_Line is ...@@ -1772,26 +1798,26 @@ package body GNAT.Command_Line is
pragma Unreferenced (Index); pragma Unreferenced (Index);
Full : constant String := Prefix & Group (Idx .. Group'Last); Full : constant String := Prefix & Group (Idx .. Group'Last);
Sw : constant String := Actual_Switch (Switch); Sw : constant String := Actual_Switch (Switch);
-- Switches definition minus argument definition
Last : Natural; Last : Natural;
Param : Natural; Param : Natural;
begin begin
if Sw'Length >= Prefix'Length if
-- Verify that sw starts with Prefix
-- Verify that sw starts with Prefix Looking_At (Sw, Sw'First, Prefix)
and then Looking_At (Sw, Sw'First, Prefix)
-- Verify that the group starts with sw
-- Verify that the group starts with sw
and then Looking_At (Full, Full'First, Sw) and then Looking_At (Full, Full'First, Sw)
then then
Last := Idx + Sw'Length - Prefix'Length - 1; Last := Idx + Sw'Length - Prefix'Length - 1;
Param := Last + 1; Param := Last + 1;
if Can_Have_Parameter (Switch) then if Can_Have_Parameter (Switch) then
-- Include potential parameter to the recursive call. -- Include potential parameter to the recursive call.
-- Only numbers are allowed. -- Only numbers are allowed.
...@@ -1989,8 +2015,10 @@ package body GNAT.Command_Line is ...@@ -1989,8 +2015,10 @@ package body GNAT.Command_Line is
-- First determine if the switch corresponds to one belonging to the -- First determine if the switch corresponds to one belonging to the
-- configuration. If so, run callback and exit. -- 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 if Found_In_Config then
return; return;
end if; end if;
...@@ -2127,10 +2155,17 @@ package body GNAT.Command_Line is ...@@ -2127,10 +2155,17 @@ package body GNAT.Command_Line is
Param : String; Param : String;
Index : Integer) Index : Integer)
is is
pragma Unreferenced (Index);
Sep : Character; Sep : Character;
begin 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 if Separator = "" then
Sep := ASCII.NUL; Sep := ASCII.NUL;
else else
...@@ -2808,13 +2843,8 @@ package body GNAT.Command_Line is ...@@ -2808,13 +2843,8 @@ package body GNAT.Command_Line is
if Iter.List = null then if Iter.List = null then
Iter.Current := Integer'Last; Iter.Current := Integer'Last;
else else
Iter.Current := Iter.List'First; Iter.Current := Iter.List'First - 1;
Next (Iter);
while Iter.Current <= Iter.List'Last
and then Iter.List (Iter.Current) = null
loop
Iter.Current := Iter.Current + 1;
end loop;
end if; end if;
end Start; end Start;
......
gcc/ada/g-comlin.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -583,6 +583,10 @@ package GNAT.Command_Line is ...@@ -583,6 +583,10 @@ package GNAT.Command_Line is
-- assumed that the remainder of the switch ("uv") is a set of characters -- assumed that the remainder of the switch ("uv") is a set of characters
-- whose order is irrelevant. In fact, this package will sort them -- whose order is irrelevant. In fact, this package will sort them
-- alphabetically. -- 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 procedure Define_Switch
(Config : in out Command_Line_Configuration; (Config : in out Command_Line_Configuration;
...@@ -768,7 +772,9 @@ package GNAT.Command_Line is ...@@ -768,7 +772,9 @@ package GNAT.Command_Line is
Config : Command_Line_Configuration); Config : Command_Line_Configuration);
function Get_Configuration function Get_Configuration
(Cmd : Command_Line) return Command_Line_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 procedure Set_Command_Line
(Cmd : in out Command_Line; (Cmd : in out Command_Line;
...@@ -781,6 +787,8 @@ package GNAT.Command_Line is ...@@ -781,6 +787,8 @@ package GNAT.Command_Line is
-- The parsing of Switches is done through calls to Getopt, by passing -- The parsing of Switches is done through calls to Getopt, by passing
-- Getopt_Description as an argument. (A "*" is automatically prepended so -- Getopt_Description as an argument. (A "*" is automatically prepended so
-- that all switches and command line arguments are accepted). -- 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 -- To properly handle switches that take parameters, you should document
-- them in Getopt_Description. Otherwise, the switch and its parameter will -- them in Getopt_Description. Otherwise, the switch and its parameter will
...@@ -792,6 +800,12 @@ package GNAT.Command_Line is ...@@ -792,6 +800,12 @@ package GNAT.Command_Line is
-- should be listed in the Sections parameter (as "-bargs -cargs"). -- should be listed in the Sections parameter (as "-bargs -cargs").
-- --
-- This function can be used to reset Cmd by passing an empty string. -- 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 procedure Add_Switch
(Cmd : in out Command_Line; (Cmd : in out Command_Line;
...@@ -1084,6 +1098,11 @@ private ...@@ -1084,6 +1098,11 @@ private
Sections : GNAT.OS_Lib.Argument_List_Access; Sections : GNAT.OS_Lib.Argument_List_Access;
-- The list of sections -- 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; Aliases : Alias_Definitions_List;
Usage : GNAT.OS_Lib.String_Access; Usage : GNAT.OS_Lib.String_Access;
Help : GNAT.OS_Lib.String_Access; Help : GNAT.OS_Lib.String_Access;
......
gcc/ada/make.adb
...@@ -411,6 +411,8 @@ package body Make is ...@@ -411,6 +411,8 @@ package body Make is
-- Delete all temp files created by Gnatmake and call Osint.Fail, with the -- 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 -- parameter S (see osint.ads). This is called from the Prj hierarchy and
-- the MLib hierarchy. -- the MLib hierarchy.
-- This subprogram also prints current error messages on stdout (ie
-- finalizes errout)
-------------------------- --------------------------
-- Obsolete Executables -- -- Obsolete Executables --
...@@ -795,15 +797,6 @@ package body Make is ...@@ -795,15 +797,6 @@ package body Make is
-- mappings, when using project file(s). The out parameter File_Index 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. -- 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 -- -- Subprogram declarations moved from the spec --
------------------------------------------------- -------------------------------------------------
...@@ -1267,7 +1260,6 @@ package body Make is ...@@ -1267,7 +1260,6 @@ package body Make is
""" is not a gnatmake switch. Consider moving " & """ is not a gnatmake switch. Consider moving " &
"it to Global_Compilation_Switches.", "it to Global_Compilation_Switches.",
Element.Location); Element.Location);
Errutil.Finalize;
Make_Failed ("*** illegal switch """ & Argv & """"); Make_Failed ("*** illegal switch """ & Argv & """");
end if; end if;
end; end;
...@@ -3719,7 +3711,7 @@ package body Make is ...@@ -3719,7 +3711,7 @@ package body Make is
-- Delete any temporary configuration pragma file -- Delete any temporary configuration pragma file
if not Debug.Debug_Flag_N then if not Debug.Debug_Flag_N then
Delete_Temp_Config_Files; Delete_Temp_Config_Files (Project_Tree);
end if; end if;
end Compile_Sources; end Compile_Sources;
...@@ -3911,53 +3903,6 @@ package body Make is ...@@ -3911,53 +3903,6 @@ package body Make is
Debug_Msg (S, Name_Id (N)); Debug_Msg (S, Name_Id (N));
end Debug_Msg; 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 -- -- Display --
------------- -------------
...@@ -4470,8 +4415,7 @@ package body Make is ...@@ -4470,8 +4415,7 @@ package body Make is
Write_Line (": no sources to compile"); Write_Line (": no sources to compile");
end if; end if;
Delete_All_Temp_Files; Finish_Program (Project_Tree, E_Success);
Exit_Program (E_Success);
end if; end if;
end if; end if;
...@@ -4619,8 +4563,7 @@ package body Make is ...@@ -4619,8 +4563,7 @@ package body Make is
Bind => Bind_Only, Bind => Bind_Only,
Link => Link_Only); Link => Link_Only);
Delete_All_Temp_Files; Finish_Program (Project_Tree, E_Success);
Exit_Program (E_Success);
else else
-- Call Get_Target_Parameters to ensure that VM_Target and -- Call Get_Target_Parameters to ensure that VM_Target and
...@@ -4631,7 +4574,7 @@ package body Make is ...@@ -4631,7 +4574,7 @@ package body Make is
-- Output usage information if no files to compile -- Output usage information if no files to compile
Usage; Usage;
Exit_Program (E_Fatal); Finish_Program (Project_Tree, E_Success);
end if; end if;
end if; end if;
...@@ -4809,7 +4752,6 @@ package body Make is ...@@ -4809,7 +4752,6 @@ package body Make is
"Global_Compilation_Switches. Use Switches instead.", "Global_Compilation_Switches. Use Switches instead.",
Project_Tree.Shared.Arrays.Table Project_Tree.Shared.Arrays.Table
(Default_Switches_Array).Location); (Default_Switches_Array).Location);
Errutil.Finalize;
Make_Failed Make_Failed
("*** illegal combination of Builder attributes"); ("*** illegal combination of Builder attributes");
end if; end if;
...@@ -6505,14 +6447,7 @@ package body Make is ...@@ -6505,14 +6447,7 @@ package body Make is
Report_Compilation_Failed; Report_Compilation_Failed;
end if; end if;
-- Delete the temporary mapping file that was created if we are Finish_Program (Project_Tree, E_Success);
-- using project files.
Delete_All_Temp_Files;
-- Output Namet statistics
Namet.Finalize;
exception exception
when X : others => when X : others =>
...@@ -7292,8 +7227,7 @@ package body Make is ...@@ -7292,8 +7227,7 @@ package body Make is
procedure Make_Failed (S : String) is procedure Make_Failed (S : String) is
begin begin
Delete_All_Temp_Files; Fail_Program (Project_Tree, S);
Osint.Fail (S);
end Make_Failed; end Make_Failed;
-------------------- --------------------
...@@ -7531,8 +7465,7 @@ package body Make is ...@@ -7531,8 +7465,7 @@ package body Make is
procedure Report_Compilation_Failed is procedure Report_Compilation_Failed is
begin begin
Delete_All_Temp_Files; Fail_Program (Project_Tree, "");
Exit_Program (E_Fatal);
end Report_Compilation_Failed; end Report_Compilation_Failed;
------------------------ ------------------------
...@@ -7552,10 +7485,7 @@ package body Make is ...@@ -7552,10 +7485,7 @@ package body Make is
Kill (Running_Compile (J).Pid, SIGINT, 1); Kill (Running_Compile (J).Pid, SIGINT, 1);
end loop; end loop;
Delete_All_Temp_Files; Finish_Program (Project_Tree, E_No_Compile);
OS_Exit (1);
-- ??? OS_Exit (1) is equivalent to Exit_Program (E_No_Compile),
-- shouldn't that be Exit_Program (E_Abort) instead?
end Sigint_Intercepted; end Sigint_Intercepted;
------------------- -------------------
......
gcc/ada/makeutl.adb
...@@ -25,6 +25,8 @@ ...@@ -25,6 +25,8 @@
with ALI; use ALI; with ALI; use ALI;
with Debug; with Debug;
with Err_Vars; use Err_Vars;
with Errutil;
with Fname; with Fname;
with Hostparm; with Hostparm;
with Osint; use Osint; with Osint; use Osint;
...@@ -32,6 +34,7 @@ with Output; use Output; ...@@ -32,6 +34,7 @@ with Output; use Output;
with Opt; use Opt; with Opt; use Opt;
with Prj.Ext; with Prj.Ext;
with Prj.Util; with Prj.Util;
with Sinput.P;
with Snames; use Snames; with Snames; use Snames;
with Table; with Table;
with Tempdir; with Tempdir;
...@@ -580,6 +583,58 @@ package body Makeutl is ...@@ -580,6 +583,58 @@ package body Makeutl is
end; end;
end Executable_Prefix_Path; 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 -- -- File_Not_A_Source_Of --
-------------------------- --------------------------
...@@ -819,6 +874,169 @@ package body Makeutl is ...@@ -819,6 +874,169 @@ package body Makeutl is
Write_Eol; Write_Eol;
end Inform; 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 -- -- Is_External_Assignment --
---------------------------- ----------------------------
...@@ -851,6 +1069,36 @@ package body Makeutl is ...@@ -851,6 +1069,36 @@ package body Makeutl is
Declaration => Argv (Start .. Finish)); Declaration => Argv (Start .. Finish));
end Is_External_Assignment; 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 -- -- Linker_Options_Switches --
----------------------------- -----------------------------
...@@ -963,14 +1211,8 @@ package body Makeutl is ...@@ -963,14 +1211,8 @@ package body Makeutl is
package body Mains 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 package Names is new Table.Table
(Table_Component_Type => File_And_Loc, (Table_Component_Type => Main_Info,
Table_Index_Type => Integer, Table_Index_Type => Integer,
Table_Low_Bound => 1, Table_Low_Bound => 1,
Table_Initial => 10, Table_Initial => 10,
...@@ -985,14 +1227,46 @@ package body Makeutl is ...@@ -985,14 +1227,46 @@ package body Makeutl is
-- Add_Main -- -- Add_Main --
-------------- --------------
procedure Add_Main (Name : String) is procedure Add_Main
(Name : String;
Index : Int := 0;
Location : Source_Ptr := No_Location)
is
begin begin
Name_Len := 0; Name_Len := 0;
Add_Str_To_Name_Buffer (Name); Add_Str_To_Name_Buffer (Name);
Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
Names.Increment_Last; 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; 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 -- -- Delete --
------------ ------------
...@@ -1003,43 +1277,167 @@ package body Makeutl is ...@@ -1003,43 +1277,167 @@ package body Makeutl is
Mains.Reset; Mains.Reset;
end Delete; 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 begin
if Current in Names.First .. Names.Last then if Number_Of_Mains = 0 then
return Names.Table (Current).Index; declare
else List : String_List_Id := Root_Project.Mains;
return 0; 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 if;
end Get_Index;
------------------ -- If there are mains, check that they are sources of the main
-- Get_Location -- -- 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 begin
if Current in Names.First .. Names.Last then Info := Next_Main;
return Names.Table (Current).Location; if Info = No_Main_Info then
return "";
else else
return No_Location; return Get_Name_String (Info.File);
end if; end if;
end Get_Location; end Next_Main;
--------------- ---------------
-- Next_Main -- -- Next_Main --
--------------- ---------------
function Next_Main return String is function Next_Main return Main_Info is
begin begin
if Current >= Names.Last then if Current >= Names.Last then
return ""; return No_Main_Info;
else else
Current := Current + 1; Current := Current + 1;
return Get_Name_String (Names.Table (Current).File_Name); return Names.Table (Current);
end if; end if;
end Next_Main; end Next_Main;
...@@ -1060,41 +1458,6 @@ package body Makeutl is ...@@ -1060,41 +1458,6 @@ package body Makeutl is
begin begin
Current := 0; Current := 0;
end Reset; 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; end Mains;
----------------------- -----------------------
...@@ -1727,6 +2090,144 @@ package body Makeutl is ...@@ -1727,6 +2090,144 @@ package body Makeutl is
Marks.Reset; Marks.Reset;
end Remove_Marks; 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 Queue;
end Makeutl; end Makeutl;
gcc/ada/makeutl.ads
...@@ -30,7 +30,8 @@ ...@@ -30,7 +30,8 @@
with ALI; with ALI;
with Namet; use Namet; with Namet; use Namet;
with Opt; with Opt;
with Prj; use Prj; with Osint;
with Prj; use Prj;
with Prj.Tree; with Prj.Tree;
with Types; use Types; with Types; use Types;
...@@ -111,6 +112,13 @@ package Makeutl is ...@@ -111,6 +112,13 @@ package Makeutl is
-- source files are still associated with the same units). Return True -- source files are still associated with the same units). Return True
-- if everything is still valid. -- 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 function Is_External_Assignment
(Env : Prj.Tree.Environment; (Env : Prj.Tree.Environment;
Argv : String) return Boolean; Argv : String) return Boolean;
...@@ -204,6 +212,24 @@ package Makeutl is ...@@ -204,6 +212,24 @@ package Makeutl is
function Path_Or_File_Name (Path : Path_Name_Type) return String; function Path_Or_File_Name (Path : Path_Name_Type) return String;
-- Returns a file name if -df is used, otherwise return a path name -- 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 -- -- Mains --
----------- -----------
...@@ -215,38 +241,62 @@ package Makeutl is ...@@ -215,38 +241,62 @@ package Makeutl is
-- Mains are stored in a table. An index is used to retrieve the mains -- Mains are stored in a table. An index is used to retrieve the mains
-- from the table. -- from the table.
package Mains is type Main_Info is record
File : File_Name_Type; -- Always canonical casing
procedure Add_Main (Name : String); Index : Int := 0;
-- Add one main to the table 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); package Mains is
procedure Add_Main
procedure Set_Location (Location : Source_Ptr); (Name : String;
-- Set the location of the last main added. By default, the location is Index : Int := 0;
-- No_Location. 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; procedure Delete;
-- Empty the table -- Empty the table
procedure Reset; procedure Reset;
-- Reset the index to the beginning of the table -- Reset the cursor 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.
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; function Next_Main return String;
-- Get the location of the current main function Next_Main return Main_Info;
-- Moves the cursor forward and returns the new current entry.
procedure Update_Main (Name : String); -- Returns No_File_And_Loc if there are no more mains in the table.
-- Update the file name of the current main
function Number_Of_Mains return Natural; function Number_Of_Mains return Natural;
-- Returns the number of mains added with Add_Main since the last call -- Returns the number of mains in the table.
-- to Delete.
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; end Mains;
...@@ -308,6 +358,26 @@ package Makeutl is ...@@ -308,6 +358,26 @@ package Makeutl is
-- The second version returns False if the Source was already marked in -- The second version returns False if the Source was already marked in
-- the queue. -- 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 procedure Extract
(Found : out Boolean; (Found : out Boolean;
Source : out Source_Info); Source : out Source_Info);
......
gcc/ada/prj.adb
...@@ -144,6 +144,39 @@ package body Prj is ...@@ -144,6 +144,39 @@ package body Prj is
end if; end if;
end Delete_Temporary_File; 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 -- -- Delete_All_Temp_Files --
--------------------------- ---------------------------
...@@ -493,7 +526,8 @@ package body Prj is ...@@ -493,7 +526,8 @@ package body Prj is
Project : Project_Id; Project : Project_Id;
In_Imported_Only : Boolean := False; In_Imported_Only : Boolean := False;
In_Extended_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 is
Result : Source_Id := No_Source; Result : Source_Id := No_Source;
...@@ -517,7 +551,9 @@ package body Prj is ...@@ -517,7 +551,9 @@ package body Prj is
begin begin
Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
while Element (Iterator) /= No_Source loop 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); Src := Element (Iterator);
return; return;
end if; end if;
......
gcc/ada/prj.ads
...@@ -1380,11 +1380,13 @@ package Prj is ...@@ -1380,11 +1380,13 @@ package Prj is
Project : Project_Id; Project : Project_Id;
In_Imported_Only : Boolean := False; In_Imported_Only : Boolean := False;
In_Extended_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 -- 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 -- (if In_Imported_Only is False) or in the projects imported or extended
-- by Project otherwise. In_Extended_Only implies In_Imported_Only, and -- 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 -- -- Project_Tree_Data --
...@@ -1647,6 +1649,12 @@ package Prj is ...@@ -1647,6 +1649,12 @@ package Prj is
-- Delete all recorded temporary files. -- Delete all recorded temporary files.
-- Does nothing if Debug.Debug_Flag_N is set -- 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 procedure Delete_Temporary_File
(Shared : Shared_Project_Tree_Data_Access := null; (Shared : Shared_Project_Tree_Data_Access := null;
Path : Path_Name_Type); Path : Path_Name_Type);
......
gcc/ada/sem_ch4.adb
...@@ -1524,15 +1524,21 @@ package body Sem_Ch4 is ...@@ -1524,15 +1524,21 @@ package body Sem_Ch4 is
Else_Expr := Next (Then_Expr); 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 -- * if they have no ELSE part, in which case the expression is
-- equivalent to -- equivalent to
-- NOT Condition OR ELSE Then_Expr -- NOT Condition OR ELSE Then_Expr
-- * in pre- and postconditions, where the Condition cannot have side- -- * in pre- and postconditions, where the Condition cannot have side-
-- effects (in ALFA) and thus the expression is equivalent to -- effects (in ALFA) and thus the expression is equivalent to
-- (Condition AND THEN Then_Expr) -- (Condition AND THEN Then_Expr)
-- and (NOT 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 if Present (Else_Expr) and then not In_Pre_Post_Expression then
Mark_Non_ALFA_Subprogram; Mark_Non_ALFA_Subprogram;
end if; end if;
......
gcc/ada/sem_res.adb
...@@ -5860,6 +5860,10 @@ package body Sem_Res is ...@@ -5860,6 +5860,10 @@ package body Sem_Res is
Append_To (Expressions (N), Error); Append_To (Expressions (N), Error);
end if; end if;
if Root_Type (Typ) /= Standard_Boolean then
Mark_Non_ALFA_Subprogram;
end if;
Set_Etype (N, Typ); Set_Etype (N, Typ);
Eval_Conditional_Expression (N); Eval_Conditional_Expression (N);
end Resolve_Conditional_Expression; end Resolve_Conditional_Expression;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment