sem_ch8.ads, [...] (Find_Type, [...]): Use correct entity as denoted entity for…

sem_ch8.ads, [...] (Find_Type, [...]): Use correct entity as denoted entity for the selector of the rewritten node.

2007-08-14  Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.ads, sem_ch8.adb (Find_Type, case of a 'Base attribute
	reference): Use correct entity as denoted entity for the selector of
	the rewritten node.
	(Find_Direct_Name): Add comment about Generate_Reference incorrectly
	setting the Referenced_As_LHS flag for entities that are implicitly
	dereferenced.
	(Find_Type): If the type is an internally generated incomplete type,
	mark the full view as referenced, to prevent spurious warnings.
	(Find_Selected_Component, Has_Components): Handle properly non-limited
	views that are themselves incomplete types.
	Handle interfaces visible through limited-with clauses.
	(Analyze_Subprogram_Renaming): Disambiguate and set the entity of a
	subprogram generic actual for which we have generated a renaming.
	Warn when the renaming introduces a homonym of
	the renamed entity, and the renamed entity is directly visible.

From-SVN: r127446

gcc/ada/sem_ch8.adb

@@ -721,7 +721,7 @@ package body Sem_Ch8 is
             Set_Etype (Nam, T);
          end if;
 
-         --  Complete analysis of the subtype mark in any case, for ASIS use.
+         --  Complete analysis of the subtype mark in any case, for ASIS use
 
          if Present (Subtype_Mark (N)) then
             Find_Type (Subtype_Mark (N));
@@ -759,7 +759,7 @@ package body Sem_Ch8 is
            and then not Is_Access_Constant (Etype (Nam))
          then
             Error_Msg_N ("(Ada 2005): the renamed object is not "
-                         & "access-to-constant ('R'M 8.5.1(6))", N);
+                         & "access-to-constant (RM 8.5.1(6))", N);
          end if;
       end if;
 
@@ -872,7 +872,7 @@ package body Sem_Ch8 is
                      Error_Node);
                   Error_Msg_Sloc := Sloc (N);
                   Error_Msg_N
-                    ("\because of renaming at# ('R'M 8.5.4(4))", Error_Node);
+                    ("\because of renaming # (RM 8.5.4(4))", Error_Node);
 
                --  Ada 2005 (AI-423): Otherwise, the subtype of the object name
                --  shall exclude null.
@@ -881,7 +881,7 @@ package body Sem_Ch8 is
                  and then not Has_Null_Exclusion (Subtyp_Decl)
                then
                   Error_Msg_N
-                    ("`NOT NULL` required for subtype & ('R'M 8.5.1(4.6/2))",
+                    ("`NOT NULL` required for subtype & (RM 8.5.1(4.6/2))",
                      Defining_Identifier (Subtyp_Decl));
                end if;
             end if;
@@ -1544,7 +1544,7 @@ package body Sem_Ch8 is
                         Error_Msg_Sloc := Sloc (Hidden);
                         Error_Msg_N ("?default subprogram is resolved " &
                                      "in the generic declaration " &
-                                     "('R'M 12.6(17))", N);
+                                     "(RM 12.6(17))", N);
                         Error_Msg_NE ("\?and will not use & #", N, Hidden);
                      end if;
                   end;
@@ -1703,6 +1703,31 @@ package body Sem_Ch8 is
          return;
       end if;
 
+      --  Find the renamed entity that matches the given specification. Disable
+      --  Ada_83 because there is no requirement of full conformance between
+      --  renamed entity and new entity, even though the same circuit is used.
+
+      --  This is a bit of a kludge, which introduces a really irregular use of
+      --  Ada_Version[_Explicit]. Would be nice to find cleaner way to do this
+      --  ???
+
+      Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95);
+      Ada_Version_Explicit := Ada_Version;
+
+      if No (Old_S) then
+         Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
+
+         --  When the renamed subprogram is overloaded and used as an actual
+         --  of a generic, its entity is set to the first available homonym.
+         --  We must first disambiguate the name, then set the proper entity.
+
+         if Is_Actual
+           and then Is_Overloaded (Nam)
+         then
+            Set_Entity (Nam, Old_S);
+         end if;
+      end if;
+
       --  Most common case: subprogram renames subprogram. No body is generated
       --  in this case, so we must indicate the declaration is complete as is.
 
