diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 22 | ||||
| -rw-r--r-- | gcc/ada/a-direct.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/g-trasym.adb | 4 | ||||
| -rwxr-xr-x | gcc/ada/s-os_lib.adb | 58 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 46 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 40 |
6 files changed, 134 insertions, 39 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e49b992..cde186e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2009-04-20 Javier Miranda <miranda@adacore.com> + + * sem_disp.adb (Find_Dispatching_Type): For subprograms internally + generated by derivations of tagged types use the aliased subprogram a + reference to locate their controlling type. + +2009-04-20 Tristan Gingold <gingold@adacore.com> + + * g-trasym.adb: Set size of result buffer before calling + convert_address. + +2009-04-20 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Valid_Candidate): When checking whether a prefixed call + to a function returning an array can be interpreted as a call with + defaulted parameters whose result is indexed, take into account the + types of all the indices of the array result type. + +2009-04-20 Pascal Obry <obry@adacore.com> + + * a-direct.adb, s-os_lib.adb: Minor reformatting. + 2009-04-20 Ed Schonberg <schonberg@adacore.com> * sem_ch8.adb (Analyze_Object_Renaming): Proper checks on incorrect diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb index db9ef9f..db40b8c 100644 --- a/gcc/ada/a-direct.adb +++ b/gcc/ada/a-direct.adb @@ -1154,8 +1154,7 @@ package body Ada.Directories is end Simple_Name; function Simple_Name - (Directory_Entry : Directory_Entry_Type) return String - is + (Directory_Entry : Directory_Entry_Type) return String is begin -- First, the invalid case diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb index 917e478..6b04800 100644 --- a/gcc/ada/g-trasym.adb +++ b/gcc/ada/g-trasym.adb @@ -77,7 +77,8 @@ package body GNAT.Traceback.Symbolic is -- This is the procedure version of the Ada aware addr2line. It places -- in BUF a string representing the symbolic translation of the N_ADDRS -- raw addresses provided in ADDRS, looked up in debug information from - -- FILENAME. LEN is filled with the result length. + -- FILENAME. LEN points to an integer which contains the size of the + -- BUF buffer at input and the result length at output. -- -- This procedure is provided by libaddr2line on targets that support -- it. A dummy version is in adaint.c for other targets so that build @@ -125,6 +126,7 @@ package body GNAT.Traceback.Symbolic is end if; if Exename /= System.Null_Address then + Len := Res'Length; convert_addresses (Exename, Traceback'Address, Traceback'Length, Res (1)'Address, Len'Address); diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index 163cfbf..41d1077 100755 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1833,8 +1833,8 @@ package body System.OS_Lib is -- By default, the drive letter on Windows is in upper case - if On_Windows and then Path_Len >= 2 and then - Buffer (2) = ':' + if On_Windows and then Path_Len >= 2 + and then Buffer (2) = ':' then System.Case_Util.To_Upper (Buffer (1 .. 1)); end if; @@ -1906,31 +1906,41 @@ package body System.OS_Lib is -- it may have multiple equivalences and if resolved we will only -- get the first one. - -- On Windows, if we have an absolute path starting with a directory - -- separator, we need to have the drive letter appended in front. + if On_Windows then - -- On Windows, Get_Current_Dir will return a suitable directory - -- name (path starting with a drive letter on Windows). So we take this - -- drive letter and prepend it to the current path. + -- On Windows, if we have an absolute path starting with a directory + -- separator, we need to have the drive letter appended in front. - if On_Windows - and then Path_Buffer (1) = Directory_Separator - and then Path_Buffer (2) /= Directory_Separator - then - declare - Cur_Dir : constant String := Get_Directory (""); - -- Get the current directory to get the drive letter + -- On Windows, Get_Current_Dir will return a suitable directory name + -- (path starting with a drive letter on Windows). So we take this + -- drive letter and prepend it to the current path. - begin - if Cur_Dir'Length > 2 - and then Cur_Dir (Cur_Dir'First + 1) = ':' - then - Path_Buffer (3 .. End_Path + 2) := Path_Buffer (1 .. End_Path); - Path_Buffer (1 .. 2) := - Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); - End_Path := End_Path + 2; - end if; - end; + if Path_Buffer (1) = Directory_Separator + and then Path_Buffer (2) /= Directory_Separator + then + declare + Cur_Dir : constant String := Get_Directory (""); + -- Get the current directory to get the drive letter + + begin + if Cur_Dir'Length > 2 + and then Cur_Dir (Cur_Dir'First + 1) = ':' + then + Path_Buffer (3 .. End_Path + 2) := + Path_Buffer (1 .. End_Path); + Path_Buffer (1 .. 2) := + Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); + End_Path := End_Path + 2; + end if; + end; + + -- We have a drive letter, ensure it is upper-case + + elsif Path_Buffer (1) in 'a' .. 'z' + and then Path_Buffer (2) = ':' + then + System.Case_Util.To_Upper (Path_Buffer (1 .. 1)); + end if; end if; -- On Windows, remove all double-quotes that are possibly part of the diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index e572f56..d86cfd4 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5829,6 +5829,7 @@ package body Sem_Ch4 is Call : Node_Id; Subp : Entity_Id) return Entity_Id is + Arr_Type : Entity_Id; Comp_Type : Entity_Id; begin @@ -5844,6 +5845,7 @@ package body Sem_Ch4 is -- If the call may be an indexed call, retrieve component type of -- resulting expression, and add possible interpretation. + Arr_Type := Empty; Comp_Type := Empty; if Nkind (Call) = N_Function_Call @@ -5851,19 +5853,51 @@ package body Sem_Ch4 is and then Needs_One_Actual (Subp) then if Is_Array_Type (Etype (Subp)) then - Comp_Type := Component_Type (Etype (Subp)); + Arr_Type := Etype (Subp); elsif Is_Access_Type (Etype (Subp)) and then Is_Array_Type (Designated_Type (Etype (Subp))) then - Comp_Type := Component_Type (Designated_Type (Etype (Subp))); + Arr_Type := Designated_Type (Etype (Subp)); end if; end if; - if Present (Comp_Type) - and then Etype (Subprog) /= Comp_Type - then - Add_One_Interp (Subprog, Subp, Comp_Type); + if Present (Arr_Type) then + + -- Verify that the actuals (excluding the object) + -- match the types of the indices. + + declare + Actual : Node_Id; + Index : Node_Id; + + begin + Actual := Next (First_Actual (Call)); + Index := First_Index (Arr_Type); + + while Present (Actual) and then Present (Index) loop + if not Has_Compatible_Type (Actual, Etype (Index)) then + Arr_Type := Empty; + exit; + end if; + + Next_Actual (Actual); + Next_Index (Index); + end loop; + + if No (Actual) + and then No (Index) + and then Present (Arr_Type) + then + Comp_Type := Component_Type (Arr_Type); + end if; + end; + + if Present (Comp_Type) + and then Etype (Subprog) /= Comp_Type + then + Add_One_Interp (Subprog, Subp, Comp_Type); + end if; end if; if Etype (Call) /= Any_Type then diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 576ecbc..33044b3 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -1395,6 +1395,7 @@ package body Sem_Disp is --------------------------- function Find_Dispatching_Type (Subp : Entity_Id) return Entity_Id is + A_Formal : Entity_Id; Formal : Entity_Id; Ctrl_Type : Entity_Id; @@ -1402,6 +1403,37 @@ package body Sem_Disp is if Present (DTC_Entity (Subp)) then return Scope (DTC_Entity (Subp)); + -- For subprograms internally generated by derivations of tagged types + -- use the alias subprogram as a reference to locate the dispatching + -- type of Subp + + elsif not Comes_From_Source (Subp) + and then Present (Alias (Subp)) + and then Is_Dispatching_Operation (Alias (Subp)) + then + if Ekind (Alias (Subp)) = E_Function + and then Has_Controlling_Result (Alias (Subp)) + then + return Check_Controlling_Type (Etype (Subp), Subp); + + else + Formal := First_Formal (Subp); + A_Formal := First_Formal (Alias (Subp)); + while Present (A_Formal) loop + if Is_Controlling_Formal (A_Formal) then + return Check_Controlling_Type (Etype (Formal), Subp); + end if; + + Next_Formal (Formal); + Next_Formal (A_Formal); + end loop; + + pragma Assert (False); + return Empty; + end if; + + -- General case + else Formal := First_Formal (Subp); while Present (Formal) loop @@ -1414,14 +1446,10 @@ package body Sem_Disp is Next_Formal (Formal); end loop; - -- The subprogram may also be dispatching on result + -- The subprogram may also be dispatching on result if Present (Etype (Subp)) then - Ctrl_Type := Check_Controlling_Type (Etype (Subp), Subp); - - if Present (Ctrl_Type) then - return Ctrl_Type; - end if; + return Check_Controlling_Type (Etype (Subp), Subp); end if; end if; |