[Ada] AI-252

Arnaud Charlet charlet@adacore.com
Mon Sep 5 08:43:00 GMT 2005


Tested on i686-linux, committed on HEAD

Ongoing work for AI-252.
This patch is a series of optimizations on the code that analyzes calls
written using object notation. Previous code created multiple copies of
the actuals in the call, for each interpretation of the operation. This
was both expensive and error-prone, in the presence of overloaded actuals
whose own interpretations had to be propagated to each copy. Finally,
the code did not complete the resolution of the first actual, i.e. the
prefix of the call.

The transformation of a selected component into a call depends on the
context. If the unanalyzed context is of the form  Obj.F (X), the parent
node is an indexed component, and the intended rewriting is as the call
F(Obj, X).  If the context has the form V (Obj.F), then the rewriting is
simply V (F(Obj)). The check to distinguish these two cases was done for
parent nodes that were calls, but the corresponding check was missing for
the case of indexed components.
The following must compile quietly:

package p is
   type T is tagged null record;
   function Value (X : T) return integer;
end;
with P; use P;
procedure Try is
  Thing: T;
  Table : Array (1..10) of boolean := (others => false);
begin
  if Table (Thing.Value) then null; end if;
end;

2005-09-01  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_ch4.adb (Transform_Object_Operation): In a context off the form
	V (Obj.F), the rewriting does not involve the indexed component, but
	only the selected component itself.
	Do not apply the transformation if the analyzed node is an actual of a
	call to another subprogram.
	(Complete_Object_Operation): Retain the entity of the
	dispatching operation in the selector of the rewritten node. The
	entity will be used in the expansion of dispatching selects.
	(Analyze_One_Call): Improve location of the error message associated
	with interface.
	(Analyze_Selected_Component): No need to resolve prefix when it is a
	function call, resolution is done when parent node is resolved, as
	usual.
	(Analyze_One_Call): Add a flag to suppress analysis of the first actual,
	when attempting to resolve a call transformed from its object notation.
	(Try_Object_Operation, Transform_Object_Operastion): Avoid makind copies
	of the argument list for each interpretation of the operation.
	(Try_Object_Operation): The designated type of an access parameter may
	be an incomplete type obtained through a limited_with clause, in which
	case the primitive operations of the type are retrieved from its full
	view.
	(Analyze_Call): If this is an indirect call, and the return type of the
	access_to_subprogram is incomplete, use its full view if available.

-------------- next part --------------
Index: sem_ch4.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/sem_ch4.adb,v
retrieving revision 1.43
diff -u -p -r1.43 sem_ch4.adb
--- sem_ch4.adb	7 Jul 2005 09:46:46 -0000	1.43
+++ sem_ch4.adb	5 Sep 2005 07:31:21 -0000
@@ -25,7 +25,6 @@
 ------------------------------------------------------------------------------
 
 with Atree;    use Atree;
-with Checks;   use Checks;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
@@ -97,10 +96,11 @@ package body Sem_Ch4 is
    --  arguments, list possible interpretations.
 
    procedure Analyze_One_Call
-      (N       : Node_Id;
-       Nam     : Entity_Id;
-       Report  : Boolean;
-       Success : out Boolean);
+      (N          : Node_Id;
+       Nam        : Entity_Id;
+       Report     : Boolean;
+       Success    : out Boolean;
+       Skip_First : Boolean := False);
    --  Check one interpretation of an overloaded subprogram name for
    --  compatibility with the types of the actuals in a call. If there is a
    --  single interpretation which does not match, post error if Report is
@@ -111,6 +111,13 @@ package body Sem_Ch4 is
    --  subprogram type constructed for an access_to_subprogram. If the actuals
    --  are compatible with Nam, then Nam is added to the list of candidate
    --  interpretations for N, and Success is set to True.
