[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
This commit is contained in:
Arnaud Charlet
parent
d7567964ea
commit
f0d103851a
@ -1,3 +1,24 @@
|
||||
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>
|
||||
|
||||
* sem_eval.adb (Find_Universal_Operator_Type): New
|
||||
|
||||
@ -50,6 +50,11 @@ package body GNAT.Expect is
|
||||
Save_Output : 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
|
||||
(Descriptors : in out Array_Of_Pd;
|
||||
Result : out Expect_Match;
|
||||
@ -57,11 +62,14 @@ package body GNAT.Expect is
|
||||
Full_Buffer : Boolean);
|
||||
-- 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
|
||||
-- expired.
|
||||
-- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters
|
||||
-- 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
|
||||
-- internal buffer. These characters are from indexes
|
||||
-- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index
|
||||
@ -209,7 +217,9 @@ package body GNAT.Expect is
|
||||
Status : out Integer)
|
||||
is
|
||||
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
|
||||
Close (Descriptor.Error_Fd);
|
||||
@ -331,10 +341,17 @@ package body GNAT.Expect is
|
||||
|
||||
Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
|
||||
|
||||
if N = Expect_Timeout or else N = Expect_Full_Buffer then
|
||||
Result := N;
|
||||
return;
|
||||
end if;
|
||||
case N is
|
||||
when Expect_Internal_Error | Expect_Process_Died =>
|
||||
raise Process_Died;
|
||||
|
||||
when Expect_Timeout | Expect_Full_Buffer =>
|
||||
Result := N;
|
||||
return;
|
||||
|
||||
when others =>
|
||||
null; -- See below
|
||||
end case;
|
||||
|
||||
-- Calculate the timeout for the next turn
|
||||
|
||||
@ -478,10 +495,17 @@ package body GNAT.Expect is
|
||||
|
||||
Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
|
||||
|
||||
if N = Expect_Timeout or else N = Expect_Full_Buffer then
|
||||
Result := N;
|
||||
return;
|
||||
end if;
|
||||
case N is
|
||||
when Expect_Internal_Error | Expect_Process_Died =>
|
||||
raise Process_Died;
|
||||
|
||||
when Expect_Timeout | Expect_Full_Buffer =>
|
||||
Result := N;
|
||||
return;
|
||||
|
||||
when others =>
|
||||
null; -- Continue
|
||||
end case;
|
||||
end loop;
|
||||
end Expect;
|
||||
|
||||
@ -500,7 +524,9 @@ package body GNAT.Expect is
|
||||
|
||||
for J in Descriptors'Range loop
|
||||
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;
|
||||
|
||||
loop
|
||||
@ -511,25 +537,36 @@ package body GNAT.Expect is
|
||||
-- checking the regexps).
|
||||
|
||||
for J in Regexps'Range loop
|
||||
Match (Regexps (J).Regexp.all,
|
||||
Regexps (J).Descriptor.Buffer
|
||||
(1 .. Regexps (J).Descriptor.Buffer_Index),
|
||||
Matched);
|
||||
if Regexps (J).Regexp /= null
|
||||
and then Regexps (J).Descriptor /= null
|
||||
then
|
||||
Match (Regexps (J).Regexp.all,
|
||||
Regexps (J).Descriptor.Buffer
|
||||
(1 .. Regexps (J).Descriptor.Buffer_Index),
|
||||
Matched);
|
||||
|
||||
if Matched (0) /= No_Match then
|
||||
Result := Expect_Match (J);
|
||||
Regexps (J).Descriptor.Last_Match_Start := Matched (0).First;
|
||||
Regexps (J).Descriptor.Last_Match_End := Matched (0).Last;
|
||||
return;
|
||||
if Matched (0) /= No_Match then
|
||||
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 loop;
|
||||
|
||||
Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
|
||||
|
||||
if N = Expect_Timeout or else N = Expect_Full_Buffer then
|
||||
Result := N;
|
||||
return;
|
||||
end if;
|
||||
case N is
|
||||
when Expect_Internal_Error | Expect_Process_Died =>
|
||||
raise Process_Died;
|
||||
|
||||
when Expect_Timeout | Expect_Full_Buffer =>
|
||||
Result := N;
|
||||
return;
|
||||
|
||||
when others =>
|
||||
null; -- Continue
|
||||
end case;
|
||||
end loop;
|
||||
end Expect;
|
||||
|
||||
@ -549,21 +586,30 @@ package body GNAT.Expect is
|
||||
N : Integer;
|
||||
|
||||
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_Count : Natural := 0;
|
||||
|
||||
type Integer_Array is array (Descriptors'Range) of Integer;
|
||||
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 (Fds'Range) of Integer;
|
||||
Is_Set : aliased Integer_Array;
|
||||
|
||||
begin
|
||||
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
|
||||
Buffer_Size := Integer'Max (Buffer_Size, 4096);
|
||||
else
|
||||
Buffer_Size :=
|
||||
Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
|
||||
if Descriptors (J).Buffer_Size = 0 then
|
||||
Buffer_Size := Integer'Max (Buffer_Size, 4096);
|
||||
else
|
||||
Buffer_Size :=
|
||||
Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size);
|
||||
end if;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
@ -572,19 +618,23 @@ package body GNAT.Expect is
|
||||
-- Buffer used for input. This is allocated only once, not for
|
||||
-- every iteration of the loop
|
||||
|
||||
D : Integer;
|
||||
-- Index in Descriptors
|
||||
|
||||
begin
|
||||
-- Loop until we match or we have a timeout
|
||||
|
||||
loop
|
||||
Num_Descriptors :=
|
||||
Poll (Fds'Address, Fds'Length, Timeout, Is_Set'Address);
|
||||
Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address);
|
||||
|
||||
case Num_Descriptors is
|
||||
|
||||
-- Error?
|
||||
|
||||
when -1 =>
|
||||
raise Process_Died;
|
||||
Result := Expect_Internal_Error;
|
||||
return;
|
||||
|
||||
-- Timeout?
|
||||
|
||||
@ -595,15 +645,17 @@ package body GNAT.Expect is
|
||||
-- Some input
|
||||
|
||||
when others =>
|
||||
for J in Descriptors'Range loop
|
||||
if Is_Set (J) = 1 then
|
||||
Buffer_Size := Descriptors (J).Buffer_Size;
|
||||
for F in Fds'Range loop
|
||||
if Is_Set (F) = 1 then
|
||||
D := Fds_To_Descriptor (F);
|
||||
|
||||
Buffer_Size := Descriptors (D).Buffer_Size;
|
||||
|
||||
if Buffer_Size = 0 then
|
||||
Buffer_Size := 4096;
|
||||
end if;
|
||||
|
||||
N := Read (Descriptors (J).Output_Fd, Buffer'Address,
|
||||
N := Read (Descriptors (D).Output_Fd, Buffer'Address,
|
||||
Buffer_Size);
|
||||
|
||||
-- Error or End of file
|
||||
@ -611,43 +663,46 @@ package body GNAT.Expect is
|
||||
if N <= 0 then
|
||||
-- ??? Note that ddd tries again up to three times
|
||||
-- in that case. See LiterateA.C:174
|
||||
raise Process_Died;
|
||||
|
||||
Descriptors (D).Input_Fd := Invalid_FD;
|
||||
Result := Expect_Process_Died;
|
||||
return;
|
||||
|
||||
else
|
||||
-- If there is no limit to the buffer size
|
||||
|
||||
if Descriptors (J).Buffer_Size = 0 then
|
||||
if Descriptors (D).Buffer_Size = 0 then
|
||||
|
||||
declare
|
||||
Tmp : String_Access := Descriptors (J).Buffer;
|
||||
Tmp : String_Access := Descriptors (D).Buffer;
|
||||
|
||||
begin
|
||||
if Tmp /= null then
|
||||
Descriptors (J).Buffer :=
|
||||
Descriptors (D).Buffer :=
|
||||
new String (1 .. Tmp'Length + N);
|
||||
Descriptors (J).Buffer (1 .. Tmp'Length) :=
|
||||
Descriptors (D).Buffer (1 .. Tmp'Length) :=
|
||||
Tmp.all;
|
||||
Descriptors (J).Buffer
|
||||
Descriptors (D).Buffer
|
||||
(Tmp'Length + 1 .. Tmp'Length + N) :=
|
||||
Buffer (1 .. N);
|
||||
Free (Tmp);
|
||||
Descriptors (J).Buffer_Index :=
|
||||
Descriptors (J).Buffer'Last;
|
||||
Descriptors (D).Buffer_Index :=
|
||||
Descriptors (D).Buffer'Last;
|
||||
|
||||
else
|
||||
Descriptors (J).Buffer :=
|
||||
Descriptors (D).Buffer :=
|
||||
new String (1 .. N);
|
||||
Descriptors (J).Buffer.all :=
|
||||
Descriptors (D).Buffer.all :=
|
||||
Buffer (1 .. N);
|
||||
Descriptors (J).Buffer_Index := N;
|
||||
Descriptors (D).Buffer_Index := N;
|
||||
end if;
|
||||
end;
|
||||
|
||||
else
|
||||
-- Add what we read to the buffer
|
||||
|
||||
if Descriptors (J).Buffer_Index + N >
|
||||
Descriptors (J).Buffer_Size
|
||||
if Descriptors (D).Buffer_Index + N >
|
||||
Descriptors (D).Buffer_Size
|
||||
then
|
||||
-- If the user wants to know when we have
|
||||
-- read more than the buffer can contain.
|
||||
@ -660,33 +715,33 @@ package body GNAT.Expect is
|
||||
-- Keep as much as possible from the buffer,
|
||||
-- and forget old characters.
|
||||
|
||||
Descriptors (J).Buffer
|
||||
(1 .. Descriptors (J).Buffer_Size - N) :=
|
||||
Descriptors (J).Buffer
|
||||
(N - Descriptors (J).Buffer_Size +
|
||||
Descriptors (J).Buffer_Index + 1 ..
|
||||
Descriptors (J).Buffer_Index);
|
||||
Descriptors (J).Buffer_Index :=
|
||||
Descriptors (J).Buffer_Size - N;
|
||||
Descriptors (D).Buffer
|
||||
(1 .. Descriptors (D).Buffer_Size - N) :=
|
||||
Descriptors (D).Buffer
|
||||
(N - Descriptors (D).Buffer_Size +
|
||||
Descriptors (D).Buffer_Index + 1 ..
|
||||
Descriptors (D).Buffer_Index);
|
||||
Descriptors (D).Buffer_Index :=
|
||||
Descriptors (D).Buffer_Size - N;
|
||||
end if;
|
||||
|
||||
-- Keep what we read in the buffer
|
||||
|
||||
Descriptors (J).Buffer
|
||||
(Descriptors (J).Buffer_Index + 1 ..
|
||||
Descriptors (J).Buffer_Index + N) :=
|
||||
Descriptors (D).Buffer
|
||||
(Descriptors (D).Buffer_Index + 1 ..
|
||||
Descriptors (D).Buffer_Index + N) :=
|
||||
Buffer (1 .. N);
|
||||
Descriptors (J).Buffer_Index :=
|
||||
Descriptors (J).Buffer_Index + N;
|
||||
Descriptors (D).Buffer_Index :=
|
||||
Descriptors (D).Buffer_Index + N;
|
||||
end if;
|
||||
|
||||
-- Call each of the output filter with what we
|
||||
-- read.
|
||||
|
||||
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;
|
||||
end if;
|
||||
end if;
|
||||
@ -1062,6 +1117,13 @@ package body GNAT.Expect is
|
||||
|
||||
Expect_Internal (Descriptors, Result,
|
||||
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;
|
||||
|
||||
-- Empty the buffer
|
||||
|
||||
@ -7710,6 +7710,7 @@ package body Sem_Ch3 is
|
||||
Set_Ekind (D_Minal, E_In_Parameter);
|
||||
Set_Mechanism (D_Minal, Default_Mechanism);
|
||||
Set_Etype (D_Minal, Etype (Discrim));
|
||||
Set_Scope (D_Minal, Current_Scope);
|
||||
|
||||
Set_Discriminal (Discrim, D_Minal);
|
||||
Set_Discriminal_Link (D_Minal, Discrim);
|
||||
@ -7726,6 +7727,7 @@ package body Sem_Ch3 is
|
||||
Set_Ekind (CR_Disc, E_In_Parameter);
|
||||
Set_Mechanism (CR_Disc, Default_Mechanism);
|
||||
Set_Etype (CR_Disc, Etype (Discrim));
|
||||
Set_Scope (CR_Disc, Current_Scope);
|
||||
Set_Discriminal_Link (CR_Disc, Discrim);
|
||||
Set_CR_Discriminant (Discrim, CR_Disc);
|
||||
end if;
|
||||
|
||||
@ -4799,6 +4799,24 @@ package body Sem_Eval is
|
||||
Typ1 : Entity_Id := Empty;
|
||||
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
|
||||
if Nkind (Call) /= N_Function_Call
|
||||
or else Nkind (Name (Call)) /= N_Expanded_Name
|
||||
@ -4845,6 +4863,20 @@ package body Sem_Eval is
|
||||
if No (Typ1) then
|
||||
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
|
||||
-- More than one type of the proper class declared in P
|
||||
|
||||
|
||||
@ -9567,6 +9567,7 @@ package body Sem_Res is
|
||||
It : Interp;
|
||||
It1 : Interp;
|
||||
N1 : Entity_Id;
|
||||
T1 : Entity_Id;
|
||||
|
||||
begin
|
||||
-- Remove procedure calls, which syntactically cannot appear in
|
||||
@ -9623,16 +9624,30 @@ package body Sem_Res is
|
||||
|
||||
if Present (It.Typ) then
|
||||
N1 := It1.Nam;
|
||||
T1 := It1.Typ;
|
||||
It1 := Disambiguate (Operand, I1, I, Any_Type);
|
||||
|
||||
if It1 = No_Interp then
|
||||
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
|
||||
("\\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
|
||||
("\\possible interpretation#!", Operand);
|
||||
|
||||
|
||||
@ -3082,7 +3082,6 @@ package body Sem_Util is
|
||||
Disc := First_Discriminant (Tsk);
|
||||
while Present (Disc) loop
|
||||
if Chars (Disc) = Chars (Spec_Discriminant) then
|
||||
Set_Scope (Discriminal (Disc), Tsk);
|
||||
return Discriminal (Disc);
|
||||
end if;
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user