@@ -1712,30 +1737,21 @@ package body Sem_Ch8 is
          Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam)));
 
          --  Ada 2005 (AI-423): Check the consistency of null exclusions
-         --  between a subprogram and its renaming.
+         --  between a subprogram and its correct renaming.
 
-         if Ada_Version >= Ada_05 then
+         --  Note: the Any_Id check is a guard that prevents compiler crashes
+         --  when performing a null exclusion check between a renaming and a
+         --  renamed subprogram that has been found to be illegal.
+
+         if Ada_Version >= Ada_05
+           and then Entity (Nam) /= Any_Id
+         then
             Check_Null_Exclusion
               (Ren => New_S,
                Sub => Entity (Nam));
          end if;
       end if;
 
-      --  Find the renamed entity that matches the given specification. Disable
-      --  Ada_83 because there is no requirement of full conformance between
-      --  renamed entity and new entity, even though the same circuit is used.
-
-      --  This is a bit of a kludge, which introduces a really irregular use of
-      --  Ada_Version[_Explicit]. Would be nice to find cleaner way to do this
-      --  ???
-
-      Ada_Version := Ada_Version_Type'Max (Ada_Version, Ada_95);
-      Ada_Version_Explicit := Ada_Version;
-
-      if No (Old_S) then
-         Old_S := Find_Renamed_Entity (N, Name (N), New_S, Is_Actual);
-      end if;
-
       if Old_S /= Any_Id then
          if Is_Actual
            and then From_Default (N)
@@ -2035,6 +2051,25 @@ package body Sem_Ch8 is
              New_S, Old_S);
       end if;
 
+      --  Another warning or some utility: if the new subprogram as the same
+      --  name as the old one, the old one is not hidden by an outer homograph,
+      --  the new one is not a public symbol, and the old one is otherwise
+      --  directly visible, the renaming is superfluous.
+
+      if Chars (Old_S) = Chars (New_S)
+        and then Comes_From_Source (N)
+        and then Scope (Old_S) /= Standard_Standard
+        and then Warn_On_Redundant_Constructs
+        and then
+          (Is_Immediately_Visible (Old_S)
+            or else Is_Potentially_Use_Visible (Old_S))
+        and then Is_Overloadable (Current_Scope)
+        and then Chars (Current_Scope) /= Chars (Old_S)
+      then
+         Error_Msg_N
+          ("?redundant renaming, entity is directly visible", Name (N));
+      end if;
+
       Ada_Version := Save_AV;
       Ada_Version_Explicit := Save_AV_Exp;
    end Analyze_Subprogram_Renaming;
@@ -2372,7 +2407,7 @@ package body Sem_Ch8 is
              Handled_Statement_Sequence =>
                Make_Handled_Sequence_Of_Statements (Loc,
                    Statements => New_List (
-                     Make_Return_Statement (Loc,
+                     Make_Simple_Return_Statement (Loc,
                        Expression => Attr_Node))));
 
       --  Case of renaming a procedure
@@ -3421,11 +3456,11 @@ package body Sem_Ch8 is
          --  undefined reference.
 
          if not All_Errors_Mode then
-            Urefs.Increment_Last;
-            Urefs.Table (Urefs.Last).Node := N;
-            Urefs.Table (Urefs.Last).Err  := Emsg;
-            Urefs.Table (Urefs.Last).Nvis := Nvis;
-            Urefs.Table (Urefs.Last).Loc  := Sloc (N);
+            Urefs.Append (
+              (Node => N,
+               Err  => Emsg,
+               Nvis => Nvis,
+               Loc  => Sloc (N)));
          end if;
 
          Msg := True;