+   --
+   --  The flag Skip_First is used when analyzing a call that was rewritten
+   --  from object notation. In this case the first actual may have to receive
+   --  an explicit dereference, depending on the first formal of the operation
+   --  being called. The caller will have verified that the object is legal
+   --  for the call. If the remaining parameters match, the first parameter
+   --  will rewritten as a dereference if needed, prior to completing analysis.
 
    procedure Check_Misspelled_Selector
      (Prefix : Entity_Id;
@@ -538,15 +545,6 @@ package body Sem_Ch4 is
          Check_Restriction (No_Local_Allocators, N);
       end if;
 
-      --  Ada 2005 (AI-231): Static checks
-
-      if Ada_Version >= Ada_05
-        and then (Null_Exclusion_Present (N)
-                    or else Can_Never_Be_Null (Etype (N)))
-      then
-         Null_Exclusion_Static_Checks (N);
-      end if;
-
       if Serious_Errors_Detected > Sav_Errs then
          Set_Error_Posted (N);
          Set_Etype (N, Any_Type);
@@ -780,6 +778,20 @@ package body Sem_Ch4 is
 
          Analyze_One_Call (N, Nam_Ent, True, Success);
 
+         --  If this is an indirect call, the return type of the access_to
+         --  subprogram may be an incomplete type. At the point of the call,
+         --  use the full type if available, and at the same time update
+         --  the return type of the access_to_subprogram.
+
+         if Success
+           and then  Nkind (Nam) = N_Explicit_Dereference
+           and then Ekind (Etype (N)) = E_Incomplete_Type
+           and then Present (Full_View (Etype (N)))
+         then
+            Set_Etype (N, Full_View (Etype (N)));
+            Set_Etype (Nam_Ent, Etype (N));
+         end if;
+
       else
          --  An overloaded selected component must denote overloaded
          --  operations of a concurrent type. The interpretations are
@@ -1918,10 +1930,11 @@ package body Sem_Ch4 is
    ----------------------
 
    procedure Analyze_One_Call
-      (N       : Node_Id;
-       Nam     : Entity_Id;
-       Report  : Boolean;
-       Success : out Boolean)
+      (N          : Node_Id;
+       Nam        : Entity_Id;
+       Report     : Boolean;
+       Success    : out Boolean;
+       Skip_First : Boolean := False)
    is
       Actuals    : constant List_Id   := Parameter_Associations (N);
       Prev_T     : constant Entity_Id := Etype (N);
@@ -2104,6 +2117,16 @@ package body Sem_Ch4 is
 
          Actual := First_Actual (N);
          Formal := First_Formal (Nam);
+
+         --  If we are analyzing a call rewritten from object notation,
+         --  skip first actual, which may be rewritten later as an
+         --  explicit dereference.
+
+         if Skip_First then
+            Next_Actual (Actual);
+            Next_Formal (Formal);
+         end if;
+
          while Present (Actual) and then Present (Formal) loop
             if Nkind (Parent (Actual)) /= N_Parameter_Association
               or else Chars (Selector_Name (Parent (Actual))) = Chars (Formal)
@@ -2134,10 +2157,8 @@ package body Sem_Ch4 is
                                       (Typ   => Etype (Actual),
                                        Iface => Etype (Etype (Formal)))
                      then
-                        Error_Msg_Name_1 := Chars (Actual);
-                        Error_Msg_Name_2 := Chars (Etype (Etype (Formal)));
                         Error_Msg_NE
-                          ("(Ada 2005) % does not implement interface %",
+                          ("(Ada 2005) does not implement interface }",
                            Actual, Etype (Etype (Formal)));
                      end if;
 
@@ -2557,17 +2578,6 @@ package body Sem_Ch4 is
          return;
 
       else
-         --  Function calls that are prefixes of selected components must be
-         --  fully resolved in case we need to build an actual subtype, or
-         --  do some other operation requiring a fully resolved prefix.
-
-         --  Note: Resolving all Nkinds of nodes here doesn't work.
-         --  (Breaks 2129-008) ???.
-
-         if Nkind (Name) = N_Function_Call then
-            Resolve (Name);
-         end if;
-
          Prefix_Type := Etype (Name);
       end if;
 
@@ -4845,9 +4855,7 @@ package body Sem_Ch4 is
       Subprog         : constant Node_Id    := Selector_Name (N);
 
       Actual          : Node_Id;
-      Call_Node       : Node_Id;
-      Call_Node_Case  : Node_Id := Empty;
-      First_Actual    : Node_Id;
+      New_Call_Node  :  Node_Id := Empty;
       Node_To_Replace : Node_Id;
       Obj_Type        : Entity_Id := Etype (Obj);
 
@@ -4855,31 +4863,30 @@ package body Sem_Ch4 is
         (Call_Node       : Node_Id;
          Node_To_Replace : Node_Id;
          Subprog         : Node_Id);
-      --  Set Subprog as the name of Call_Node, replace Node_To_Replace with
-      --  Call_Node and reanalyze Node_To_Replace.
+      --  Make Subprog the name of Call_Node, replace Node_To_Replace with
+      --  Call_Node, insert the object (or its dereference) as the first actual
+      --  in the call, and complete the analysis of the call.
 
       procedure Transform_Object_Operation
         (Call_Node       : out Node_Id;
-         First_Actual    : Node_Id;
          Node_To_Replace : out Node_Id;
          Subprog         : Node_Id);
-      --  Transform Object.Operation (...) to Operation (Object, ...)
-      --  Call_Node is the resulting subprogram call node, First_Actual is
-      --  either the object Obj or an explicit dereference of Obj in certain
-      --  cases, Node_To_Replace is either N or the parent of N, and Subprog
-      --  is the subprogram we are trying to match.
+      --  Transform Obj.Operation (X, Y,,) into Operation (Obj, X, Y ..)
+      --  Call_Node is the resulting subprogram call,
+      --  Node_To_Replace is either N or the parent of N, and Subprog
+      --  is a reference to the subprogram we are trying to match.
 
       function Try_Class_Wide_Operation
         (Call_Node       : Node_Id;
          Node_To_Replace : Node_Id) return Boolean;
-      --  Traverse all the ancestor types looking for a class-wide subprogram
-      --  that matches Subprog.
+      --  Traverse all ancestor types looking for a class-wide subprogram
+      --  for which the current operation is a valid non-dispatching call.
 
       function Try_Primitive_Operation
         (Call_Node       : Node_Id;
          Node_To_Replace : Node_Id) return Boolean;
-      --  Traverse the list of primitive subprograms looking for a subprogram
-      --  than matches Subprog.
+      --  Traverse the list of primitive subprograms looking for a dispatching
+      --  operation for which the current node is a valid call .
 
       -------------------------------
       -- Complete_Object_Operation --
@@ -4890,9 +4897,30 @@ package body Sem_Ch4 is
          Node_To_Replace : Node_Id;
          Subprog         : Node_Id)
       is
+         First_Actual : Node_Id;
+
       begin
-         Set_Name (Call_Node, New_Copy_Tree (Subprog));
-         Set_Analyzed (Call_Node, False);
+         First_Actual := First (Parameter_Associations (Call_Node));
+         Set_Name (Call_Node, Subprog);
+
+         if Nkind (N) = N_Selected_Component
+           and then not Inside_A_Generic
+         then
+            Set_Entity (Selector_Name (N), Entity (Subprog));
+         end if;
+
+         --  If need be, rewrite first actual as an explicit dereference
+
+         if not Is_Access_Type (Etype (First_Formal (Entity (Subprog))))
+           and then Is_Access_Type (Etype (Obj))
+         then
+            Rewrite (First_Actual,
+              Make_Explicit_Dereference (Sloc (Obj), Obj));
+            Analyze (First_Actual);
+         else
+            Rewrite (First_Actual, Obj);
+         end if;
+
          Rewrite (Node_To_Replace, Call_Node);
          Analyze (Node_To_Replace);
       end Complete_Object_Operation;
@@ -4903,51 +4931,45 @@ package body Sem_Ch4 is
 
       procedure Transform_Object_Operation
         (Call_Node       : out Node_Id;
-         First_Actual    : Node_Id;
          Node_To_Replace : out Node_Id;
          Subprog         : Node_Id)
       is
-         Actuals     : List_Id;
          Parent_Node : constant Node_Id := Parent (N);
 
+         Dummy : constant Node_Id := New_Copy (Obj);
+         --  Placeholder used as a first parameter in the call, replaced
+         --  eventually by the proper object.
+
+         Actuals : List_Id;
+         Actual  : Node_Id;
+
       begin
-         Actuals := New_List (New_Copy_Tree (First_Actual));
+         --  Common case covering 1) Call to a procedure and 2) Call to a
+         --  function that has some additional actuals.
 
          if (Nkind (Parent_Node) = N_Function_Call
                or else
              Nkind (Parent_Node) = N_Procedure_Call_Statement)
 
