-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2017, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2020, 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- --
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
+with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
+with Stand; use Stand;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-- Local Subprograms --
-----------------------
- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id);
+ procedure Unnest_Subprogram
+ (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False);
-- Subp is a library-level subprogram which has nested subprograms, and
-- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
-- declares the AREC types and objects, adds assignments to the AREC record
-- as required, defines the xxxPTR types for uplevel referenced objects,
-- adds the ARECP parameter to all nested subprograms which need it, and
- -- modifies all uplevel references appropriately.
+ -- modifies all uplevel references appropriately. If For_Inline is True,
+ -- we're unnesting this subprogram because it's on the list of inlined
+ -- subprograms and should unnest it despite it not being part of the main
+ -- unit.
-----------
-- Calls --
-- Append a call entry to the Calls table. A check is made to see if the
-- table already contains this entry and if so it has no effect.
+ ----------------------------------
+ -- Subprograms For Fat Pointers --
+ ----------------------------------
+
+ function Build_Access_Type_Decl
+ (E : Entity_Id;
+ Scop : Entity_Id) return Node_Id;
+ -- For an uplevel reference that involves an unconstrained array type,
+ -- build an access type declaration for the corresponding activation
+ -- record component. The relevant attributes of the access type are
+ -- set here to avoid a full analysis that would require a scope stack.
+
+ function Needs_Fat_Pointer (E : Entity_Id) return Boolean;
+ -- A formal parameter of an unconstrained array type that appears in an
+ -- uplevel reference requires the construction of an access type, to be
+ -- used in the corresponding component declaration.
+
-----------
-- Urefs --
-----------
Calls.Append (Call);
end Append_Unique_Call;
+ -----------------------------
+ -- Build_Access_Type_Decl --
+ -----------------------------
+
+ function Build_Access_Type_Decl
+ (E : Entity_Id;
+ Scop : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (E);
+ Typ : Entity_Id;
+
+ begin
+ Typ := Make_Temporary (Loc, 'S');
+ Set_Ekind (Typ, E_General_Access_Type);
+ Set_Etype (Typ, Typ);
+ Set_Scope (Typ, Scop);
+ Set_Directly_Designated_Type (Typ, Etype (E));
+
+ return
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ Subtype_Indication => New_Occurrence_Of (Etype (E), Loc)));
+ end Build_Access_Type_Decl;
+
---------------
-- Get_Level --
---------------
end loop;
end Get_Level;
+ --------------------------
+ -- In_Synchronized_Unit --
+ --------------------------
+
+ function In_Synchronized_Unit (Subp : Entity_Id) return Boolean is
+ S : Entity_Id := Scope (Subp);
+
+ begin
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Concurrent_Type (S) then
+ return True;
+
+ elsif Is_Private_Type (S)
+ and then Present (Full_View (S))
+ and then Is_Concurrent_Type (Full_View (S))
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Synchronized_Unit;
+
+ -----------------------
+ -- Needs_Fat_Pointer --
+ -----------------------
+
+ function Needs_Fat_Pointer (E : Entity_Id) return Boolean is
+ Typ : Entity_Id;
+ begin
+ if Is_Formal (E) then
+ Typ := Etype (E);
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Typ := Full_View (Typ);
+ end if;
+
+ return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
+ else
+ return False;
+ end if;
+ end Needs_Fat_Pointer;
+
----------------
-- Subp_Index --
----------------
if Subps_Index (E) = Uint_0 then
E := Ultimate_Alias (E);
+ -- The body of a protected operation has a different name and
+ -- has been scanned at this point, and thus has an entry in the
+ -- subprogram table.
+
+ if E = Sub and then Convention (E) = Convention_Protected then
+ E := Protected_Body_Subprogram (E);
+ end if;
+
if Ekind (E) = E_Function
and then Rewritten_For_C (E)
and then Present (Corresponding_Procedure (E))
-- Unnest_Subprogram --
-----------------------
- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
+ procedure Unnest_Subprogram
+ (Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False) is
function AREC_Name (J : Pos; S : String) return Name_Id;
-- Returns name for string ARECjS, where j is the decimal value of j
-- to determine whether the main unit is generic (the scope stack is not
-- present when this is called on the main unit).
- if Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
+ if not For_Inline
+ and then Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
then
return;
- end if;
- -- At least for now, do not unnest anything but main source unit
+ -- Only unnest when generating code for the main source unit or if
+ -- we're unnesting for inline. But in some Annex E cases the Sloc
+ -- points to a different unit, so also make sure that the Parent
+ -- isn't in something that we know we're generating code for.
- if not In_Extended_Main_Source_Unit (Subp_Body) then
+ elsif not For_Inline
+ and then not In_Extended_Main_Code_Unit (Subp_Body)
+ and then not In_Extended_Main_Code_Unit (Parent (Subp_Body))
+ then
return;
end if;
Urefs.Init;
Build_Tables : declare
- Current_Subprogram : Entity_Id;
+ Current_Subprogram : Entity_Id := Empty;
-- When we scan a subprogram body, we set Current_Subprogram to the
-- corresponding entity. This gets recursively saved and restored.
Caller : Entity_Id;
Callee : Entity_Id;
- procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean);
+ procedure Check_Static_Type
+ (T : Entity_Id;
+ N : Node_Id;
+ DT : in out Boolean;
+ Check_Designated : Boolean := False);
-- Given a type T, checks if it is a static type defined as a type
-- with no dynamic bounds in sight. If so, the only action is to
-- set Is_Static_Type True for T. If T is not a static type, then
-- all types with dynamic bounds associated with T are detected,
-- and their bounds are marked as uplevel referenced if not at the
- -- library level, and DT is set True.
+ -- library level, and DT is set True. If N is specified, it's the
+ -- node that will need to be replaced. If not specified, it means
+ -- we can't do a replacement because the bound is implicit.
+
+ -- If Check_Designated is True and T or its full view is an access
+ -- type, check whether the designated type has dynamic bounds.
procedure Note_Uplevel_Ref
(E : Entity_Id;
+ N : Node_Id;
Caller : Entity_Id;
Callee : Entity_Id);
-- Called when we detect an explicit or implicit uplevel reference
-- from within Caller to entity E declared in Callee. E can be a
-- an object or a type.
+ procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id);
+ -- Enter a subprogram whose body is visible or which is a
+ -- subprogram instance into the subprogram table.
+
-----------------------
-- Check_Static_Type --
-----------------------
- procedure Check_Static_Type (T : Entity_Id; DT : in out Boolean) is
- procedure Note_Uplevel_Bound (N : Node_Id);
+ procedure Check_Static_Type
+ (T : Entity_Id;
+ N : Node_Id;
+ DT : in out Boolean;
+ Check_Designated : Boolean := False)
+ is
+ procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id);
-- N is the bound of a dynamic type. This procedure notes that
-- this bound is uplevel referenced, it can handle references
-- to entities (typically _FIRST and _LAST entities), and also
-- attribute references of the form T'name (name is typically
-- FIRST or LAST) where T is the uplevel referenced bound.
+ -- Ref, if Present, is the location of the reference to
+ -- replace.
------------------------
-- Note_Uplevel_Bound --
------------------------
- procedure Note_Uplevel_Bound (N : Node_Id) is
+ procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is
begin
- -- Entity name case
+ -- Entity name case. Make sure that the entity is declared
+ -- in a subprogram. This may not be the case for a type in a
+ -- loop appearing in a precondition.
+ -- Exclude explicitly discriminants (that can appear
+ -- in bounds of discriminated components).
if Is_Entity_Name (N) then
- if Present (Entity (N)) then
+ if Present (Entity (N))
+ and then not Is_Type (Entity (N))
+ and then Present (Enclosing_Subprogram (Entity (N)))
+ and then Ekind (Entity (N)) /= E_Discriminant
+ then
Note_Uplevel_Ref
(E => Entity (N),
+ N => Empty,
Caller => Current_Subprogram,
Callee => Enclosing_Subprogram (Entity (N)));
end if;
- -- Attribute case
+ -- Attribute or indexed component case
+
+ elsif Nkind_In (N, N_Attribute_Reference,
+ N_Indexed_Component)
+ then
+ Note_Uplevel_Bound (Prefix (N), Ref);
+
+ -- The indices of the indexed components, or the
+ -- associated expressions of an attribute reference,
+ -- may also involve uplevel references.
+
+ declare
+ Expr : Node_Id;
+
+ begin
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ Note_Uplevel_Bound (Expr, Ref);
+ Next (Expr);
+ end loop;
+ end;
- elsif Nkind (N) = N_Attribute_Reference then
- Note_Uplevel_Bound (Prefix (N));
+ -- The type of the prefix may be have an uplevel
+ -- reference if this needs bounds.
+
+ if Nkind (N) = N_Attribute_Reference then
+ declare
+ Attr : constant Attribute_Id :=
+ Get_Attribute_Id (Attribute_Name (N));
+ DT : Boolean := False;
+
+ begin
+ if (Attr = Attribute_First
+ or else Attr = Attribute_Last
+ or else Attr = Attribute_Length)
+ and then Is_Constrained (Etype (Prefix (N)))
+ then
+ Check_Static_Type
+ (Etype (Prefix (N)), Empty, DT);
+ end if;
+ end;
+ end if;
+
+ -- Binary operator cases. These can apply to arrays for
+ -- which we may need bounds.
+
+ elsif Nkind (N) in N_Binary_Op then
+ Note_Uplevel_Bound (Left_Opnd (N), Ref);
+ Note_Uplevel_Bound (Right_Opnd (N), Ref);
+
+ -- Unary operator case
+
+ elsif Nkind (N) in N_Unary_Op then
+ Note_Uplevel_Bound (Right_Opnd (N), Ref);
+
+ -- Explicit dereference and selected component case
+
+ elsif Nkind_In (N, N_Explicit_Dereference,
+ N_Selected_Component)
+ then
+ Note_Uplevel_Bound (Prefix (N), Ref);
+
+ -- Conditional expressions
+
+ elsif Nkind (N) = N_If_Expression then
+ declare
+ Expr : Node_Id;
+
+ begin
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ Note_Uplevel_Bound (Expr, Ref);
+ Next (Expr);
+ end loop;
+ end;
+
+ elsif Nkind (N) = N_Case_Expression then
+ declare
+ Alternative : Node_Id;
+
+ begin
+ Note_Uplevel_Bound (Expression (N), Ref);
+
+ Alternative := First (Alternatives (N));
+ while Present (Alternative) loop
+ Note_Uplevel_Bound (Expression (Alternative), Ref);
+ end loop;
+ end;
+
+ -- Conversion case
+
+ elsif Nkind (N) = N_Type_Conversion then
+ Note_Uplevel_Bound (Expression (N), Ref);
end if;
end Note_Uplevel_Bound;
begin
-- If already marked static, immediate return
- if Is_Static_Type (T) then
+ if Is_Static_Type (T) and then not Check_Designated then
return;
end if;
begin
if not Is_Static_Expression (LB) then
- Note_Uplevel_Bound (LB);
+ Note_Uplevel_Bound (LB, N);
DT := True;
end if;
if not Is_Static_Expression (UB) then
- Note_Uplevel_Bound (UB);
+ Note_Uplevel_Bound (UB, N);
DT := True;
end if;
end;
- -- For record type, check all components
+ -- For record type, check all components and discriminant
+ -- constraints if present.
elsif Is_Record_Type (T) then
declare
C : Entity_Id;
+ D : Elmt_Id;
+
begin
C := First_Component_Or_Discriminant (T);
while Present (C) loop
- Check_Static_Type (Etype (C), DT);
+ Check_Static_Type (Etype (C), N, DT);
Next_Component_Or_Discriminant (C);
end loop;
+
+ if Has_Discriminants (T)
+ and then Present (Discriminant_Constraint (T))
+ then
+ D := First_Elmt (Discriminant_Constraint (T));
+ while Present (D) loop
+ if not Is_Static_Expression (Node (D)) then
+ Note_Uplevel_Bound (Node (D), N);
+ DT := True;
+ end if;
+
+ Next_Elmt (D);
+ end loop;
+ end if;
end;
-- For array type, check index types and component type
declare
IX : Node_Id;
begin
- Check_Static_Type (Component_Type (T), DT);
+ Check_Static_Type (Component_Type (T), N, DT);
IX := First_Index (T);
while Present (IX) loop
- Check_Static_Type (Etype (IX), DT);
+ Check_Static_Type (Etype (IX), N, DT);
Next_Index (IX);
end loop;
end;
-- For private type, examine whether full view is static
- elsif Is_Private_Type (T) and then Present (Full_View (T)) then
- Check_Static_Type (Full_View (T), DT);
+ elsif Is_Incomplete_Or_Private_Type (T)
+ and then Present (Full_View (T))
+ then
+ Check_Static_Type (Full_View (T), N, DT, Check_Designated);
if Is_Static_Type (Full_View (T)) then
Set_Is_Static_Type (T);
end if;
+ -- For access types, check designated type when required
+
+ elsif Is_Access_Type (T) and then Check_Designated then
+ Check_Static_Type (Directly_Designated_Type (T), N, DT);
+
-- For now, ignore other types
else
procedure Note_Uplevel_Ref
(E : Entity_Id;
+ N : Node_Id;
Caller : Entity_Id;
Callee : Entity_Id)
is
+ Full_E : Entity_Id := E;
begin
-- Nothing to do for static type
and then Corresponding_Procedure (Callee) = Caller
then
return;
+
+ elsif Ekind_In (Callee, E_Entry, E_Entry_Family) then
+ return;
end if;
-- We have a new uplevel referenced entity
+ if Ekind (E) = E_Constant and then Present (Full_View (E)) then
+ Full_E := Full_View (E);
+ end if;
+
-- All we do at this stage is to add the uplevel reference to
-- the table. It's too early to do anything else, since this
-- uplevel reference may come from an unreachable subprogram
-- in which case the entry will be deleted.
- Urefs.Append ((N, E, Caller, Callee));
+ Urefs.Append ((N, Full_E, Caller, Callee));
end Note_Uplevel_Ref;
+ -------------------------
+ -- Register_Subprogram --
+ -------------------------
+
+ procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
+ L : constant Nat := Get_Level (Subp, E);
+
+ begin
+ -- Subprograms declared in tasks and protected types cannot be
+ -- eliminated because calls to them may be in other units, so
+ -- they must be treated as reachable.
+
+ Subps.Append
+ ((Ent => E,
+ Bod => Bod,
+ Lev => L,
+ Reachable => In_Synchronized_Unit (E)
+ or else Address_Taken (E),
+ Uplevel_Ref => L,
+ Declares_AREC => False,
+ Uents => No_Elist,
+ Last => 0,
+ ARECnF => Empty,
+ ARECn => Empty,
+ ARECnT => Empty,
+ ARECnPT => Empty,
+ ARECnP => Empty,
+ ARECnU => Empty));
+
+ Set_Subps_Index (E, UI_From_Int (Subps.Last));
+
+ -- If we marked this reachable because it's in a synchronized
+ -- unit, we have to mark all enclosing subprograms as reachable
+ -- as well. We do the same for subprograms with Address_Taken,
+ -- because otherwise we can run into problems with looking at
+ -- enclosing subprograms in Subps.Table due to their being
+ -- unreachable (the Subp_Index of unreachable subps is later
+ -- set to zero and their entry in Subps.Table is removed).
+
+ if In_Synchronized_Unit (E) or else Address_Taken (E) then
+ declare
+ S : Entity_Id := E;
+
+ begin
+ for J in reverse 1 .. L - 1 loop
+ S := Enclosing_Subprogram (S);
+ Subps.Table (Subp_Index (S)).Reachable := True;
+ end loop;
+ end;
+ end if;
+ end Register_Subprogram;
+
-- Start of processing for Visit_Node
begin
- -- Record a call
+ case Nkind (N) is
- if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
+ -- Record a subprogram call
- -- We are only interested in direct calls, not indirect calls
- -- (where Name (N) is an explicit dereference) at least for now!
+ when N_Function_Call
+ | N_Procedure_Call_Statement
+ =>
+ -- We are only interested in direct calls, not indirect
+ -- calls (where Name (N) is an explicit dereference) at
+ -- least for now!
- and then Nkind (Name (N)) in N_Has_Entity
- then
- Ent := Entity (Name (N));
+ if Nkind (Name (N)) in N_Has_Entity then
+ Ent := Entity (Name (N));
- -- We are only interested in calls to subprograms nested
- -- within Subp. Calls to Subp itself or to subprograms
- -- that are outside the nested structure do not affect us.
+ -- We are only interested in calls to subprograms nested
+ -- within Subp. Calls to Subp itself or to subprograms
+ -- outside the nested structure do not affect us.
- if Scope_Within (Ent, Subp) then
+ if Scope_Within (Ent, Subp)
+ and then Is_Subprogram (Ent)
+ and then not Is_Imported (Ent)
+ then
+ Append_Unique_Call ((N, Current_Subprogram, Ent));
+ end if;
+ end if;
- -- Ignore calls to imported routines
+ -- For all calls where the formal is an unconstrained array
+ -- and the actual is constrained we need to check the bounds
+ -- for uplevel references.
- if Is_Imported (Ent) then
- null;
+ declare
+ Actual : Entity_Id;
+ DT : Boolean := False;
+ Formal : Node_Id;
+ Subp : Entity_Id;
- -- Here we have a call to keep and analyze
+ begin
+ if Nkind (Name (N)) = N_Explicit_Dereference then
+ Subp := Etype (Name (N));
+ else
+ Subp := Entity (Name (N));
+ end if;
- else
- -- Both caller and callee must be subprograms
+ Actual := First_Actual (N);
+ Formal := First_Formal_With_Extras (Subp);
+ while Present (Actual) loop
+ if Is_Array_Type (Etype (Formal))
+ and then not Is_Constrained (Etype (Formal))
+ and then Is_Constrained (Etype (Actual))
+ then
+ Check_Static_Type (Etype (Actual), Empty, DT);
+ end if;
- if Is_Subprogram (Ent) then
- Append_Unique_Call ((N, Current_Subprogram, Ent));
+ Next_Actual (Actual);
+ Next_Formal_With_Extras (Formal);
+ end loop;
+ end;
+
+ -- An At_End_Proc in a statement sequence indicates that there
+ -- is a call from the enclosing construct or block to that
+ -- subprogram. As above, the called entity must be local and
+ -- not imported.
+
+ when N_Handled_Sequence_Of_Statements =>
+ if Present (At_End_Proc (N))
+ and then Scope_Within (Entity (At_End_Proc (N)), Subp)
+ and then not Is_Imported (Entity (At_End_Proc (N)))
+ then
+ Append_Unique_Call
+ ((N, Current_Subprogram, Entity (At_End_Proc (N))));
+ end if;
+
+ -- Similarly, the following constructs include a semantic
+ -- attribute Procedure_To_Call that must be handled like
+ -- other calls. Likewise for attribute Storage_Pool.
+
+ when N_Allocator
+ | N_Extended_Return_Statement
+ | N_Free_Statement
+ | N_Simple_Return_Statement
+ =>
+ declare
+ Pool : constant Entity_Id := Storage_Pool (N);
+ Proc : constant Entity_Id := Procedure_To_Call (N);
+
+ begin
+ if Present (Proc)
+ and then Scope_Within (Proc, Subp)
+ and then not Is_Imported (Proc)
+ then
+ Append_Unique_Call ((N, Current_Subprogram, Proc));
end if;
+
+ if Present (Pool)
+ and then not Is_Library_Level_Entity (Pool)
+ and then Scope_Within_Or_Same (Scope (Pool), Subp)
+ then
+ Caller := Current_Subprogram;
+ Callee := Enclosing_Subprogram (Pool);
+
+ if Callee /= Caller then
+ Note_Uplevel_Ref (Pool, Empty, Caller, Callee);
+ end if;
+ end if;
+ end;
+
+ -- For an allocator with a qualified expression, check type
+ -- of expression being qualified. The explicit type name is
+ -- handled as an entity reference.
+
+ if Nkind (N) = N_Allocator
+ and then Nkind (Expression (N)) = N_Qualified_Expression
+ then
+ declare
+ DT : Boolean := False;
+ begin
+ Check_Static_Type
+ (Etype (Expression (Expression (N))), Empty, DT);
+ end;
+
+ -- For a Return or Free (all other nodes we handle here),
+ -- we usually need the size of the object, so we need to be
+ -- sure that any nonstatic bounds of the expression's type
+ -- that are uplevel are handled.
+
+ elsif Nkind (N) /= N_Allocator
+ and then Present (Expression (N))
+ then
+ declare
+ DT : Boolean := False;
+ begin
+ Check_Static_Type
+ (Etype (Expression (N)),
+ Empty,
+ DT,
+ Check_Designated => Nkind (N) = N_Free_Statement);
+ end;
end if;
- end if;
- -- Record a 'Access as a (potential) call
+ -- A 'Access reference is a (potential) call. So is 'Address,
+ -- in particular on imported subprograms. Other attributes
+ -- require special handling.
- elsif Nkind (N) = N_Attribute_Reference then
- declare
- Attr : constant Attribute_Id :=
- Get_Attribute_Id (Attribute_Name (N));
- begin
- case Attr is
- when Attribute_Access
- | Attribute_Unchecked_Access
- | Attribute_Unrestricted_Access
- =>
- if Nkind (Prefix (N)) in N_Has_Entity then
- Ent := Entity (Prefix (N));
-
- -- We are only interested in calls to subprograms
- -- nested within Subp.
-
- if Scope_Within (Ent, Subp) then
- if Is_Imported (Ent) then
- null;
-
- elsif Is_Subprogram (Ent) then
- Append_Unique_Call
- ((N, Current_Subprogram, Ent));
+ when N_Attribute_Reference =>
+ declare
+ Attr : constant Attribute_Id :=
+ Get_Attribute_Id (Attribute_Name (N));
+ begin
+ case Attr is
+ when Attribute_Access
+ | Attribute_Unchecked_Access
+ | Attribute_Unrestricted_Access
+ | Attribute_Address
+ =>
+ if Nkind (Prefix (N)) in N_Has_Entity then
+ Ent := Entity (Prefix (N));
+
+ -- We only need to examine calls to subprograms
+ -- nested within current Subp.
+
+ if Scope_Within (Ent, Subp) then
+ if Is_Imported (Ent) then
+ null;
+
+ elsif Is_Subprogram (Ent) then
+ Append_Unique_Call
+ ((N, Current_Subprogram, Ent));
+ end if;
end if;
end if;
- end if;
- when others =>
- null;
- end case;
- end;
+ -- References to bounds can be uplevel references if
+ -- the type isn't static.
+
+ when Attribute_First
+ | Attribute_Last
+ | Attribute_Length
+ =>
+ -- Special-case attributes of objects whose bounds
+ -- may be uplevel references. More complex prefixes
+ -- handled during full traversal. Note that if the
+ -- nominal subtype of the prefix is unconstrained,
+ -- the bound must be obtained from the object, not
+ -- from the (possibly) uplevel reference. We call
+ -- Get_Referenced_Object to deal with prefixes that
+ -- are object renamings (prefixes that are types
+ -- can be passed and will simply be returned).
+
+ if Is_Constrained
+ (Etype (Get_Referenced_Object (Prefix (N))))
+ then
+ declare
+ DT : Boolean := False;
+ begin
+ Check_Static_Type
+ (Etype (Get_Referenced_Object (Prefix (N))),
+ Empty,
+ DT);
+ end;
- -- Record a subprogram. We record a subprogram body that acts as
- -- a spec. Otherwise we record a subprogram declaration, providing
- -- that it has a corresponding body we can get hold of. The case
- -- of no corresponding body being available is ignored for now.
+ return OK;
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end;
- elsif Nkind (N) = N_Subprogram_Body then
- Ent := Unique_Defining_Entity (N);
+ -- Component associations in aggregates are either static or
+ -- else the aggregate will be expanded into assignments, in
+ -- which case the expression is analyzed later and provides
+ -- no relevant code generation.
+
+ when N_Component_Association =>
+ if No (Expression (N))
+ or else No (Etype (Expression (N)))
+ then
+ return Skip;
+ end if;
- -- Ignore generic subprogram
+ -- Generic associations are not analyzed: the actuals are
+ -- transferred to renaming and subtype declarations that
+ -- are the ones that must be examined.
- if Is_Generic_Subprogram (Ent) then
+ when N_Generic_Association =>
return Skip;
- end if;
- -- Make new entry in subprogram table if not already made
+ -- Indexed references can be uplevel if the type isn't static
+ -- and if the lower bound (or an inner bound for a multi-
+ -- dimensional array) is uplevel.
- declare
- L : constant Nat := Get_Level (Subp, Ent);
- begin
- Subps.Append
- ((Ent => Ent,
- Bod => N,
- Lev => L,
- Reachable => False,
- Uplevel_Ref => L,
- Declares_AREC => False,
- Uents => No_Elist,
- Last => 0,
- ARECnF => Empty,
- ARECn => Empty,
- ARECnT => Empty,
- ARECnPT => Empty,
- ARECnP => Empty,
- ARECnU => Empty));
- Set_Subps_Index (Ent, UI_From_Int (Subps.Last));
- end;
+ when N_Indexed_Component
+ | N_Slice
+ =>
+ if Is_Constrained (Etype (Prefix (N))) then
+ declare
+ DT : Boolean := False;
+ begin
+ Check_Static_Type (Etype (Prefix (N)), Empty, DT);
+ end;
+ end if;
- -- We make a recursive call to scan the subprogram body, so
- -- that we can save and restore Current_Subprogram.
+ -- A selected component can have an implicit up-level
+ -- reference due to the bounds of previous fields in the
+ -- record. We simplify the processing here by examining
+ -- all components of the record.
- declare
- Save_CS : constant Entity_Id := Current_Subprogram;
- Decl : Node_Id;
+ -- Selected components appear as unit names and end labels
+ -- for child units. Prefixes of these nodes denote parent
+ -- units and carry no type information so they are skipped.
- begin
- Current_Subprogram := Ent;
+ when N_Selected_Component =>
+ if Present (Etype (Prefix (N))) then
+ declare
+ DT : Boolean := False;
+ begin
+ Check_Static_Type (Etype (Prefix (N)), Empty, DT);
+ end;
+ end if;
- -- Scan declarations
+ -- For EQ/NE comparisons, we need the type of the operands
+ -- in order to do the comparison, which means we need the
+ -- bounds.
- Decl := First (Declarations (N));
- while Present (Decl) loop
- Visit (Decl);
- Next (Decl);
- end loop;
+ when N_Op_Eq
+ | N_Op_Ne
+ =>
+ declare
+ DT : Boolean := False;
+ begin
+ Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT);
+ Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT);
+ end;
- -- Scan statements
+ -- Likewise we need the sizes to compute how much to move in
+ -- an assignment.
- Visit (Handled_Statement_Sequence (N));
+ when N_Assignment_Statement =>
+ declare
+ DT : Boolean := False;
+ begin
+ Check_Static_Type (Etype (Name (N)), Empty, DT);
+ Check_Static_Type (Etype (Expression (N)), Empty, DT);
+ end;
- -- Restore current subprogram setting
+ -- Record a subprogram. We record a subprogram body that acts
+ -- as a spec. Otherwise we record a subprogram declaration,
+ -- providing that it has a corresponding body we can get hold
+ -- of. The case of no corresponding body being available is
+ -- ignored for now.
- Current_Subprogram := Save_CS;
- end;
+ when N_Subprogram_Body =>
+ Ent := Unique_Defining_Entity (N);
- -- Now at this level, return skipping the subprogram body
- -- descendants, since we already took care of them!
+ -- Ignore generic subprogram
- return Skip;
+ if Is_Generic_Subprogram (Ent) then
+ return Skip;
+ end if;
- -- Record an uplevel reference
+ -- Make new entry in subprogram table if not already made
- elsif Nkind (N) in N_Has_Entity and then Present (Entity (N)) then
- Ent := Entity (N);
+ Register_Subprogram (Ent, N);
- -- Only interested in entities declared within our nest
+ -- We make a recursive call to scan the subprogram body, so
+ -- that we can save and restore Current_Subprogram.
- if not Is_Library_Level_Entity (Ent)
- and then Scope_Within_Or_Same (Scope (Ent), Subp)
+ declare
+ Save_CS : constant Entity_Id := Current_Subprogram;
+ Decl : Node_Id;
- -- Skip entities defined in inlined subprograms
+ begin
+ Current_Subprogram := Ent;
- and then Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
- and then
+ -- Scan declarations
- -- Constants and variables are interesting
+ Decl := First (Declarations (N));
+ while Present (Decl) loop
+ Visit (Decl);
+ Next (Decl);
+ end loop;
- (Ekind_In (Ent, E_Constant, E_Variable)
+ -- Scan statements
- -- Formals are interesting, but not if being used as mere
- -- names of parameters for name notation calls.
+ Visit (Handled_Statement_Sequence (N));
- or else
- (Is_Formal (Ent)
- and then not
- (Nkind (Parent (N)) = N_Parameter_Association
- and then Selector_Name (Parent (N)) = N))
+ -- Restore current subprogram setting
- -- Types other than known Is_Static types are interesting
+ Current_Subprogram := Save_CS;
+ end;
- or else (Is_Type (Ent)
- and then not Is_Static_Type (Ent)))
- then
- -- Here we have a possible interesting uplevel reference
+ -- Now at this level, return skipping the subprogram body
+ -- descendants, since we already took care of them!
- if Is_Type (Ent) then
- declare
- DT : Boolean := False;
+ return Skip;
- begin
- Check_Static_Type (Ent, DT);
+ -- If we have a body stub, visit the associated subunit, which
+ -- is a semantic descendant of the stub.
- if Is_Static_Type (Ent) then
- return OK;
- end if;
- end;
+ when N_Body_Stub =>
+ Visit (Library_Unit (N));
+
+ -- A declaration of a wrapper package indicates a subprogram
+ -- instance for which there is no explicit body. Enter the
+ -- subprogram instance in the table.
+
+ when N_Package_Declaration =>
+ if Is_Wrapper_Package (Defining_Entity (N)) then
+ Register_Subprogram
+ (Related_Instance (Defining_Entity (N)), Empty);
end if;
- Caller := Current_Subprogram;
- Callee := Enclosing_Subprogram (Ent);
+ -- Skip generic declarations
+
+ when N_Generic_Declaration =>
+ return Skip;
+
+ -- Skip generic package body
- if Callee /= Caller and then not Is_Static_Type (Ent) then
- Note_Uplevel_Ref (Ent, Caller, Callee);
+ when N_Package_Body =>
+ if Present (Corresponding_Spec (N))
+ and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
+ then
+ return Skip;
end if;
- end if;
- -- If we have a body stub, visit the associated subunit
+ -- Pragmas and component declarations are ignored. Quantified
+ -- expressions are expanded into explicit loops and the
+ -- original epression must be ignored.
+
+ when N_Component_Declaration
+ | N_Pragma
+ | N_Quantified_Expression
+ =>
+ return Skip;
+
+ -- We want to skip the function spec for a generic function
+ -- to avoid looking at any generic types that might be in
+ -- its formals.
- elsif Nkind (N) in N_Body_Stub then
- Visit (Library_Unit (N));
+ when N_Function_Specification =>
+ if Is_Generic_Subprogram (Unique_Defining_Entity (N)) then
+ return Skip;
+ end if;
- -- Skip generic declarations
+ -- Otherwise record an uplevel reference in a local identifier
- elsif Nkind (N) in N_Generic_Declaration then
- return Skip;
+ when others =>
+ if Nkind (N) in N_Has_Entity
+ and then Present (Entity (N))
+ then
+ Ent := Entity (N);
- -- Skip generic package body
+ -- Only interested in entities declared within our nest
- elsif Nkind (N) = N_Package_Body
- and then Present (Corresponding_Spec (N))
- and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
- then
- return Skip;
- end if;
+ if not Is_Library_Level_Entity (Ent)
+ and then Scope_Within_Or_Same (Scope (Ent), Subp)
+
+ -- Skip entities defined in inlined subprograms
+
+ and then
+ Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
+
+ -- Constants and variables are potentially uplevel
+ -- references to global declarations.
+
+ and then
+ (Ekind_In (Ent, E_Constant,
+ E_Loop_Parameter,
+ E_Variable)
+
+ -- Formals are interesting, but not if being used
+ -- as mere names of parameters for name notation
+ -- calls.
+
+ or else
+ (Is_Formal (Ent)
+ and then not
+ (Nkind (Parent (N)) = N_Parameter_Association
+ and then Selector_Name (Parent (N)) = N))
+
+ -- Types other than known Is_Static types are
+ -- potentially interesting.
+
+ or else
+ (Is_Type (Ent) and then not Is_Static_Type (Ent)))
+ then
+ -- Here we have a potentially interesting uplevel
+ -- reference to examine.
+
+ if Is_Type (Ent) then
+ declare
+ DT : Boolean := False;
+
+ begin
+ Check_Static_Type (Ent, N, DT);
+ return OK;
+ end;
+ end if;
+
+ Caller := Current_Subprogram;
+ Callee := Enclosing_Subprogram (Ent);
+
+ if Callee /= Caller
+ and then (not Is_Static_Type (Ent)
+ or else Needs_Fat_Pointer (Ent))
+ then
+ Note_Uplevel_Ref (Ent, N, Caller, Callee);
+
+ -- Check the type of a formal parameter of the current
+ -- subprogram, whose formal type may be an uplevel
+ -- reference.
+
+ elsif Is_Formal (Ent)
+ and then Scope (Ent) = Current_Subprogram
+ then
+ declare
+ DT : Boolean := False;
+
+ begin
+ Check_Static_Type (Etype (Ent), Empty, DT);
+ end;
+ end if;
+ end if;
+ end if;
+ end case;
-- Fall through to continue scanning children of this node
loop
S := Enclosing_Subprogram (S);
- -- if we are at the top level, as can happen with
+ -- If we are at the top level, as can happen with
-- references to formals in aspects of nested subprogram
- -- declarations, there are no further subprograms to
- -- mark as requiring activation records.
+ -- declarations, there are no further subprograms to mark
+ -- as requiring activation records.
exit when No (S);
- Subps.Table (Subp_Index (S)).Declares_AREC := True;
+
+ declare
+ SUBI : Subp_Entry renames Subps.Table (Subp_Index (S));
+ begin
+ SUBI.Declares_AREC := True;
+
+ -- If this entity was marked reachable because it is
+ -- in a task or protected type, there may not appear
+ -- to be any calls to it, which would normally adjust
+ -- the levels of the parent subprograms. So we need to
+ -- be sure that the uplevel reference of that entity
+ -- takes into account possible calls.
+
+ if In_Synchronized_Unit (SUBF.Ent)
+ and then SUBT.Lev < SUBI.Uplevel_Ref
+ then
+ SUBI.Uplevel_Ref := SUBT.Lev;
+ end if;
+ end;
+
exit when S = URJ.Callee;
end loop;
-- We do not add types to this list, only actual references
-- to objects that will be referenced uplevel, and we use
-- the flag Is_Uplevel_Referenced_Entity to avoid making
- -- duplicate entries in the list.
+ -- duplicate entries in the list. Discriminants are also
+ -- excluded, only the enclosing object can appear in the
+ -- list.
- if not Is_Uplevel_Referenced_Entity (URJ.Ent) then
+ if not Is_Uplevel_Referenced_Entity (URJ.Ent)
+ and then Ekind (URJ.Ent) /= E_Discriminant
+ then
Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
-
- if not Is_Type (URJ.Ent) then
- Append_New_Elmt (URJ.Ent, SUBT.Uents);
- end if;
+ Append_New_Elmt (URJ.Ent, SUBT.Uents);
end if;
-- And set uplevel indication for caller
Write_Eol;
end if;
- -- Rewrite declaration and body to null statements
+ -- Rewrite declaration, body, and corresponding freeze node
+ -- to null statements.
- Spec := Corresponding_Spec (STJ.Bod);
+ -- A subprogram instantiation does not have an explicit
+ -- body. If unused, we could remove the corresponding
+ -- wrapper package and its body (TBD).
- if Present (Spec) then
- Decl := Parent (Declaration_Node (Spec));
- Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
- end if;
+ if Present (STJ.Bod) then
+ Spec := Corresponding_Spec (STJ.Bod);
+
+ if Present (Spec) then
+ Decl := Parent (Declaration_Node (Spec));
+ Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
- Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
+ if Present (Freeze_Node (Spec)) then
+ Rewrite (Freeze_Node (Spec),
+ Make_Null_Statement (Sloc (Decl)));
+ end if;
+ end if;
+
+ Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
+ end if;
end if;
end;
end loop;
-- Loop through subprograms
Subp_Loop : declare
- Addr : constant Entity_Id := RTE (RE_Address);
+ Addr : Entity_Id := Empty;
begin
for J in Subps_First .. Subps.Last loop
begin
-- Decorate the new formal entity
- Set_Scope (Form, STJ.Ent);
- Set_Ekind (Form, E_In_Parameter);
- Set_Etype (Form, STJE.ARECnPT);
- Set_Mechanism (Form, By_Copy);
- Set_Never_Set_In_Source (Form, True);
- Set_Analyzed (Form, True);
- Set_Comes_From_Source (Form, False);
+ Set_Scope (Form, STJ.Ent);
+ Set_Ekind (Form, E_In_Parameter);
+ Set_Etype (Form, STJE.ARECnPT);
+ Set_Mechanism (Form, By_Copy);
+ Set_Never_Set_In_Source (Form, True);
+ Set_Analyzed (Form, True);
+ Set_Comes_From_Source (Form, False);
+ Set_Is_Activation_Record (Form, True);
-- Case of only body present
-- Local declarations for one such subprogram
declare
- Loc : constant Source_Ptr := Sloc (STJ.Bod);
+ Loc : constant Source_Ptr := Sloc (STJ.Bod);
+
+ Decls : constant List_Id := New_List;
+ -- List of new declarations we create
+
Clist : List_Id;
Comp : Entity_Id;
+ Decl_Assign : Node_Id;
+ -- Assignment to set uplink, Empty if none
+
Decl_ARECnT : Node_Id;
Decl_ARECnPT : Node_Id;
Decl_ARECn : Node_Id;
Decl_ARECnP : Node_Id;
-- Declaration nodes for the AREC entities we build
- Decl_Assign : Node_Id;
- -- Assigment to set uplink, Empty if none
-
- Decls : List_Id;
- -- List of new declarations we create
-
begin
- -- Build list of component declarations for ARECnT
+ -- Build list of component declarations for ARECnT and
+ -- load System.Address.
Clist := Empty_List;
+ if No (Addr) then
+ Addr := RTE (RE_Address);
+ end if;
+
-- If we are in a subprogram that has a static link that
-- is passed in (as indicated by ARECnF being defined),
-- then include ARECnU : ARECmPT where ARECmPT comes from
if Present (STJ.Uents) then
declare
- Elmt : Elmt_Id;
- Uent : Entity_Id;
+ Elmt : Elmt_Id;
+ Ptr_Decl : Node_Id;
+ Uent : Entity_Id;
Indx : Nat;
-- 1's origin of index in list of elements. This is
Set_Activation_Record_Component
(Uent, Comp);
- Append_To (Clist,
- Make_Component_Declaration (Loc,
- Defining_Identifier => Comp,
- Component_Definition =>
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Addr, Loc))));
+ if Needs_Fat_Pointer (Uent) then
+
+ -- Build corresponding access type
+
+ Ptr_Decl :=
+ Build_Access_Type_Decl
+ (Etype (Uent), STJ.Ent);
+ Append_To (Decls, Ptr_Decl);
+ -- And use its type in the corresponding
+ -- component.
+
+ Append_To (Clist,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier => Comp,
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of
+ (Defining_Identifier (Ptr_Decl),
+ Loc))));
+ else
+ Append_To (Clist,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier => Comp,
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Subtype_Indication =>
+ New_Occurrence_Of (Addr, Loc))));
+ end if;
Next_Elmt (Elmt);
end loop;
end;
end if;
-- Now we can insert the AREC declarations into the body
-
-- type ARECnT is record .. end record;
-- pragma Suppress_Initialization (ARECnT);
Component_List =>
Make_Component_List (Loc,
Component_Items => Clist)));
- Decls := New_List (Decl_ARECnT);
+ Append_To (Decls, Decl_ARECnT);
-- type ARECnPT is access all ARECnT;
New_Occurrence_Of (STJ.ARECnPT, Loc),
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (STJ.ARECn, Loc),
Attribute_Name => Name_Access));
Append_To (Decls, Decl_ARECnP);
Decl_Assign := Empty;
end if;
- Prepend_List_To (Declarations (STJ.Bod), Decls);
+ if No (Declarations (STJ.Bod)) then
+ Set_Declarations (STJ.Bod, Decls);
+ else
+ Prepend_List_To (Declarations (STJ.Bod), Decls);
+ end if;
-- Analyze the newly inserted declarations. Note that we
-- do not need to establish the whole scope stack, since
Loc : constant Source_Ptr := Sloc (Ent);
Dec : constant Node_Id :=
Declaration_Node (Ent);
- Ins : Node_Id;
- Asn : Node_Id;
+
+ Asn : Node_Id;
+ Attr : Name_Id;
+ Comp : Entity_Id;
+ Ins : Node_Id;
+ Rhs : Node_Id;
begin
-- For parameters, we insert the assignment
-- right after the declaration of ARECnP.
- -- For all other entities, we insert
- -- the assignment immediately after
- -- the declaration of the entity.
+ -- For all other entities, we insert the
+ -- assignment immediately after the
+ -- declaration of the entity or after the
+ -- freeze node if present.
-- Note: we don't need to mark the entity
-- as being aliased, because the address
if Is_Formal (Ent) then
Ins := Decl_ARECnP;
+
+ elsif Has_Delayed_Freeze (Ent) then
+ Ins := Freeze_Node (Ent);
+
else
Ins := Dec;
end if;
-- Build and insert the assignment:
-- ARECn.nam := nam'Address
+ -- or else 'Access for unconstrained array
+
+ if Needs_Fat_Pointer (Ent) then
+ Attr := Name_Access;
+ else
+ Attr := Name_Address;
+ end if;
+
+ Rhs :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Ent, Loc),
+ Attribute_Name => Attr);
+
+ -- If the entity is an unconstrained formal
+ -- we wrap the attribute reference in an
+ -- unchecked conversion to the type of the
+ -- activation record component, to prevent
+ -- spurious subtype conformance errors within
+ -- instances.
+
+ if Is_Formal (Ent)
+ and then not Is_Constrained (Etype (Ent))
+ then
+ -- Find target component and its type
+
+ Comp := First_Component (STJ.ARECnT);
+ while Chars (Comp) /= Chars (Ent) loop
+ Comp := Next_Component (Comp);
+ end loop;
+
+ Rhs :=
+ Unchecked_Convert_To (Etype (Comp), Rhs);
+ end if;
Asn :=
Make_Assignment_Statement (Loc,
(Activation_Record_Component
(Ent),
Loc)),
+ Expression => Rhs);
+
+ -- If we have a loop parameter, we have
+ -- to insert before the first statement
+ -- of the loop. Ins points to the
+ -- N_Loop_Parameter_Specification or to
+ -- an N_Iterator_Specification.
+
+ if Nkind_In
+ (Ins, N_Iterator_Specification,
+ N_Loop_Parameter_Specification)
+ then
+ -- Quantified expression are rewritten as
+ -- loops during expansion.
+
+ if Nkind (Parent (Ins)) =
+ N_Quantified_Expression
+ then
+ null;
+
+ else
+ Ins :=
+ First
+ (Statements
+ (Parent (Parent (Ins))));
+ Insert_Before (Ins, Asn);
+ end if;
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Ent, Loc),
- Attribute_Name => Name_Address));
-
- Insert_After (Ins, Asn);
+ else
+ Insert_After (Ins, Asn);
+ end if;
-- Analyze the assignment statement. We do
-- not need to establish the relevant scope
begin
-- Ignore type references, these are implicit references that do
-- not need rewriting (e.g. the appearence in a conversion).
-
- if Is_Type (UPJ.Ent) then
- goto Continue;
- end if;
-
- -- Also ignore uplevel references to bounds of types that come
- -- from the original type reference.
-
- if Is_Entity_Name (UPJ.Ref)
- and then Present (Entity (UPJ.Ref))
- and then Is_Type (Entity (UPJ.Ref))
+ -- Also ignore if no reference was specified or if the rewriting
+ -- has already been done (this can happen if the N_Identifier
+ -- occurs more than one time in the tree). Also ignore references
+ -- when not generating C code (in particular for the case of LLVM,
+ -- since GNAT-LLVM will handle the processing for up-level refs).
+
+ if No (UPJ.Ref)
+ or else not Is_Entity_Name (UPJ.Ref)
+ or else not Present (Entity (UPJ.Ref))
+ or else not Opt.Generate_C_Code
then
goto Continue;
end if;
Typ : constant Entity_Id := Etype (UPJ.Ent);
-- The type of the referenced entity
- Atyp : constant Entity_Id := Get_Actual_Subtype (UPJ.Ref);
+ Atyp : Entity_Id;
-- The actual subtype of the reference
RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
SI : SI_Type;
begin
+ Atyp := Etype (UPJ.Ref);
+
+ if Ekind (Atyp) /= E_Record_Subtype then
+ Atyp := Get_Actual_Subtype (UPJ.Ref);
+ end if;
+
-- Ignore if no ARECnF entity for enclosing subprogram which
-- probably happens as a result of not properly treating
-- instance bodies. To be examined ???
goto Continue;
end if;
+ -- If this is a reference to a global constant, use its value
+ -- rather than create a reference. It is more efficient and
+ -- furthermore indispensable if the context requires a
+ -- constant, such as a branch of a case statement.
+
+ if Ekind (UPJ.Ent) = E_Constant
+ and then Is_True_Constant (UPJ.Ent)
+ and then Present (Constant_Value (UPJ.Ent))
+ and then Is_Static_Expression (Constant_Value (UPJ.Ent))
+ then
+ Rewrite (UPJ.Ref, New_Copy_Tree (Constant_Value (UPJ.Ent)));
+ goto Continue;
+ end if;
+
-- Push the current scope, so that the pointer type Tnn, and
-- any subsidiary entities resulting from the analysis of the
-- rewritten reference, go in the right entity chain.
-- from level STJR.Lev to level STJE.Lev. The general form of
-- the rewritten reference for entity X is:
- -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECm.X)
+ -- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
-- where a,b,c,d .. m =
-- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
Comp := Activation_Record_Component (UPJ.Ent);
pragma Assert (Present (Comp));
- -- Do the replacement
+ -- Do the replacement. If the component type is an access type,
+ -- this is an uplevel reference for an entity that requires a
+ -- fat pointer, so dereference the component.
- Rewrite (UPJ.Ref,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Atyp, Loc),
- Attribute_Name => Name_Deref,
- Expressions => New_List (
- Make_Selected_Component (Loc,
- Prefix => Pfx,
- Selector_Name =>
- New_Occurrence_Of (Comp, Loc)))));
+ if Is_Access_Type (Etype (Comp)) then
+ Rewrite (UPJ.Ref,
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix => Pfx,
+ Selector_Name =>
+ New_Occurrence_Of (Comp, Loc))));
+
+ else
+ Rewrite (UPJ.Ref,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Atyp, Loc),
+ Attribute_Name => Name_Deref,
+ Expressions => New_List (
+ Make_Selected_Component (Loc,
+ Prefix => Pfx,
+ Selector_Name =>
+ New_Occurrence_Of (Comp, Loc)))));
+ end if;
-- Analyze and resolve the new expression. We do not need to
-- establish the relevant scope stack entries here, because we
-- expect any exceptions)
Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
+
+ -- Generate an extra temporary to facilitate the C backend
+ -- processing this dereference
+
+ if Opt.Modify_Tree_For_C
+ and then Nkind_In (Parent (UPJ.Ref),
+ N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ then
+ Force_Evaluation (UPJ.Ref, Mode => Strict);
+ end if;
+
Pop_Scope;
end Rewrite_One_Ref;
end;
begin
if Present (STT.ARECnF)
- and then Nkind (CTJ.N) /= N_Attribute_Reference
+ and then Nkind (CTJ.N) in N_Subprogram_Call
then
-- CTJ.N is a call to a subprogram which may require a pointer
-- to an activation record. The subprogram containing the call
-- have to find the activation record needed by the
-- callee. This is as follows:
- -- ARECaF.ARECbU.ARECcU....ARECm
+ -- ARECaF.ARECbU.ARECcU....ARECmU
-- where a,b,c .. m =
-- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
if No (Act) then
Set_First_Named_Actual (CTJ.N, Extra);
+ -- If call has been relocated (as with an expression in
+ -- an aggregate), set First_Named pointer in original node
+ -- as well, because that's the parent of the parameter list.
+
+ Set_First_Named_Actual
+ (Parent (List_Containing (ExtraP)), Extra);
+
-- Here we must follow the chain and append the new entry
else
-- Tree visitor that search for outer level procedures with nested
-- subprograms and invokes Unnest_Subprogram()
+ ---------------
+ -- Do_Search --
+ ---------------
+
+ procedure Do_Search is new Traverse_Proc (Search_Subprograms);
+ -- Subtree visitor instantiation
+
------------------------
-- Search_Subprograms --
------------------------
Unnest_Subprogram (Spec_Id, N);
end if;
end;
+
+ -- The proper body of a stub may contain nested subprograms, and
+ -- therefore must be visited explicitly. Nested stubs are examined
+ -- recursively in Visit_Node.
+
+ elsif Nkind (N) in N_Body_Stub then
+ Do_Search (Library_Unit (N));
+
+ -- Skip generic packages
+
+ elsif Nkind (N) = N_Package_Body
+ and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
+ then
+ return Skip;
end if;
return OK;
end Search_Subprograms;
- ---------------
- -- Do_Search --
- ---------------
-
- procedure Do_Search is new Traverse_Proc (Search_Subprograms);
- -- Subtree visitor instantiation
+ Subp : Entity_Id;
+ Subp_Body : Node_Id;
-- Start of processing for Unnest_Subprograms
begin
- if not Opt.Unnest_Subprogram_Mode then
+ if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then
return;
end if;
+ -- A specification will contain bodies if it contains instantiations so
+ -- examine package or subprogram declaration of the main unit, when it
+ -- is present.
+
+ if Nkind (Unit (N)) = N_Package_Body
+ or else (Nkind (Unit (N)) = N_Subprogram_Body
+ and then not Acts_As_Spec (N))
+ then
+ Do_Search (Library_Unit (N));
+ end if;
+
Do_Search (N);
+
+ -- Unnest any subprograms passed on the list of inlined subprograms
+
+ Subp := First_Inlined_Subprogram (N);
+
+ while Present (Subp) loop
+ Subp_Body := Parent (Declaration_Node (Subp));
+
+ if Nkind (Subp_Body) = N_Subprogram_Declaration
+ and then Present (Corresponding_Body (Subp_Body))
+ then
+ Subp_Body := Parent (Declaration_Node
+ (Corresponding_Body (Subp_Body)));
+ end if;
+
+ Unnest_Subprogram (Subp, Subp_Body, For_Inline => True);
+ Next_Inlined_Subprogram (Subp);
+ end loop;
end Unnest_Subprograms;
end Exp_Unst;
projects / thirdparty / gcc.git / blobdiff