mirror of
https://github.com/autc04/Retro68.git
synced 2024-09-27 12:57:21 +00:00
393 lines
16 KiB
Ada
393 lines
16 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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;
|