@@ -3804,7 +3839,7 @@ package body Sem_Ch8 is
          --  to the discriminant in the initialization procedure.
 
          else
-            --  Entity is unambiguous, indicate that it is referenced here One
+            --  Entity is unambiguous, indicate that it is referenced here. One
             --  slightly odd case is that we do not want to set the Referenced
             --  flag if the entity is a label, and the identifier is the label
             --  in the source, since this is not a reference from the point of
@@ -3819,7 +3854,14 @@ package body Sem_Ch8 is
                   Set_Referenced (E, R);
                end;
 
-            --  Normal case, not a label. Generate reference
+            --  Normal case, not a label: generate reference
+
+            --  ??? It is too early to generate a reference here even if
+            --    the entity is unambiguous, because the tree is not
+            --    sufficiently typed at this point for Generate_Reference to
+            --    determine whether this reference modifies the denoted object
+            --    (because implicit derefences cannot be identified prior to
+            --    full type resolution).
 
             else
                Generate_Reference (E, N);
@@ -3938,6 +3980,8 @@ package body Sem_Ch8 is
             --  the scope, it is important to note that the limited view also
             --  has shadow entities associated nested packages. For this reason
             --  the correct scope of the entity is the scope of the real entity
+            --  The non-limited view may itself be incomplete, in which case
+            --  get the full view if available.
 
             elsif From_With_Type (Id)
               and then Is_Type (Id)
@@ -3945,7 +3989,7 @@ package body Sem_Ch8 is
               and then Present (Non_Limited_View (Id))
               and then Scope (Non_Limited_View (Id)) = P_Name
             then
-               Candidate        := Non_Limited_View (Id);
+               Candidate        := Get_Full_View (Non_Limited_View (Id));
                Is_New_Candidate := True;
 
             else
@@ -4706,6 +4750,8 @@ package body Sem_Ch8 is
          then
             --  Selected component of record. Type checking will validate
             --  name of selector.
+            --  ??? could we rewrite an implicit dereference into an explicit
+            --  one here?
 
             Analyze_Selected_Component (N);
 
@@ -4865,7 +4911,7 @@ package body Sem_Ch8 is
                then
                   Error_Msg_N
                     ("\dereference must not be of an incomplete type " &
-                       "('R'M 3.10.1)", P);
+                       "(RM 3.10.1)", P);
                end if;
 
             else
@@ -4899,10 +4945,9 @@ package body Sem_Ch8 is
 
       elsif Nkind (N) = N_Attribute_Reference then
 
-         --  Class attribute. This is only valid in Ada 95 mode, but we don't
-         --  do a check, since the tagged type referenced could only exist if
-         --  we were in 95 mode when it was declared (or, if we were in Ada
-         --  83 mode, then an error message would already have been issued).
+         --  Class attribute. This is not valid in Ada 83 mode, but we do not
+         --  need to enforce that at this point, since the declaration of the
+         --  tagged type in the prefix would have been flagged already.
 
          if Attribute_Name (N) = Name_Class then
             Check_Restriction (No_Dispatch, N);
@@ -4918,8 +4963,8 @@ package body Sem_Ch8 is
 
             T := Base_Type (Entity (Prefix (N)));
 
-            --  Case type is not known to be tagged. Its appearance in the
-            --  prefix of the 'Class attribute indicates that the full view
+            --  Case where type is not known to be tagged. Its appearance in
+            --  the prefix of the 'Class attribute indicates that the full view
             --  will be tagged.
 
             if not Is_Tagged_Type (T) then
@@ -4927,6 +4972,24 @@ package body Sem_Ch8 is
 
                   --  It is legal to denote the class type of an incomplete
                   --  type. The full type will have to be tagged, of course.