-            --  Avoid recursive calls
+            --  N is a selected component node containing the name of the
+            --  subprogram. If N is not the name of the parent node we must
+            --  not replace the parent node by the new construct. This case
+            --  occurs when N is a parameterless call to a subprogram that
+            --  is an actual parameter of a call to another subprogram. For
+            --  example:
+            --            Some_Subprogram (..., Obj.Operation, ...)
 
-           and then N /= First (Parameter_Associations (Parent_Node))
+            and then Name (Parent_Node) = N
          then
             Node_To_Replace := Parent_Node;
 
-            --  Copy list of actuals in full before attempting to resolve call.
-            --  This is necessary to ensure that the chaining of named actuals
-            --  that happens during matching is done on a separate copy.
-
-            declare
-               Actual : Node_Id;
-            begin
-               Actual := First (Parameter_Associations (Parent_Node));
-               while Present (Actual) loop
-                  declare
-                     New_Actual : constant Node_Id := New_Copy_Tree (Actual);
-
-                  begin
-                     Append (New_Actual, Actuals);
+            Actuals := Parameter_Associations (Parent_Node);
 
-                     if Nkind (Actual) = N_Function_Call
-                       and then Is_Overloaded (Name (Actual))
-                     then
-                        Save_Interps (Name (Actual), Name (New_Actual));
-                     end if;
-                  end;
-
-                  Next (Actual);
-               end loop;
-            end;
+            if Present (Actuals) then
+               Prepend (Dummy, Actuals);
+            else
+               Actuals := New_List (Dummy);
+            end if;
 
             if Nkind (Parent_Node) = N_Procedure_Call_Statement then
                Call_Node :=
