sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for renaming…

sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for renaming entry as subprogram using rename-as-body if...

2007-12-06  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for
	renaming entry as subprogram using rename-as-body if subprogram spec
	frozen.
	(Use_One_Type): The clause is legal on an access type whose designated
	type has a limited view.
	(Find_Direct_Name): Use Namet.Sp.Is_Bad_Spelling_Of function
	(Find_Expanded_Name): Use Namet.Sp.Is_Bad_Spelling_Of function
	(Analyze_Renamed_Primitive_Operation): new procedure to determine the
	operation denoted by a selected component.
	(Analyze_Renamed_Entry): Resolve the prefix of the entry name, because
	it can be an expression, possibly overloaded, that returns a task or
	an access to one.

From-SVN: r130854

gcc/ada/sem_ch8.adb

@@ -37,6 +37,7 @@ with Lib;      use Lib;
 with Lib.Load; use Lib.Load;
 with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
+with Namet.Sp; use Namet.Sp;
 with Nlists;   use Nlists;
 with Nmake;    use Nmake;
 with Opt;      use Opt;
@@ -64,8 +65,6 @@ with Table;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 
-with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
-
 package body Sem_Ch8 is
 
    ------------------------------------
@@ -388,6 +387,14 @@ package body Sem_Ch8 is
    --  Used when the renamed entity is an indexed component. The prefix must
    --  denote an entry family.
 
+   procedure Analyze_Renamed_Primitive_Operation
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean);
+   --  If the renamed entity in a subprogram renaming is a primitive operation
+   --  or a class-wide operation in prefix form, save the target object, which
+   --  must be added to the list of actuals in any subsequent call.
+
    function Applicable_Use (Pack_Name : Node_Id) return Boolean;
    --  Common code to Use_One_Package and Set_Use, to determine whether
    --  use clause must be processed. Pack_Name is an entity name that
@@ -974,7 +981,7 @@ package body Sem_Ch8 is
       end if;
 
       --  Apply Text_IO kludge here, since we may be renaming one of the
-      --  children of Text_IO
+      --  children of Text_IO.
 
       Text_IO_Kludge (Name (N));
 
@@ -1014,6 +1021,8 @@ package body Sem_Ch8 is
          Set_Ekind (New_P, E_Package);
          Set_Etype (New_P, Standard_Void_Type);
 
+      --  Here for OK package renaming
+
       else
          --  Entities in the old package are accessible through the renaming
          --  entity. The simplest implementation is to have both packages share
@@ -1036,6 +1045,24 @@ package body Sem_Ch8 is
          Check_Library_Unit_Renaming (N, Old_P);
          Generate_Reference (Old_P, Name (N));
 
+         --  If the renaming is in the visible part of a package, then we set
+         --  In_Package_Spec for the renamed package, to prevent giving
+         --  warnings about no entities referenced. Such a warning would be
+         --  overenthusiastic, since clients can see entities in the renamed
+         --  package via the visible package renaming.
+
+         declare
+            Ent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+         begin
+            if Ekind (Ent) = E_Package
+              and then not In_Private_Part (Ent)
+              and then In_Extended_Main_Source_Unit (N)
+              and then Ekind (Old_P) = E_Package
+            then
+               Set_Renamed_In_Spec (Old_P);
+            end if;
+         end;
+
          --  If this is the renaming declaration of a package instantiation
          --  within itself, it is the declaration that ends the list of actuals
          --  for the instantiation. At this point, the subtypes that rename
@@ -1084,7 +1111,6 @@ package body Sem_Ch8 is
             end;
          end if;
       end if;
-
    end Analyze_Package_Renaming;
 
    -------------------------------
@@ -1210,6 +1236,11 @@ package body Sem_Ch8 is
          end if;
 
          Inherit_Renamed_Profile (New_S, Old_S);
+
+         --  The prefix can be an arbitrary expression that yields a task
+         --  type, so it must be resolved.
+
+         Resolve (Prefix (Nam), Scope (Old_S));
       end if;
 
       Set_Convention (New_S, Convention (Old_S));
@@ -1265,6 +1296,114 @@ package body Sem_Ch8 is
       end if;
    end Analyze_Renamed_Family_Member;
 