+                  --  In Ada2005 this usage is declared obsolescent, so we
+                  --  warn accordingly.
+
+                  --  ??? This test is temporarily disabled (always False)
+                  --  because it causes an unwanted warning on GNAT sources
+                  --  (built with -gnatg, which includes Warn_On_Obsolescent_
+                  --  Feature). Once this issue is cleared in the sources, it
+                  --  can be enabled.
+
+                  if not Is_Tagged_Type (T)
+                    and then Ada_Version >= Ada_05
+                    and then Warn_On_Obsolescent_Feature
+                    and then False
+                  then
+                     Error_Msg_N
+                       ("applying 'Class to an untagged imcomplete type"
+                         & " is an obsolescent feature  (RM J.11)", N);
+                  end if;
 
                   Set_Is_Tagged_Type (T);
                   Set_Primitive_Operations (T, New_Elmt_List);
@@ -5026,14 +5089,12 @@ package body Sem_Ch8 is
                if Nkind (Prefix (N)) = N_Expanded_Name then
                   Rewrite (N,
                      Make_Expanded_Name (Sloc (N),
-                       Chars     => Chars (Entity (N)),
-                       Prefix    => New_Copy (Prefix (Prefix (N))),
-                       Selector_Name =>
-                         New_Reference_To (Entity (N), Sloc (N))));
+                       Chars         => Chars (T),
+                       Prefix        => New_Copy (Prefix (Prefix (N))),
+                       Selector_Name => New_Reference_To (T, Sloc (N))));
 
                else
-                  Rewrite (N,
-                    New_Reference_To (Entity (N), Sloc (N)));
+                  Rewrite (N, New_Reference_To (T, Sloc (N)));
                end if;
 
                Set_Entity (N, T);
@@ -5078,8 +5139,32 @@ package body Sem_Ch8 is
             Set_Entity (N, Any_Type);
 
          else
+            --  If the type is an incomplete type created to handle
+            --  anonymous access components of a record type, then the
+            --  incomplete type is the visible entity and subsequent
+            --  references will point to it. Mark the original full
+            --  type as referenced, to prevent spurious warnings.
+
+            if Is_Incomplete_Type (T_Name)
+              and then Present (Full_View (T_Name))
+              and then not Comes_From_Source (T_Name)
+            then
+               Set_Referenced (Full_View (T_Name));
+            end if;
+
             T_Name := Get_Full_View (T_Name);
 
+            --  Ada 2005 (AI-251, AI-50217): Handle interfaces visible through
+            --  limited-with clauses
+
+            if From_With_Type (T_Name)
+              and then Ekind (T_Name) in Incomplete_Kind
+              and then Present (Non_Limited_View (T_Name))
+              and then Is_Interface (Non_Limited_View (T_Name))
+            then
+               T_Name := Non_Limited_View (T_Name);
+            end if;
+
             if In_Open_Scopes (T_Name) then
                if Ekind (Base_Type (T_Name)) = E_Task_Type then
 
@@ -5141,28 +5226,6 @@ package body Sem_Ch8 is
       end if;
    end Find_Type;
 
-   -------------------
-   -- Get_Full_View --
-   -------------------
-
-   function Get_Full_View (T_Name : Entity_Id) return Entity_Id is
-   begin
-      if Ekind (T_Name) = E_Incomplete_Type
-        and then Present (Full_View (T_Name))
-      then
-         return Full_View (T_Name);
-
-      elsif Is_Class_Wide_Type (T_Name)
-        and then Ekind (Root_Type (T_Name)) = E_Incomplete_Type
-        and then Present (Full_View (Root_Type (T_Name)))
-      then
-         return Class_Wide_Type (Full_View (Root_Type (T_Name)));
-
-      else
-         return T_Name;
-      end if;
-   end Get_Full_View;
-
    ------------------------------------
    -- Has_Implicit_Character_Literal --
    ------------------------------------
@@ -5608,7 +5671,8 @@ package body Sem_Ch8 is
            or else (Is_Incomplete_Type (T1)
                      and then From_With_Type (T1)
                      and then Present (Non_Limited_View (T1))
-                     and then Is_Record_Type (Non_Limited_View (T1)));
+                     and then Is_Record_Type
+                                (Get_Full_View (Non_Limited_View (T1))));
       end Has_Components;
 
    --  Start of processing for Is_Appropriate_For_Record