@@ -4956,8 +4978,6 @@ package body Sem_Ch4 is
                    Parameter_Associations => Actuals);
 
             else
-               pragma Assert (Nkind (Parent_Node) = N_Function_Call);
-
                Call_Node :=
                  Make_Function_Call (Loc,
                    Name => New_Copy_Tree (Subprog),
@@ -4965,31 +4985,30 @@ package body Sem_Ch4 is
 
             end if;
 
-         --  Before analysis, the function call appears as an
-         --  indexed component.
+         --  Before analysis, the function call appears as an indexed component
+         --  if there are no named associations.
 
-         elsif Nkind (Parent_Node) =  N_Indexed_Component then
+         elsif Nkind (Parent_Node) =  N_Indexed_Component
+           and then N = Prefix (Parent_Node)
+         then
             Node_To_Replace := Parent_Node;
 
-            declare
-               Actual : Node_Id;
-               New_Act : Node_Id;
-            begin
-               Actual := First (Expressions (Parent_Node));
-               while Present (Actual) loop
-                  New_Act := New_Copy_Tree (Actual);
-                  Analyze (New_Act);
-                  Append (New_Act, Actuals);
-                  Next (Actual);
-               end loop;
-            end;
+            Actuals := Expressions (Parent_Node);
+
+            Actual := First (Actuals);
+            while Present (Actual) loop
+               Analyze (Actual);
+               Next (Actual);
+            end loop;
+
+            Prepend (Dummy, Actuals);
 
             Call_Node :=
                Make_Function_Call (Loc,
                  Name => New_Copy_Tree (Subprog),
                  Parameter_Associations => Actuals);
 
-         --  Parameterless call
+         --  Parameterless call:  Obj.F is rewritten as F (Obj)
 
          else
             Node_To_Replace := N;
@@ -4997,7 +5016,7 @@ package body Sem_Ch4 is
             Call_Node :=
                Make_Function_Call (Loc,
                  Name => New_Copy_Tree (Subprog),
-                 Parameter_Associations => Actuals);
+                 Parameter_Associations => New_List (Dummy));
          end if;
       end Transform_Object_Operation;
 
