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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@146411 138bc75d-0d04-0410-961f-82ee72b054a4

6 files changed, 134 insertions, 39 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index e49b9926966..cde186e6a6a 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 db9ef9f7c51..db40b8c85be 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 917e47855fb..6b048001dfa 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 163cfbf9230..41d1077c2c0 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 e572f56905b..d86cfd47398 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 576ecbc701c..33044b3a810 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;