Skip to content

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

[multiple changes] 

2010-06-22  Gary Dismukes  <dismukes@adacore.com>

	* sem_ch3.adb (Build_Discriminal): Set default scopes for newly created
	discriminals to the current scope.
	* sem_util.adb (Find_Body_Discriminal): Remove setting of discriminal's
	scope, which could overwrite a different already set value.

2010-06-22  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Valid_Conversion): If expression is a predefined
	operator, use sloc of type of interpretation to improve error message
	when operand is of some derived type.
	* sem_eval.adb (Is_Mixed_Mode_Operand): New function, use it.

2010-06-22  Emmanuel Briot  <briot@adacore.com>

	* g-expect-vms.adb (Expect_Internal): No longer raises an exception, so
	that it can set out parameters as well. When a process has died, reset
	its Input_Fd to Invalid_Fd, so that when using multiple processes we
	can find out which process has died.

From-SVN: r161135
parent d7567964
Showing with 201 additions and 70 deletions
gcc/ada/ChangeLog
2010-06-22 Gary Dismukes <dismukes@adacore.com>
* sem_ch3.adb (Build_Discriminal): Set default scopes for newly created
discriminals to the current scope.
* sem_util.adb (Find_Body_Discriminal): Remove setting of discriminal's
scope, which could overwrite a different already set value.
2010-06-22 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Valid_Conversion): If expression is a predefined
operator, use sloc of type of interpretation to improve error message
when operand is of some derived type.
* sem_eval.adb (Is_Mixed_Mode_Operand): New function, use it.
2010-06-22 Emmanuel Briot <briot@adacore.com>
* g-expect-vms.adb (Expect_Internal): No longer raises an exception, so
that it can set out parameters as well. When a process has died, reset
its Input_Fd to Invalid_Fd, so that when using multiple processes we
can find out which process has died.
2010-06-22 Thomas Quinot <quinot@adacore.com> 2010-06-22 Thomas Quinot <quinot@adacore.com>
* sem_eval.adb (Find_Universal_Operator_Type): New * sem_eval.adb (Find_Universal_Operator_Type): New
......
gcc/ada/g-expect-vms.adb
...@@ -50,6 +50,11 @@ package body GNAT.Expect is ...@@ -50,6 +50,11 @@ package body GNAT.Expect is
Save_Output : File_Descriptor; Save_Output : File_Descriptor;
Save_Error : File_Descriptor; Save_Error : File_Descriptor;
Expect_Process_Died : constant Expect_Match := -100;
Expect_Internal_Error : constant Expect_Match := -101;
-- Additional possible outputs of Expect_Internal. These are not visible in
-- the spec because the user will never see them.
procedure Expect_Internal procedure Expect_Internal
(Descriptors : in out Array_Of_Pd; (Descriptors : in out Array_Of_Pd;
Result : out Expect_Match; Result : out Expect_Match;
...@@ -57,11 +62,14 @@ package body GNAT.Expect is ...@@ -57,11 +62,14 @@ package body GNAT.Expect is
Full_Buffer : Boolean); Full_Buffer : Boolean);
-- Internal function used to read from the process Descriptor. -- Internal function used to read from the process Descriptor.
-- --
-- Three outputs are possible: -- Several outputs are possible:
-- Result=Expect_Timeout, if no output was available before the timeout -- Result=Expect_Timeout, if no output was available before the timeout
-- expired. -- expired.
-- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters
-- had to be discarded from the internal buffer of Descriptor. -- had to be discarded from the internal buffer of Descriptor.
-- Result=Express_Process_Died if one of the processes was terminated.
-- That process's Input_Fd is set to Invalid_FD
-- Result=Express_Internal_Error
-- Result=<integer>, indicates how many characters were added to the -- Result=<integer>, indicates how many characters were added to the
-- internal buffer. These characters are from indexes -- internal buffer. These characters are from indexes
-- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index
...@@ -209,7 +217,9 @@ package body GNAT.Expect is ...@@ -209,7 +217,9 @@ package body GNAT.Expect is
Status : out Integer) Status : out Integer)
is is
begin begin
Close (Descriptor.Input_Fd); if Descriptor.Input_Fd /= Invalid_FD then
Close (Descriptor.Input_Fd);
end if;
if Descriptor.Error_Fd /= Descriptor.Output_Fd then if Descriptor.Error_Fd /= Descriptor.Output_Fd then
Close (Descriptor.Error_Fd); Close (Descriptor.Error_Fd);
...@@ -331,10 +341,17 @@ package body GNAT.Expect is ...@@ -331,10 +341,17 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
if N = Expect_Timeout or else N = Expect_Full_Buffer then case N is
Result := N; when Expect_Internal_Error | Expect_Process_Died =>
return; raise Process_Died;
end if;
when Expect_Timeout | Expect_Full_Buffer =>
Result := N;
return;
when others =>
null; -- See below
end case;
-- Calculate the timeout for the next turn -- Calculate the timeout for the next turn
...@@ -478,10 +495,17 @@ package body GNAT.Expect is ...@@ -478,10 +495,17 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout, Full_Buffer); Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
if N = Expect_Timeout or else N = Expect_Full_Buffer then case N is
Result := N; when Expect_Internal_Error | Expect_Process_Died =>
return; raise Process_Died;
end if;
when Expect_Timeout | Expect_Full_Buffer =>
Result := N;
return;
when others =>
null; -- Continue
end case;
end loop; end loop;
end Expect; end Expect;
...@@ -500,7 +524,9 @@ package body GNAT.Expect is ...@@ -500,7 +524,9 @@ package body GNAT.Expect is
for J in Descriptors'Range loop for J in Descriptors'Range loop
Descriptors (J) := Regexps (J).Descriptor; Descriptors (J) := Regexps (J).Descriptor;
Reinitialize_Buffer (Regexps (J).Descriptor.all); if Descriptors (J) /= null then
Reinitialize_Buffer (Regexps (J).Descriptor.all);
end if;
end loop; end loop;
loop loop
...@@ -511,25 +537,36 @@ package body GNAT.Expect is ...@@ -511,25 +537,36 @@ package body GNAT.Expect is
-- checking the regexps). -- checking the regexps).
for J in Regexps'Range loop for J in Regexps'Range loop
Match (Regexps (J).Regexp.all, if Regexps (J).Regexp /= null
Regexps (J).Descriptor.Buffer and then Regexps (J).Descriptor /= null
(1 .. Regexps (J).Descriptor.Buffer_Index), then
Matched); Match (Regexps (J).Regexp.all,
Regexps (J).Descriptor.Buffer
if Matched (0) /= No_Match then (1 .. Regexps (J).Descriptor.Buffer_Index),
Result := Expect_Match (J); Matched);
Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; if Matched (0) /= No_Match then
return; Result := Expect_Match (J);
Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
return;
end if;
end if; end if;
end loop; end loop;
Expect_Internal (Descriptors, N, Timeout, Full_Buffer); Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
if N = Expect_Timeout or else N = Expect_Full_Buffer then case N is
Result := N; when Expect_Internal_Error | Expect_Process_Died =>
return; raise Process_Died;
end if;
when Expect_Timeout | Expect_Full_Buffer =>
Result := N;
return;
when others =>
null; -- Continue
end case;
end loop; end loop;
end Expect; end Expect;
...@@ -549,21 +586,30 @@ package body GNAT.Expect is ...@@ -549,21 +586,30 @@ package body GNAT.Expect is
N : Integer; N : Integer;
type File_Descriptor_Array is type File_Descriptor_Array is
array (Descriptors'Range) of File_Descriptor; array (0 .. Descriptors'Length - 1) of File_Descriptor;
Fds : aliased File_Descriptor_Array; Fds : aliased File_Descriptor_Array;
Fds_Count : Natural := 0;
Fds_To_Descriptor : array (Fds'Range) of Integer;
-- Maps file descriptor entries from Fds to entries in Descriptors.
-- They do not have the same index when entries in Descriptors are null.
type Integer_Array is array (Descriptors'Range) of Integer; type Integer_Array is array (Fds'Range) of Integer;
Is_Set : aliased Integer_Array; Is_Set : aliased Integer_Array;
begin begin
for J in Descriptors'Range loop for J in Descriptors'Range loop
Fds (J) := Descriptors (J).Output_Fd; if Descriptors (J) /= null then
Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd;
Fds_To_Descriptor (Fds'First + Fds_Count) := J;
Fds_Count := Fds_Count + 1;
if Descriptors (J).Buffer_Size = 0 then if Descriptors (J).Buffer_Size = 0 then
Buffer_Size := Integer'Max (Buffer_Size, 4096); Buffer_Size := Integer'Max (Buffer_Size, 4096);
else else
Buffer_Size := Buffer_Size :=
Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
end if;
end if; end if;
end loop; end loop;
...@@ -572,19 +618,23 @@ package body GNAT.Expect is ...@@ -572,19 +618,23 @@ package body GNAT.Expect is
-- Buffer used for input. This is allocated only once, not for -- Buffer used for input. This is allocated only once, not for
-- every iteration of the loop -- every iteration of the loop
D : Integer;
-- Index in Descriptors
begin begin
-- Loop until we match or we have a timeout -- Loop until we match or we have a timeout
loop loop
Num_Descriptors := Num_Descriptors :=
Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address); Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address);
case Num_Descriptors is case Num_Descriptors is
-- Error? -- Error?
when -1 => when -1 =>
raise Process_Died; Result := Expect_Internal_Error;
return;
-- Timeout? -- Timeout?
...@@ -595,15 +645,17 @@ package body GNAT.Expect is ...@@ -595,15 +645,17 @@ package body GNAT.Expect is
-- Some input -- Some input
when others => when others =>
for J in Descriptors'Range loop for F in Fds'Range loop
if Is_Set (J) = 1 then if Is_Set (F) = 1 then
Buffer_Size := Descriptors (J).Buffer_Size; D := Fds_To_Descriptor (F);
Buffer_Size := Descriptors (D).Buffer_Size;
if Buffer_Size = 0 then if Buffer_Size = 0 then
Buffer_Size := 4096; Buffer_Size := 4096;
end if; end if;
N := Read (Descriptors (J).Output_Fd, Buffer'Address, N := Read (Descriptors (D).Output_Fd, Buffer'Address,
Buffer_Size); Buffer_Size);
-- Error or End of file -- Error or End of file
...@@ -611,43 +663,46 @@ package body GNAT.Expect is ...@@ -611,43 +663,46 @@ package body GNAT.Expect is
if N <= 0 then if N <= 0 then
-- ??? Note that ddd tries again up to three times -- ??? Note that ddd tries again up to three times
-- in that case. See LiterateA.C:174 -- in that case. See LiterateA.C:174
raise Process_Died;
Descriptors (D).Input_Fd := Invalid_FD;
Result := Expect_Process_Died;
return;
else else
-- If there is no limit to the buffer size -- If there is no limit to the buffer size
if Descriptors (J).Buffer_Size = 0 then if Descriptors (D).Buffer_Size = 0 then
declare declare
Tmp : String_Access := Descriptors (J).Buffer; Tmp : String_Access := Descriptors (D).Buffer;
begin begin
if Tmp /= null then if Tmp /= null then
Descriptors (J).Buffer := Descriptors (D).Buffer :=
new String (1 .. Tmp'Length + N); new String (1 .. Tmp'Length + N);
Descriptors (J).Buffer (1 .. Tmp'Length) := Descriptors (D).Buffer (1 .. Tmp'Length) :=
Tmp.all; Tmp.all;
Descriptors (J).Buffer Descriptors (D).Buffer
(Tmp'Length + 1 .. Tmp'Length + N) := (Tmp'Length + 1 .. Tmp'Length + N) :=
Buffer (1 .. N); Buffer (1 .. N);
Free (Tmp); Free (Tmp);
Descriptors (J).Buffer_Index := Descriptors (D).Buffer_Index :=
Descriptors (J).Buffer'Last; Descriptors (D).Buffer'Last;
else else
Descriptors (J).Buffer := Descriptors (D).Buffer :=
new String (1 .. N); new String (1 .. N);
Descriptors (J).Buffer.all := Descriptors (D).Buffer.all :=
Buffer (1 .. N); Buffer (1 .. N);
Descriptors (J).Buffer_Index := N; Descriptors (D).Buffer_Index := N;
end if; end if;
end; end;
else else
-- Add what we read to the buffer -- Add what we read to the buffer
if Descriptors (J).Buffer_Index + N > if Descriptors (D).Buffer_Index + N >
Descriptors (J).Buffer_Size Descriptors (D).Buffer_Size
then then
-- If the user wants to know when we have -- If the user wants to know when we have
-- read more than the buffer can contain. -- read more than the buffer can contain.
...@@ -660,33 +715,33 @@ package body GNAT.Expect is ...@@ -660,33 +715,33 @@ package body GNAT.Expect is
-- Keep as much as possible from the buffer, -- Keep as much as possible from the buffer,
-- and forget old characters. -- and forget old characters.
Descriptors (J).Buffer Descriptors (D).Buffer
(1 .. Descriptors (J).Buffer_Size - N) := (1 .. Descriptors (D).Buffer_Size - N) :=
Descriptors (J).Buffer Descriptors (D).Buffer
(N - Descriptors (J).Buffer_Size + (N - Descriptors (D).Buffer_Size +
Descriptors (J).Buffer_Index + 1 .. Descriptors (D).Buffer_Index + 1 ..
Descriptors (J).Buffer_Index); Descriptors (D).Buffer_Index);
Descriptors (J).Buffer_Index := Descriptors (D).Buffer_Index :=
Descriptors (J).Buffer_Size - N; Descriptors (D).Buffer_Size - N;
end if; end if;
-- Keep what we read in the buffer -- Keep what we read in the buffer
Descriptors (J).Buffer Descriptors (D).Buffer
(Descriptors (J).Buffer_Index + 1 .. (Descriptors (D).Buffer_Index + 1 ..
Descriptors (J).Buffer_Index + N) := Descriptors (D).Buffer_Index + N) :=
Buffer (1 .. N); Buffer (1 .. N);
Descriptors (J).Buffer_Index := Descriptors (D).Buffer_Index :=
Descriptors (J).Buffer_Index + N; Descriptors (D).Buffer_Index + N;
end if; end if;
-- Call each of the output filter with what we -- Call each of the output filter with what we
-- read. -- read.
Call_Filters Call_Filters
(Descriptors (J).all, Buffer (1 .. N), Output); (Descriptors (D).all, Buffer (1 .. N), Output);
Result := Expect_Match (N); Result := Expect_Match (D);
return; return;
end if; end if;
end if; end if;
...@@ -1062,6 +1117,13 @@ package body GNAT.Expect is ...@@ -1062,6 +1117,13 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, Result, Expect_Internal (Descriptors, Result,
Timeout => 0, Full_Buffer => False); Timeout => 0, Full_Buffer => False);
if Result = Expect_Internal_Error
or else Result = Expect_Process_Died
then
raise Process_Died;
end if;
Descriptor.Last_Match_End := Descriptor.Buffer_Index; Descriptor.Last_Match_End := Descriptor.Buffer_Index;
-- Empty the buffer -- Empty the buffer
......
gcc/ada/sem_ch3.adb
...@@ -7710,6 +7710,7 @@ package body Sem_Ch3 is ...@@ -7710,6 +7710,7 @@ package body Sem_Ch3 is
Set_Ekind (D_Minal, E_In_Parameter); Set_Ekind (D_Minal, E_In_Parameter);
Set_Mechanism (D_Minal, Default_Mechanism); Set_Mechanism (D_Minal, Default_Mechanism);
Set_Etype (D_Minal, Etype (Discrim)); Set_Etype (D_Minal, Etype (Discrim));
Set_Scope (D_Minal, Current_Scope);
Set_Discriminal (Discrim, D_Minal); Set_Discriminal (Discrim, D_Minal);
Set_Discriminal_Link (D_Minal, Discrim); Set_Discriminal_Link (D_Minal, Discrim);
...@@ -7726,6 +7727,7 @@ package body Sem_Ch3 is ...@@ -7726,6 +7727,7 @@ package body Sem_Ch3 is
Set_Ekind (CR_Disc, E_In_Parameter); Set_Ekind (CR_Disc, E_In_Parameter);
Set_Mechanism (CR_Disc, Default_Mechanism); Set_Mechanism (CR_Disc, Default_Mechanism);
Set_Etype (CR_Disc, Etype (Discrim)); Set_Etype (CR_Disc, Etype (Discrim));
Set_Scope (CR_Disc, Current_Scope);
Set_Discriminal_Link (CR_Disc, Discrim); Set_Discriminal_Link (CR_Disc, Discrim);
Set_CR_Discriminant (Discrim, CR_Disc); Set_CR_Discriminant (Discrim, CR_Disc);
end if; end if;
......
gcc/ada/sem_eval.adb
...@@ -4799,6 +4799,24 @@ package body Sem_Eval is ...@@ -4799,6 +4799,24 @@ package body Sem_Eval is
Typ1 : Entity_Id := Empty; Typ1 : Entity_Id := Empty;
Priv_E : Entity_Id; Priv_E : Entity_Id;
function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
-- Check whether one operand is a mixed-mode operation that requires
-- the presence of a fixed-point type. Given that all operands are
-- universal and have been constant-folded, retrieve the original
-- function call.
---------------------------
-- Is_Mixed_Mode_Operand --
---------------------------
function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
begin
return Nkind (Original_Node (Op)) = N_Function_Call
and then Present (Next_Actual (First_Actual (Original_Node (Op))))
and then Etype (First_Actual (Original_Node (Op))) /=
Etype (Next_Actual (First_Actual (Original_Node (Op))));
end Is_Mixed_Mode_Operand;
begin begin
if Nkind (Call) /= N_Function_Call if Nkind (Call) /= N_Function_Call
or else Nkind (Name (Call)) /= N_Expanded_Name or else Nkind (Name (Call)) /= N_Expanded_Name
...@@ -4845,6 +4863,20 @@ package body Sem_Eval is ...@@ -4845,6 +4863,20 @@ package body Sem_Eval is
if No (Typ1) then if No (Typ1) then
Typ1 := E; Typ1 := E;
-- Before emitting an error, check for the presence of a
-- mixed-mode operation that specifies a fixed point type.
elsif Is_Relational
and then
(Is_Mixed_Mode_Operand (Left_Opnd (N))
or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
then
if Is_Fixed_Point_Type (E) then
Typ1 := E;
end if;
else else
-- More than one type of the proper class declared in P -- More than one type of the proper class declared in P
......
gcc/ada/sem_res.adb
...@@ -9567,6 +9567,7 @@ package body Sem_Res is ...@@ -9567,6 +9567,7 @@ package body Sem_Res is
It : Interp; It : Interp;
It1 : Interp; It1 : Interp;
N1 : Entity_Id; N1 : Entity_Id;
T1 : Entity_Id;
begin begin
-- Remove procedure calls, which syntactically cannot appear in -- Remove procedure calls, which syntactically cannot appear in
...@@ -9623,16 +9624,30 @@ package body Sem_Res is ...@@ -9623,16 +9624,30 @@ package body Sem_Res is
if Present (It.Typ) then if Present (It.Typ) then
N1 := It1.Nam; N1 := It1.Nam;
T1 := It1.Typ;
It1 := Disambiguate (Operand, I1, I, Any_Type); It1 := Disambiguate (Operand, I1, I, Any_Type);
if It1 = No_Interp then if It1 = No_Interp then
Error_Msg_N ("ambiguous operand in conversion", Operand); Error_Msg_N ("ambiguous operand in conversion", Operand);
Error_Msg_Sloc := Sloc (It.Nam); -- If the interpretation involves a standard operator, use
-- the location of the type, which may be user-defined.
if Sloc (It.Nam) = Standard_Location then
Error_Msg_Sloc := Sloc (It.Typ);
else
Error_Msg_Sloc := Sloc (It.Nam);
end if;
Error_Msg_N -- CODEFIX Error_Msg_N -- CODEFIX
("\\possible interpretation#!", Operand); ("\\possible interpretation#!", Operand);
Error_Msg_Sloc := Sloc (N1); if Sloc (N1) = Standard_Location then
Error_Msg_Sloc := Sloc (T1);
else
Error_Msg_Sloc := Sloc (N1);
end if;
Error_Msg_N -- CODEFIX Error_Msg_N -- CODEFIX
("\\possible interpretation#!", Operand); ("\\possible interpretation#!", Operand);
......
gcc/ada/sem_util.adb
...@@ -3082,7 +3082,6 @@ package body Sem_Util is ...@@ -3082,7 +3082,6 @@ package body Sem_Util is
Disc := First_Discriminant (Tsk); Disc := First_Discriminant (Tsk);
while Present (Disc) loop while Present (Disc) loop
if Chars (Disc) = Chars (Spec_Discriminant) then if Chars (Disc) = Chars (Spec_Discriminant) then
Set_Scope (Discriminal (Disc), Tsk);
return Discriminal (Disc); return Discriminal (Disc);
end if; end if;
......
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