@@ -5010,16 +5029,20 @@ package body Sem_Ch4 is
          Node_To_Replace : Node_Id) return Boolean
       is
          Anc_Type : Entity_Id;
-         Dummy    : Node_Id;
          Hom      : Entity_Id;
          Hom_Ref  : Node_Id;
          Success  : Boolean;
 
       begin
-         --  Loop through ancestor types, traverse their homonym chains and
-         --  gather all interpretations of the subprogram.
+         --  Loop through ancestor types, traverse the homonym chain of the
+         --  subprogram, and try out those homonyms whose first formal has the
+         --  class-wide type of the ancestor.
+
+         --  Should we verify that it is declared in the same package as the
+         --  ancestor type ???
 
          Anc_Type := Obj_Type;
+
          loop
             Hom := Current_Entity (Subprog);
             while Present (Hom) loop
@@ -5032,79 +5055,42 @@ package body Sem_Ch4 is
                then
                   Hom_Ref := New_Reference_To (Hom, Loc);
 
-                  --  When both the type of the object and the type of the
-                  --  first formal of the primitive operation are tagged
-                  --  access types, we use a node with the object as first
-                  --  actual.
-
-                  if Is_Access_Type (Etype (Obj))
-                    and then Ekind (Etype (First_Formal (Hom))) =
-                               E_Anonymous_Access_Type
-                  then
-                     --  Allocate the node only once
-
-                     if not Present (Call_Node_Case) then
-                        Analyze_Expression (Obj);
-                        Set_Analyzed       (Obj);
-
-                        Transform_Object_Operation (
-                          Call_Node       => Call_Node_Case,
-                          First_Actual    => Obj,
-                          Node_To_Replace => Dummy,
-                          Subprog         => Subprog);
-
-                        Set_Etype (Call_Node_Case, Any_Type);
-                        Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
-                     end if;
+                  Set_Etype (Call_Node, Any_Type);
+                  Set_Parent (Call_Node, Parent (Node_To_Replace));
 
-                     Set_Name (Call_Node_Case, Hom_Ref);
+                  Set_Name (Call_Node, Hom_Ref);
 
-                     Analyze_One_Call (
-                       N       => Call_Node_Case,
-                       Nam     => Hom,
-                       Report  => False,
-                       Success => Success);
-
-                     if Success then
-                        Complete_Object_Operation (
-                          Call_Node       => Call_Node_Case,
-                          Node_To_Replace => Node_To_Replace,
-                          Subprog         => Hom_Ref);
+                  Analyze_One_Call
+                    (N          => Call_Node,
+                     Nam        => Hom,
+                     Report     => False,
+                     Success    => Success,
+                     Skip_First => True);
 
-                        return True;
-                     end if;
+                  if Success then
 
-                  --  ??? comment required
+                     --  Reformat into the proper call
 
-                  else
-                     Set_Name (Call_Node, Hom_Ref);
+                     Complete_Object_Operation
+                       (Call_Node       => Call_Node,
+                        Node_To_Replace => Node_To_Replace,
+                        Subprog         => Hom_Ref);
 