+   -----------------------------------------
+   -- Analyze_Renamed_Primitive_Operation --
+   -----------------------------------------
+
+   procedure Analyze_Renamed_Primitive_Operation
+     (N       : Node_Id;
+      New_S   : Entity_Id;
+      Is_Body : Boolean)
+   is
+      Old_S : Entity_Id;
+
+      function Conforms
+        (Subp : Entity_Id;
+         Ctyp : Conformance_Type) return Boolean;
+      --  Verify that the signatures of the renamed entity and the new entity
+      --  match. The first formal of the renamed entity is skipped because it
+      --  is the target object in any subsequent call.
+
+      function Conforms
+        (Subp : Entity_Id;
+         Ctyp : Conformance_Type) return Boolean
+      is
+         Old_F : Entity_Id;
+         New_F : Entity_Id;
+
+      begin
+         if Ekind (Subp) /= Ekind (New_S) then
+            return False;
+         end if;
+
+         Old_F := Next_Formal (First_Formal (Subp));
+         New_F := First_Formal (New_S);
+         while Present (Old_F) and then Present (New_F) loop
+            if not Conforming_Types (Etype (Old_F), Etype (New_F), Ctyp) then
+               return False;
+            end if;
+
+            if Ctyp >= Mode_Conformant
+              and then Ekind (Old_F) /= Ekind (New_F)
+            then
+               return False;
+            end if;
+
+            Next_Formal (New_F);
+            Next_Formal (Old_F);
+         end loop;
+
+         return True;
+      end Conforms;
+
+   begin
+      if not Is_Overloaded (Selector_Name (Name (N))) then
+         Old_S := Entity (Selector_Name (Name (N)));
+
+         if not Conforms (Old_S, Type_Conformant) then
+            Old_S := Any_Id;
+         end if;
+
+      else
+         --  Find the operation that matches the given signature
+
+         declare
+            It  : Interp;
+            Ind : Interp_Index;
+
+         begin
+            Old_S := Any_Id;
+            Get_First_Interp (Selector_Name (Name (N)), Ind, It);
+
+            while Present (It.Nam) loop
+               if Conforms (It.Nam, Type_Conformant) then
+                  Old_S := It.Nam;
+               end if;
+
+               Get_Next_Interp (Ind, It);
+            end loop;
+         end;
+      end if;
+
+      if Old_S = Any_Id then
+         Error_Msg_N (" no subprogram or entry matches specification",  N);
+
+      else
+         if Is_Body then
+            if not Conforms (Old_S, Subtype_Conformant) then
+               Error_Msg_N ("subtype conformance error in renaming", N);
+            end if;
+
+            Generate_Reference (New_S, Defining_Entity (N), 'b');
+            Style.Check_Identifier (Defining_Entity (N), New_S);
+
+         else
+            --  Only mode conformance required for a renaming_as_declaration
+
+            if not Conforms (Old_S, Mode_Conformant) then
+               Error_Msg_N ("mode conformance error in renaming", N);
+            end if;
+         end if;
+
+         --  Inherit_Renamed_Profile (New_S, Old_S);
+
+         --  The prefix can be an arbitrary expression that yields an
+         --  object, so it must be resolved.
+
+         Resolve (Prefix (Name (N)));
+      end if;
+   end Analyze_Renamed_Primitive_Operation;
+
    ---------------------------------
    -- Analyze_Subprogram_Renaming --
    ---------------------------------
@@ -1573,14 +1712,17 @@ package body Sem_Ch8 is
 
       Rename_Spec := Find_Corresponding_Spec (N);
 
+      --  Case of Renaming_As_Body
+
       if Present (Rename_Spec) then
 
-         --  Renaming_As_Body. Renaming declaration is the completion of
-         --  the declaration of Rename_Spec. We will build an actual body
-         --  for it at the freezing point.
+         --  Renaming declaration is the completion of the declaration of
+         --  Rename_Spec. We build an actual body for it at the freezing point.
 
          Set_Corresponding_Spec (N, Rename_Spec);
 
+         --  Deal with special case of Input and Output stream functions
+
          if Nkind (Unit_Declaration_Node (Rename_Spec)) =
                                      N_Abstract_Subprogram_Declaration
          then
@@ -1622,6 +1764,13 @@ package body Sem_Ch8 is
          Check_Fully_Conformant (New_S, Rename_Spec);
          Set_Public_Status (New_S);
 
+         --  The specification does not introduce new formals, but only
+         --  repeats the formals of the original subprogram declaration.
+         --  For cross-reference purposes, and for refactoring tools, we
+         --  treat the formals of the renaming declaration as body formals.
+
+         Reference_Body_Formals (Rename_Spec, New_S);
+
          --  Indicate that the entity in the declaration functions like the
          --  corresponding body, and is not a new entity. The body will be
          --  constructed later at the freeze point, so indicate that the
@@ -1645,6 +1794,8 @@ package body Sem_Ch8 is
               ("subprogram& overrides inherited operation", N, Rename_Spec);
          end if;
 
+      --  Normal subprogram renaming (not renaming as body)
+
       else
          Generate_Definition (New_S);
          New_Overloaded_Entity (New_S);
@@ -1671,12 +1822,57 @@ package body Sem_Ch8 is
 
       elsif Nkind (Nam) = N_Selected_Component then
 
