blob: a63ddfa71b59b3c1b17c0ced791c90d81d87b6ff [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 8 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
package body Exp_Ch8 is
---------------------------------------------
-- Expand_N_Exception_Renaming_Declaration --
---------------------------------------------
procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
Decl : Node_Id;
begin
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
Insert_Action (N, Decl);
end if;
end Expand_N_Exception_Renaming_Declaration;
------------------------------------------
-- Expand_N_Object_Renaming_Declaration --
------------------------------------------
-- Most object renaming cases can be done by just capturing the address
-- of the renamed object. The cases in which this is not true are when
-- this address is not computable, since it involves extraction of a
-- packed array element, or of a record component to which a component
-- clause applies (that can specify an arbitrary bit boundary), or where
-- the enclosing record itself has a non-standard representation.
-- In Ada 2022, a third case arises when the renamed object is a nonatomic
-- subcomponent of an atomic object, because reads of or writes to it must
-- access the enclosing atomic object. That's also the case for an object
-- subject to the Volatile_Full_Access GNAT aspect/pragma in any language
-- version. For the sake of simplicity, we treat any subcomponent of an
-- atomic or Volatile_Full_Access object in any language version this way.
-- In these three cases, we pre-evaluate the renaming expression, by
-- extracting and freezing the values of any subscripts, and then we
-- set the flag Is_Renaming_Of_Object which means that any reference
-- to the object will be handled by macro substitution in the front
-- end, and the back end will know to ignore the renaming declaration.
-- An additional odd case that requires processing by expansion is
-- the renaming of a discriminant of a mutable record type. The object
-- is a constant because it renames something that cannot be assigned to,
-- but in fact the underlying value can change and must be reevaluated
-- at each reference. Gigi does have a notion of a "constant view" of
-- an object, and therefore the front-end must perform the expansion.
-- For simplicity, and to bypass some obscure code-generation problem,
-- we use macro substitution for all renamed discriminants, whether the
-- enclosing type is constrained or not.
-- The other special processing required is for the case of renaming
-- of an object of a class wide type, where it is necessary to build
-- the appropriate subtype for the renamed object.
-- More comments needed for this para ???
procedure Expand_N_Object_Renaming_Declaration (N : Node_Id) is
function Evaluation_Required (Nam : Node_Id) return Boolean;
-- Determines whether it is necessary to do static name evaluation for
-- renaming of Nam. It is considered necessary if evaluating the name
-- involves indexing a packed array, or extracting a component of a
-- record to which a component clause applies, or a subcomponent of an
-- atomic object. Note that we are only interested in these operations
-- if they occur as part of the name itself, subscripts are just values
-- that are computed as part of the evaluation, so they are unimportant.
-- In addition, always return True for Modify_Tree_For_C since the
-- code generator doesn't know how to handle renamings.
-------------------------
-- Evaluation_Required --
-------------------------
function Evaluation_Required (Nam : Node_Id) return Boolean is
begin
if Modify_Tree_For_C then
return True;
elsif Nkind (Nam) in N_Indexed_Component | N_Slice then
if Is_Packed (Etype (Prefix (Nam))) then
return True;
elsif Is_Full_Access_Object (Prefix (Nam)) then
return True;
else
return Evaluation_Required (Prefix (Nam));
end if;
elsif Nkind (Nam) = N_Selected_Component then
declare
Rec_Type : constant Entity_Id := Etype (Prefix (Nam));
begin
if Present (Component_Clause (Entity (Selector_Name (Nam))))
or else Has_Non_Standard_Rep (Rec_Type)
then
return True;
elsif Ekind (Entity (Selector_Name (Nam))) = E_Discriminant
and then Is_Record_Type (Rec_Type)
and then not Is_Concurrent_Record_Type (Rec_Type)
then
return True;
elsif Is_Full_Access_Object (Prefix (Nam)) then
return True;
else
return Evaluation_Required (Prefix (Nam));
end if;
end;
else
return False;
end if;
end Evaluation_Required;
-- Local variables
Decl : Node_Id;
Nam : constant Node_Id := Name (N);
T : constant Entity_Id := Etype (Defining_Identifier (N));
-- Start of processing for Expand_N_Object_Renaming_Declaration
begin
-- Perform name evaluation if required
if Evaluation_Required (Nam) then
Evaluate_Name (Nam);
Set_Is_Renaming_Of_Object (Defining_Identifier (N));
end if;
-- Deal with construction of subtype in class-wide case
if Is_Class_Wide_Type (T) then
Expand_Subtype_From_Expr (N, T, Subtype_Mark (N), Name (N));
Find_Type (Subtype_Mark (N));
Set_Etype (Defining_Identifier (N), Entity (Subtype_Mark (N)));
-- Freeze the class-wide subtype here to ensure that the subtype
-- and equivalent type are frozen before the renaming.
Freeze_Before (N, Entity (Subtype_Mark (N)));
end if;
-- Ada 2005 (AI-318-02): If the renamed object is a call to a build-in-
-- place function, then a temporary return object needs to be created
-- and access to it must be passed to the function.
if Is_Build_In_Place_Function_Call (Nam) then
Make_Build_In_Place_Call_In_Anonymous_Context (Nam);
-- Ada 2005 (AI-318-02): Specialization of previous case for renaming
-- containing build-in-place function calls whose returned object covers
-- interface types.
elsif Present (Unqual_BIP_Iface_Function_Call (Nam)) then
Make_Build_In_Place_Iface_Call_In_Anonymous_Context (Nam);
end if;
-- Create renaming entry for debug information. Mark the entity as
-- needing debug info if it comes from sources because the current
-- setting in Freeze_Entity occurs too late. ???
Set_Debug_Info_Defining_Id (N);
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
Insert_Action (N, Decl);
end if;
end Expand_N_Object_Renaming_Declaration;
-------------------------------------------
-- Expand_N_Package_Renaming_Declaration --
-------------------------------------------
procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
Decl : Node_Id;
begin
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
-- If we are in a compilation unit, then this is an outer
-- level declaration, and must have a scope of Standard
if Nkind (Parent (N)) = N_Compilation_Unit then
declare
Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
begin
Push_Scope (Standard_Standard);
if No (Actions (Aux)) then
Set_Actions (Aux, New_List (Decl));
else
Append (Decl, Actions (Aux));
end if;
Analyze (Decl);
-- Enter the debug variable in the qualification list, which
-- must be done at this point because auxiliary declarations
-- occur at the library level and aren't associated with a
-- normal scope.
Qualify_Entity_Names (Decl);
Pop_Scope;
end;
-- Otherwise, just insert after the package declaration
else
Insert_Action (N, Decl);
end if;
end if;
end Expand_N_Package_Renaming_Declaration;
----------------------------------------------
-- Expand_N_Subprogram_Renaming_Declaration --
----------------------------------------------
procedure Expand_N_Subprogram_Renaming_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Entity (N);
function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
-- Build and return the body for the renaming declaration of an equality
-- or inequality operator of type Typ.
-----------------------------
-- Build_Body_For_Renaming --
-----------------------------
function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
Left : constant Entity_Id := First_Formal (Id);
Right : constant Entity_Id := Next_Formal (Left);
Body_Id : Entity_Id;
Decl : Node_Id;
begin
Set_Alias (Id, Empty);
Set_Has_Completion (Id, False);
Rewrite (N,
Make_Subprogram_Declaration (Loc,
Specification => Specification (N)));
Set_Has_Delayed_Freeze (Id);
Body_Id := Make_Defining_Identifier (Loc, Chars (Id));
Set_Debug_Info_Needed (Body_Id);
if Has_Variant_Part (Typ) then
Decl :=
Build_Variant_Record_Equality
(Typ => Typ,
Body_Id => Body_Id,
Param_Specs => Copy_Parameter_List (Id));
-- Build body for renamed equality, to capture its current meaning.
-- It may be redefined later, but the renaming is elaborated where
-- it occurs. This is technically known as Squirreling semantics.
-- Renaming is rewritten as a subprogram declaration, and the
-- generated body is inserted into the freeze actions for the
-- subprogram.
else
Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Body_Id,
Parameter_Specifications => Copy_Parameter_List (Id),
Result_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Simple_Return_Statement (Loc,
Expression =>
Expand_Record_Equality
(Id,
Typ => Typ,
Lhs => Make_Identifier (Loc, Chars (Left)),
Rhs => Make_Identifier (Loc, Chars (Right)))))));
end if;
return Decl;
end Build_Body_For_Renaming;
-- Local variables
Nam : constant Node_Id := Name (N);
-- Start of processing for Expand_N_Subprogram_Renaming_Declaration
begin
-- When the prefix of the name is a function call, we must force the
-- call to be made by removing side effects from the call, since we
-- must only call the function once.
if Nkind (Nam) = N_Selected_Component
and then Nkind (Prefix (Nam)) = N_Function_Call
then
Remove_Side_Effects (Prefix (Nam));
-- For an explicit dereference, the prefix must be captured to prevent
-- reevaluation on calls through the renaming, which could result in
-- calling the wrong subprogram if the access value were to be changed.
elsif Nkind (Nam) = N_Explicit_Dereference then
Force_Evaluation (Prefix (Nam));
end if;
-- Handle cases where we build a body for a renamed equality
if Is_Entity_Name (Nam)
and then Chars (Entity (Nam)) = Name_Op_Eq
and then Scope (Entity (Nam)) = Standard_Standard
then
declare
Typ : constant Entity_Id := Etype (First_Formal (Id));
begin
-- Check whether this is a renaming of a predefined equality on an
-- untagged record type (AI05-0123).
if Ada_Version >= Ada_2012
and then Is_Record_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
then
Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
end if;
end;
end if;
end Expand_N_Subprogram_Renaming_Declaration;
end Exp_Ch8;