-                     Analyze_One_Call (
-                       N       => Call_Node,
-                       Nam     => Hom,
-                       Report  => False,
-                       Success => Success);
-
-                     if Success then
-                        Complete_Object_Operation (
-                          Call_Node       => Call_Node,
-                          Node_To_Replace => Node_To_Replace,
-                          Subprog         => Hom_Ref);
-
-                        return True;
-                     end if;
+                     return True;
                   end if;
                end if;
 
                Hom := Homonym (Hom);
             end loop;
 
-            --  Climb to ancestor type if there is one
+            --  Examine other ancestor types
 
             exit when Etype (Anc_Type) = Anc_Type;
             Anc_Type := Etype (Anc_Type);
          end loop;
 
+         --  Nothing matched
+
          return False;
       end Try_Class_Wide_Operation;
 
@@ -5116,12 +5102,44 @@ package body Sem_Ch4 is
         (Call_Node       : Node_Id;
          Node_To_Replace : Node_Id) return Boolean
       is
-         Dummy       : Node_Id;
          Elmt        : Elmt_Id;
          Prim_Op     : Entity_Id;
          Prim_Op_Ref : Node_Id;
          Success     : Boolean;
 
+         function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
+         --  Verify that the prefix, dereferenced if need be, is a valid
+         --  controlling argument in a call to Op. The remaining actuals
+         --  are checked in the subsequent call to Analyze_One_Call.
+
+         -----------------------------
+         -- Valid_First_Argument_Of --
+         -----------------------------
+
+         function Valid_First_Argument_Of (Op : Entity_Id) return Boolean is
+            Typ : constant Entity_Id := Etype (First_Formal (Op));
+
+         begin
+            --  Simple case
+
+            return Base_Type (Obj_Type) = Typ
+
+            --  Prefix can be dereferenced
+
+              or else
+                (Is_Access_Type (Obj_Type)
+                  and then Designated_Type (Obj_Type) = Typ)
+
+            --  Formal is an access parameter, for which the object
+            --  can provide an access.
+
+              or else
+                (Ekind (Typ) = E_Anonymous_Access_Type
+                  and then Designated_Type (Typ) = Obj_Type);
+         end Valid_First_Argument_Of;
+
+      --  Start of processing for Try_Primitive_Operation
+
       begin
          --  Look for the subprogram in the list of primitive operations
 
@@ -5131,69 +5149,29 @@ package body Sem_Ch4 is
 
             if Chars (Prim_Op) = Chars (Subprog)
               and then Present (First_Formal (Prim_Op))
+              and then Valid_First_Argument_Of (Prim_Op)
             then
                Prim_Op_Ref := New_Reference_To (Prim_Op, Loc);
 
-               --  When both the type of the object and the type of the first
-               --  formal of the primitive operation are tagged access types,
-               --  we use a node with the object as first actual.
-
-               if Is_Access_Type (Etype (Obj))
-                 and then Ekind (Etype (First_Formal (Prim_Op))) =
-                            E_Anonymous_Access_Type
-               then
-                  --  Allocate the node only once
-
-                  if not Present (Call_Node_Case) then
-                     Analyze_Expression (Obj);
-                     Set_Analyzed       (Obj);
-
-                     Transform_Object_Operation (
-                       Call_Node       => Call_Node_Case,
-                       First_Actual    => Obj,
-                       Node_To_Replace => Dummy,
-                       Subprog         => Subprog);
-
-                     Set_Etype (Call_Node_Case, Any_Type);
-                     Set_Parent (Call_Node_Case, Parent (Node_To_Replace));
-                  end if;
-
-                  Set_Name (Call_Node_Case, Prim_Op_Ref);
+               Set_Etype (Call_Node, Any_Type);
+               Set_Parent (Call_Node, Parent (Node_To_Replace));
 
-                  Analyze_One_Call (
-                    N       => Call_Node_Case,
-                    Nam     => Prim_Op,
-                    Report  => False,
-                    Success => Success);
+               Set_Name (Call_Node, Prim_Op_Ref);
 
