Commit ae77c68b by Arnaud Charlet

[multiple changes]

2010-06-22  Robert Dewar  <dewar@adacore.com>

	* sem_eval.adb: Minor reformatting.

2010-06-22  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_N_Conditional_Expression): Use
	Expression_With_Actions to clean up the code generated when folding
	constant expressions.

2010-06-22  Vincent Celier  <celier@adacore.com>

	* g-expect-vms.adb: Add new subprograms Free, First_Dead_Process and
	Has_Process.

From-SVN: r161132
parent 47edeeab
2010-06-22 Robert Dewar <dewar@adacore.com>
* sem_eval.adb: Minor reformatting.
2010-06-22 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_N_Conditional_Expression): Use
Expression_With_Actions to clean up the code generated when folding
constant expressions.
2010-06-22 Vincent Celier <celier@adacore.com>
* g-expect-vms.adb: Add new subprograms Free, First_Dead_Process and
Has_Process.
2010-06-22 Vincent Celier <celier@adacore.com> 2010-06-22 Vincent Celier <celier@adacore.com>
* prj-nmsc.adb (Find_Sources): When a source from a multi-unit file is * prj-nmsc.adb (Find_Sources): When a source from a multi-unit file is
......
...@@ -4053,8 +4053,25 @@ package body Exp_Ch4 is ...@@ -4053,8 +4053,25 @@ package body Exp_Ch4 is
end if; end if;
Remove (Expr); Remove (Expr);
Insert_Actions (N, Actions);
Rewrite (N, Relocate_Node (Expr)); if Present (Actions) then
-- If we are not allowed to use Expression_With_Actions, just
-- skip the optimization, it is not critical for correctness.
if not Use_Expression_With_Actions then
goto Skip_Optimization;
end if;
Rewrite (N,
Make_Expression_With_Actions (Loc,
Expression => Relocate_Node (Expr),
Actions => Actions));
Analyze_And_Resolve (N, Typ);
else
Rewrite (N, Relocate_Node (Expr));
end if;
-- Note that the result is never static (legitimate cases of static -- Note that the result is never static (legitimate cases of static
-- conditional expressions were folded in Sem_Eval). -- conditional expressions were folded in Sem_Eval).
...@@ -4063,6 +4080,8 @@ package body Exp_Ch4 is ...@@ -4063,6 +4080,8 @@ package body Exp_Ch4 is
return; return;
end if; end if;
<<Skip_Optimization>>
-- If the type is limited or unconstrained, we expand as follows to -- If the type is limited or unconstrained, we expand as follows to
-- avoid any possibility of improper copies. -- avoid any possibility of improper copies.
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2002-2009, AdaCore -- -- Copyright (C) 2002-2010, 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- --
...@@ -715,6 +715,24 @@ package body GNAT.Expect is ...@@ -715,6 +715,24 @@ package body GNAT.Expect is
(Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End);
end Expect_Out_Match; end Expect_Out_Match;
------------------------
-- First_Dead_Process --
------------------------
function First_Dead_Process
(Regexp : Multiprocess_Regexp_Array) return Natural is
begin
for R in Regexp'Range loop
if Regexp (R).Descriptor /= null
and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD
then
return R;
end if;
end loop;
return 0;
end First_Dead_Process;
----------- -----------
-- Flush -- -- Flush --
----------- -----------
...@@ -770,6 +788,18 @@ package body GNAT.Expect is ...@@ -770,6 +788,18 @@ package body GNAT.Expect is
end loop; end loop;
end Flush; end Flush;
----------
-- Free --
----------
procedure Free (Regexp : in out Multiprocess_Regexp) is
procedure Unchecked_Free is new Ada.Unchecked_Deallocation
(Process_Descriptor'Class, Process_Descriptor_Access);
begin
Unchecked_Free (Regexp.Descriptor);
Free (Regexp.Regexp);
end Free;
------------------------ ------------------------
-- Get_Command_Output -- -- Get_Command_Output --
------------------------ ------------------------
...@@ -897,6 +927,15 @@ package body GNAT.Expect is ...@@ -897,6 +927,15 @@ package body GNAT.Expect is
return Descriptor.Pid; return Descriptor.Pid;
end Get_Pid; end Get_Pid;
-----------------
-- Has_Process --
-----------------
function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is
begin
return Regexp /= (Regexp'Range => (null, null));
end Has_Process;
--------------- ---------------
-- Interrupt -- -- Interrupt --
--------------- ---------------
......
...@@ -183,7 +183,7 @@ package body Sem_Eval is ...@@ -183,7 +183,7 @@ package body Sem_Eval is
procedure Test_Ambiguous_Operator (N : Node_Id); procedure Test_Ambiguous_Operator (N : Node_Id);
-- Check whether an arithmetic operation with universal operands which -- Check whether an arithmetic operation with universal operands which
-- is a rewritten function call with an explicit scope indication is -- is a rewritten function call with an explicit scope indication is
-- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one
-- visible numeric type declared in P and the context does not impose a -- visible numeric type declared in P and the context does not impose a
-- type on the result (e.g. in the expression of a type conversion). -- type on the result (e.g. in the expression of a type conversion).
...@@ -1466,10 +1466,12 @@ package body Sem_Eval is ...@@ -1466,10 +1466,12 @@ package body Sem_Eval is
end if; end if;
if (Etype (Right) = Universal_Integer if (Etype (Right) = Universal_Integer
or else Etype (Right) = Universal_Real) or else
Etype (Right) = Universal_Real)
and then and then
(Etype (Left) = Universal_Integer (Etype (Left) = Universal_Integer
or else Etype (Left) = Universal_Real) or else
Etype (Left) = Universal_Real)
then then
Test_Ambiguous_Operator (N); Test_Ambiguous_Operator (N);
end if; end if;
...@@ -3412,7 +3414,8 @@ package body Sem_Eval is ...@@ -3412,7 +3414,8 @@ package body Sem_Eval is
end if; end if;
if Etype (Right) = Universal_Integer if Etype (Right) = Universal_Integer
or else Etype (Right) = Universal_Real or else
Etype (Right) = Universal_Real
then then
Test_Ambiguous_Operator (N); Test_Ambiguous_Operator (N);
end if; end if;
...@@ -4730,9 +4733,9 @@ package body Sem_Eval is ...@@ -4730,9 +4733,9 @@ package body Sem_Eval is
Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
Is_Fix : constant Boolean := Is_Fix : constant Boolean :=
Nkind (N) in N_Binary_Op Nkind (N) in N_Binary_Op
and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
-- a mixed-mode operation in this context indicates the -- A mixed-mode operation in this context indicates the
-- presence of fixed-point type in the designated package. -- presence of fixed-point type in the designated package.
E : Entity_Id; E : Entity_Id;
...@@ -4763,9 +4766,7 @@ package body Sem_Eval is ...@@ -4763,9 +4766,7 @@ package body Sem_Eval is
Typ1 := Empty; Typ1 := Empty;
E := First_Entity (Pack); E := First_Entity (Pack);
while Present (E) while Present (E) and then E /= Priv_E loop
and then E /= Priv_E
loop
if Is_Numeric_Type (E) if Is_Numeric_Type (E)
and then Nkind (Parent (E)) /= N_Subtype_Declaration and then Nkind (Parent (E)) /= N_Subtype_Declaration
and then Comes_From_Source (E) and then Comes_From_Source (E)
......
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