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;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-with GNAT.Spelling_Checker; use GNAT.Spelling_Checker;
-
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
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
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));
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
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
end;
end if;
end if;
-
end Analyze_Package_Renaming;
-------------------------------
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));
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 --
---------------------------------
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
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
("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);
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
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;
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);
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);
-- Now check for possible misspellings
- Get_Name_String (Chars (N));
-
declare
E : Entity_Id;
Ematch : Entity_Id := Empty;
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;
<<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
-- 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;
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;
-- 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.
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));
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.
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;
-- 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;
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);
projects / thirdparty / gcc.git / commitdiff