-         --  Renamed entity is an entry or protected subprogram. For those
-         --  cases an explicit body is built (at the point of freezing of this
-         --  entity) that contains a call to the renamed entity.
+         --  A prefix of the form  A.B can designate an entry of task A, a
+         --  protected operation of protected object A, or finally a primitive
+         --  operation of object A. In the later case, A is an object of some
+         --  tagged type, or an access type that denotes one such. To further
+         --  distinguish these cases, note that the scope of a task entry or
+         --  protected operation is type of the prefix.
+
+         --  The prefix could be an overloaded function call that returns both
+         --  kinds of operations. This overloading pathology is left to the
+         --  dedicated reader ???
+
+         declare
+            T : constant Entity_Id := Etype (Prefix (Nam));
+
+         begin
+            if Present (T)
+              and then
+                (Is_Tagged_Type (T)
+                  or else
+                    (Is_Access_Type (T)
+                      and then
+                        Is_Tagged_Type (Designated_Type (T))))
+              and then Scope (Entity (Selector_Name (Nam))) /= T
+            then
+               Analyze_Renamed_Primitive_Operation
+                 (N, New_S, Present (Rename_Spec));
+               return;
 
+            else
+               --  Renamed entity is an entry or protected operation. For those
+               --  cases an explicit body is built (at the point of freezing of
+               --  this entity) that contains a call to the renamed entity.
+
+               --  This is not allowed for renaming as body if the renamed
+               --  spec is already frozen (see RM 8.5.4(5) for details).
+
+               if Present (Rename_Spec)
+                 and then Is_Frozen (Rename_Spec)
+               then
+                  Error_Msg_N
+                    ("renaming-as-body cannot rename entry as subprogram", N);
+                  Error_Msg_NE
+                    ("\since & is already frozen (RM 8.5.4(5))",
+                     N, Rename_Spec);
+               else
                   Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec));
+               end if;
+
                return;
+            end if;
+         end;
 
       elsif Nkind (Nam) = N_Explicit_Dereference then
 
@@ -2760,8 +2956,8 @@ package body Sem_Ch8 is
             Pop_Scope;
 
             while not (Is_List_Member (Decl))
-              or else Nkind (Parent (Decl)) = N_Protected_Definition
-              or else Nkind (Parent (Decl)) = N_Task_Definition
+              or else Nkind_In (Parent (Decl), N_Protected_Definition,
+                                               N_Task_Definition)
             loop
                Decl := Parent (Decl);
             end loop;
@@ -3339,10 +3535,7 @@ package body Sem_Ch8 is
          if Nkind (N) = N_Identifier
            and then Nkind (Parent (N)) = N_Case_Statement_Alternative
          then
-            Get_Name_String (Chars (N));
-
             declare
-               Case_Str : constant String    := Name_Buffer (1 .. Name_Len);
                Case_Stm : constant Node_Id   := Parent (Parent (N));
                Case_Typ : constant Entity_Id := Etype (Expression (Case_Stm));
                Case_Rtp : constant Entity_Id := Root_Type (Case_Typ);
@@ -3359,9 +3552,7 @@ package body Sem_Ch8 is
                   Get_Name_String (Chars (Lit));
 
                   if Chars (Lit) /= Chars (N)
-                    and then Is_Bad_Spelling_Of
-                      (Case_Str, Name_Buffer (1 .. Name_Len))
-                  then
+                    and then Is_Bad_Spelling_Of (Chars (N), Chars (Lit)) then
                      Error_Msg_Node_2 := Lit;
                      Error_Msg_N
                        ("& is undefined, assume misspelling of &", N);
@@ -3445,8 +3636,6 @@ package body Sem_Ch8 is
 
             --  Now check for possible misspellings
 
-            Get_Name_String (Chars (N));
-
             declare
                E      : Entity_Id;
                Ematch : Entity_Id := Empty;
@@ -3455,23 +3644,16 @@ package body Sem_Ch8 is
                                 Name_Id (Nat (First_Name_Id) +
                                            Name_Entries_Count - 1);
 
-               S  : constant String (1 .. Name_Len) :=
-                      Name_Buffer (1 .. Name_Len);
-
             begin
-               for N in First_Name_Id .. Last_Name_Id loop
-                  E := Get_Name_Entity_Id (N);
+               for Nam in First_Name_Id .. Last_Name_Id loop
+                  E := Get_Name_Entity_Id (Nam);
 
                   if Present (E)
                      and then (Is_Immediately_Visible (E)
                                  or else
                                Is_Potentially_Use_Visible (E))
                   then
-                     Get_Name_String (N);
-
-                     if Is_Bad_Spelling_Of
-                          (S, Name_Buffer (1 .. Name_Len))
-                     then
+                     if Is_Bad_Spelling_Of (Chars (N), Nam) then
                         Ematch := E;
                         exit;
                      end if;
@@ -3812,6 +3994,18 @@ package body Sem_Ch8 is
 
       <<Found>> begin
 
