From: Robert Dewar Date: Thu, 13 Dec 2007 10:30:55 +0000 (+0100) Subject: sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for renaming entry... X-Git-Tag: releases/gcc-4.3.0~1042 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=294ccb21c4d993c4fd9f4220e0ee8513a1666894;p=thirdparty%2Fgcc.git sem_ch8.adb (Analyze_Subprogram_Renaming): Special error message for renaming entry as subprogram using rename-as-body if... 2007-12-06 Robert Dewar Ed Schonberg * 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 --- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 8a5ae003e5fe..ec2047b749ef 100644 --- a/gcc/ada/sem_ch8.adb +++ b/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 @@ -916,7 +923,7 @@ package body Sem_Ch8 is or else (Nkind (Original_Node (Nam)) = N_Attribute_Reference and then Is_Function_Attribute_Name - (Attribute_Name (Original_Node (Nam)))) + (Attribute_Name (Original_Node (Nam)))) -- Weird but legal, equivalent to renaming a function call. -- Illegal if the literal is the result of constant-folding an @@ -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. - Analyze_Renamed_Entry (N, New_S, Present (Rename_Spec)); - return; + -- 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 <> 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); - if Nkind (Parent (N)) = N_Label then + -- 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. + + 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,26 +4430,17 @@ 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) - and then not Is_Internal_Name (Chars (Id)) - then - Error_Msg_NE - ("possible misspelling of&", Selector, Id); - exit; - end if; + while Present (Id) loop + if Is_Bad_Spelling_Of (Chars (Id), Chars (Selector)) + and then not Is_Internal_Name (Chars (Id)) + then + Error_Msg_NE + ("possible misspelling of&", Selector, Id); + exit; + end if; - Next_Entity (Id); - end loop; - end; + Next_Entity (Id); + end loop; -- Specialize the message if this may be an instantiation -- of a child unit that was not mentioned in the context. @@ -4252,7 +4448,7 @@ package body Sem_Ch8 is if Nkind (Parent (N)) = N_Package_Instantiation and then Is_Generic_Instance (Entity (Prefix (N))) and then Is_Compilation_Unit - (Generic_Parent (Parent (Entity (Prefix (N))))) + (Generic_Parent (Parent (Entity (Prefix (N))))) then Error_Msg_Node_2 := Selector; Error_Msg_N ("\missing `WITH &.&;`", Prefix (N)); @@ -4298,11 +4494,11 @@ package body Sem_Ch8 is if Is_Task_Type (P_Name) and then ((Ekind (Id) = E_Entry - and then Nkind (Parent (N)) /= N_Attribute_Reference) - or else - (Ekind (Id) = E_Entry_Family - and then - Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) + and then Nkind (Parent (N)) /= N_Attribute_Reference) + or else + (Ekind (Id) = E_Entry_Family + and then + Nkind (Parent (Parent (N))) /= N_Attribute_Reference)) then -- It is an entry call after all, either to the current task (which -- will deadlock) or to an enclosing task. @@ -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 - or else (Nkind (The_Unit) = N_Subprogram_Body - and then not Acts_As_Spec (Cunit (Current_Sem_Unit)))) + 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)))) 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);