diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e9b3374fe4e..fcc8c886248 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,24 @@ +2010-06-22 Gary Dismukes + + * 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 + + * 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 + + * 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 * sem_eval.adb (Find_Universal_Operator_Type): New diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb index d57093c28d1..d92e1e7783e 100644 --- a/gcc/ada/g-expect-vms.adb +++ b/gcc/ada/g-expect-vms.adb @@ -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=, 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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 27cb478e72b..f98b3b1944c 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 1d9e0f6cd89..fb17144b668 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -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 diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index bf00a976bfc..fcf5a2c914a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -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); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 340e8fee07f..04f8341f2ad 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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;