+         --  When distribution features are available (Get_PCS_Name /=
+         --  Name_No_DSA), a remote access-to-subprogram type is converted
+         --  into a record type holding whatever information is needed to
+         --  perform a remote call on an RCI suprogram. In that case we
+         --  rewrite any occurrence of the RAS type into the equivalent record
+         --  type here. 'Access attribute references and RAS dereferences are
+         --  then implemented using specific TSSs. However when distribution is
+         --  not available (case of Get_PCS_Name = Name_No_DSA), we bypass the
+         --  generation of these TSSs, and we must keep the RAS type in its
+         --  original access-to-subprogram form (since all calls through a
+         --  value of such type will be local anyway in the absence of a PCS).
+
          if Comes_From_Source (N)
            and then Is_Remote_Access_To_Subprogram_Type (E)
            and then Expander_Active
@@ -3875,17 +4069,28 @@ package body Sem_Ch8 is
          --  to the discriminant in the initialization procedure.
 
          else
-            --  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
-            --  view of the user
+            --  Entity is unambiguous, indicate that it is referenced here
+
+            --  For a renaming of an object, always generate simple reference,
+            --  we don't try to keep track of assignments in this case.
+
+            if Is_Object (E) and then Present (Renamed_Object (E)) then
+               Generate_Reference (E, N);
+
+            --  One 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
+            --  view of the user.
 
-            if Nkind (Parent (N)) = N_Label then
+            elsif Nkind (Parent (N)) = N_Label then
                declare
                   R : constant Boolean := Referenced (E);
+
                begin
-                  if not Is_Actual_Parameter then
+                  --  Generate reference unless this is an actual parameter
+                  --  (see comment below)
+
+                  if Is_Actual_Parameter then
                      Generate_Reference (E, N);
                      Set_Referenced (E, R);
                   end if;
@@ -3938,8 +4143,8 @@ package body Sem_Ch8 is
                begin
                   P := Parent (N);
                   while Present (P)
-                    and then Nkind (P) /= N_Parameter_Specification
-                    and then Nkind (P) /= N_Component_Declaration
+                    and then not Nkind_In (P, N_Parameter_Specification,
+                                              N_Component_Declaration)
                   loop
                      P := Parent (P);
                   end loop;
@@ -4225,16 +4430,8 @@ package body Sem_Ch8 is
                   --  Check for misspelling of some entity in prefix
 
                   Id := First_Entity (P_Name);
-                  Get_Name_String (Chars (Selector));
-
-                  declare
-                     S  : constant String (1 .. Name_Len) :=
-                            Name_Buffer (1 .. Name_Len);
-                  begin
                   while Present (Id) loop
-                        Get_Name_String (Chars (Id));
-                        if Is_Bad_Spelling_Of
-                          (Name_Buffer (1 .. Name_Len), S)
+                     if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector))
                        and then not Is_Internal_Name (Chars (Id))
                      then
                         Error_Msg_NE
@@ -4244,7 +4441,6 @@ package body Sem_Ch8 is
 
                      Next_Entity (Id);
                   end loop;
-                  end;
 
                   --  Specialize the message if this may be an instantiation
                   --  of a child unit that was not mentioned in the context.
@@ -6179,9 +6375,11 @@ package body Sem_Ch8 is
          The_Unit := Unit (Cunit (Current_Sem_Unit));
 
          if No (With_Sys)
-           and then (Nkind (The_Unit) = N_Package_Body
+           and then
+             (Nkind (The_Unit) = N_Package_Body
                 or else (Nkind (The_Unit) = N_Subprogram_Body
-                        and then not Acts_As_Spec (Cunit (Current_Sem_Unit))))
+                           and then
+                             not Acts_As_Spec (Cunit (Current_Sem_Unit))))
          then
             With_Sys := Find_System (Library_Unit (Cunit (Current_Sem_Unit)));
          end if;
@@ -6193,7 +6391,6 @@ package body Sem_Ch8 is
             --  context as well (Current_Sem_Unit is the parent unit);
 
             The_Unit := Parent (N);
-
             while Nkind (The_Unit) /= N_Compilation_Unit loop
                The_Unit := Parent (The_Unit);
             end loop;
@@ -6694,7 +6891,14 @@ package body Sem_Ch8 is
       if In_Open_Scopes (Scope (T)) then
          null;
 
-      elsif From_With_Type (T) then
+      --  A limited view cannot appear in a use_type clause. However, an
+      --  access type whose designated type is limited has the flag but
+      --  is not itself a limited view unless we only have a limited view
+      --  of its enclosing package.
+
+      elsif From_With_Type (T)
+        and then From_With_Type (Scope (T))
+      then
          Error_Msg_N
            ("incomplete type from limited view "
              & "cannot appear in use clause", Id);