@@ -5817,7 +5881,7 @@ package body Sem_Ch8 is
       end if;
 
       Scope_Suppress := SST.Save_Scope_Suppress;
-      Local_Entity_Suppress.Set_Last (SST.Save_Local_Entity_Suppress);
+      Local_Suppress_Stack_Top := SST.Save_Local_Suppress_Stack_Top;
 
       if Debug_Flag_W then
          Write_Str ("--> exiting scope: ");
@@ -5886,9 +5950,9 @@ package body Sem_Ch8 is
          SST : Scope_Stack_Entry renames Scope_Stack.Table (Scope_Stack.Last);
 
       begin
-         SST.Entity                         := S;
-         SST.Save_Scope_Suppress            := Scope_Suppress;
-         SST.Save_Local_Entity_Suppress     := Local_Entity_Suppress.Last;
+         SST.Entity                        := S;
+         SST.Save_Scope_Suppress           := Scope_Suppress;
+         SST.Save_Local_Suppress_Stack_Top := Local_Suppress_Stack_Top;
 
          if Scope_Stack.Last > Scope_Stack.First then
             SST.Component_Alignment_Default := Scope_Stack.Table

gcc/ada/sem_ch8.ads

@@ -76,15 +76,15 @@ package Sem_Ch8 is
    --  appearing in context clauses.
 
    procedure Find_Direct_Name (N : Node_Id);
-   --  Given a direct name (Identifier or Operator_Symbol), this routine
-   --  scans the homonym chain for the name searching for corresponding
-   --  visible entities to find the referenced entity (or in the case of
-   --  overloading), entities. On return, the Entity, and Etype fields
-   --  are set. In the non-overloaded case, these are the correct final
-   --  entries. In the overloaded case, Is_Overloaded is set, Etype and
-   --  Entity refer to an arbitrary element of the overloads set, and
-   --  an appropriate list of entries has been made in the overload
-   --  interpretation table (to be disambiguated in the resolve phase).
+   --  Given a direct name (Identifier or Operator_Symbol), this routine scans
+   --  the homonym chain for the name searching for corresponding visible
+   --  entities to find the referenced entity (or in the case of overloading),
+   --  entities. On return, the Entity and Etype fields are set. In the
+   --  non-overloaded case, these are the correct final entries. In the
+   --  overloaded case, Is_Overloaded is set, Etype and Entity refer to an
+   --  arbitrary element of the overloads set, and an appropriate list of
+   --  entries has been made in the overload interpretation table (to be
+   --  disambiguated in the resolve phase).
 
    procedure Find_Selected_Component (N : Node_Id);
    --  Resolve various cases of selected components, recognize expanded names
@@ -93,16 +93,14 @@ package Sem_Ch8 is
    --  Perform name resolution, and verify that the name found is that of a
    --  type. On return the Entity and Etype fields of the node N are set
    --  appropriately. If it is an incomplete type whose full declaration has
-   --  been seen, they are set to the entity in the full declaration.
-   --  Similarly, if the type is private, it has received a full declaration,
-   --  and we are in the private part or body of the package, then the two
-   --  fields are set to the entity of the full declaration as well. This
-   --  procedure also provides special processing for Class types as well.
-
-   function Get_Full_View (T_Name : Entity_Id) return Entity_Id;
-   --  If T_Name is an incomplete type and the full declaration has been
-   --  seen, or is the name of a class_wide type whose root is incomplete.
-   --  return the corresponding full declaration.
+   --  been seen, they are set to the entity in the full declaration. If it
+   --  is an incomplete type associated with an interface visible through a
+   --  limited-with clause, whose full declaration has been seen, they are
+   --  set to the entity in the full declaration. Similarly, if the type is
+   --  private, it has received a full declaration, and we are in the private
+   --  part or body of the package, then the two fields are set to the entity
+   --  of the full declaration as well. This procedure also has special
+   --  processing for 'Class attribute references.
 
    procedure Initialize;
    --  Initializes data structures used for visibility analysis. Must be