-                  if Success then
-                     Complete_Object_Operation (
-                       Call_Node       => Call_Node_Case,
-                       Node_To_Replace => Node_To_Replace,
-                       Subprog         => Prim_Op_Ref);
-
-                     return True;
-                  end if;
-
-               --  Comment required ???
-
-               else
-                  Set_Name (Call_Node, Prim_Op_Ref);
+               Analyze_One_Call
+                 (N          => Call_Node,
+                  Nam        => Prim_Op,
+                  Report     => False,
+                  Success    => Success,
+                  Skip_First => True);
+
+               if Success then
+                  Complete_Object_Operation
+                    (Call_Node       => Call_Node,
+                     Node_To_Replace => Node_To_Replace,
+                     Subprog         => Prim_Op_Ref);
 
-                  Analyze_One_Call (
-                    N       => Call_Node,
-                    Nam     => Prim_Op,
-                    Report  => False,
-                    Success => Success);
-
-                  if Success then
-                     Complete_Object_Operation (
-                       Call_Node       => Call_Node,
-                       Node_To_Replace => Node_To_Replace,
-                       Subprog         => Prim_Op_Ref);
-
-                     return True;
-                  end if;
+                  return True;
                end if;
             end if;
 
@@ -5218,7 +5196,21 @@ package body Sem_Ch4 is
          Obj_Type := Etype (Class_Wide_Type (Obj_Type));
       end if;
 
-      --  Analyze the actuals in case of subprogram call
+      --  The type may have be obtained through a limited_with clause,
+      --  in which case the primitive operations are available on its
+      --  non-limited view.
+
+      if Ekind (Obj_Type) = E_Incomplete_Type
+        and then From_With_Type (Obj_Type)
+      then
+         Obj_Type := Non_Limited_View (Obj_Type);
+      end if;
+
+      if not Is_Tagged_Type (Obj_Type) then
+         return False;
+      end if;
+
+      --  Analyze the actuals if node is know to be a subprogram call
 
       if Is_Subprg_Call and then N = Name (Parent (N)) then
          Actual := First (Parameter_Associations (Parent (N)));
@@ -5228,38 +5220,28 @@ package body Sem_Ch4 is
          end loop;
       end if;
 
-      --  If the object is of an Access type, explicit dereference is
-      --  required.
+      Analyze_Expression (Obj);
 
-      if Is_Access_Type (Etype (Obj)) then
-         First_Actual :=
-           Make_Explicit_Dereference (Sloc (Obj), Obj);
-         Set_Etype (First_Actual, Obj_Type);
-      else
-         First_Actual := Obj;
-      end if;
-
-      Analyze_Expression (First_Actual);
-      Set_Analyzed       (First_Actual);
+      --  Build a subprogram call node, using a copy of Obj as its first
+      --  actual. This is a placeholder, to be replaced by an explicit
+      --  dereference when needed.
+
+      Transform_Object_Operation
+        (Call_Node       => New_Call_Node,
+         Node_To_Replace => Node_To_Replace,
+         Subprog         => Subprog);
 
-      --  Build a subprogram call node
-
-      Transform_Object_Operation (
-        Call_Node       => Call_Node,
-        First_Actual    => First_Actual,
-        Node_To_Replace => Node_To_Replace,
-        Subprog         => Subprog);
-
-      Set_Etype (Call_Node, Any_Type);
-      Set_Parent (Call_Node, Parent (Node_To_Replace));
+      Set_Etype (New_Call_Node, Any_Type);
+      Set_Parent (New_Call_Node, Parent (Node_To_Replace));
 
       return
          Try_Primitive_Operation
-           (Call_Node       => Call_Node,
+           (Call_Node       => New_Call_Node,
             Node_To_Replace => Node_To_Replace)
+
         or else
          Try_Class_Wide_Operation
-           (Call_Node       => Call_Node,
+           (Call_Node       => New_Call_Node,
             Node_To_Replace => Node_To_Replace);
    end Try_Object_Operation;
 


More information about the Gcc-patches mailing list