-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, 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 Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
+with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
with Validsw; use Validsw;
package body Exp_Ch5 is
function Change_Of_Representation (N : Node_Id) return Boolean;
- -- Determine if the right hand side of the assignment N is a type
- -- conversion which requires a change of representation. Called
- -- only for the array and record cases.
+ -- Determine if the right hand side of assignment N is a type conversion
+ -- which requires a change of representation. Called only for the array
+ -- and record cases.
procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id);
-- N is an assignment which assigns an array value. This routine process
-- the various special cases and checks required for such assignments,
-- including change of representation. Rhs is normally simply the right
- -- hand side of the assignment, except that if the right hand side is
- -- a type conversion or a qualified expression, then the Rhs is the
- -- actual expression inside any such type conversions or qualifications.
+ -- hand side of the assignment, except that if the right hand side is a
+ -- type conversion or a qualified expression, then the RHS is the actual
+ -- expression inside any such type conversions or qualifications.
function Expand_Assign_Array_Loop
(N : Node_Id;
end if;
if Is_Unchecked_Union (Base_Type (R_Typ)) then
- Insert_Action (N, Make_Field_Assign (CF, True));
+
+ -- Within an initialization procedure this is the
+ -- assignment to an unchecked union component, in which
+ -- case there is no discriminant to initialize.
+
+ if Inside_Init_Proc then
+ null;
+
+ else
+ -- The assignment is part of a conversion from a
+ -- derived unchecked union type with an inferable
+ -- discriminant, to a parent type.
+
+ Insert_Action (N, Make_Field_Assign (CF, True));
+ end if;
+
else
Insert_Action (N, Make_Field_Assign (CF));
end if;
procedure Expand_N_Assignment_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Crep : constant Boolean := Change_Of_Representation (N);
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
Typ : constant Entity_Id := Underlying_Type (Etype (Lhs));
-- Skip discriminant check if change of representation. Will be
-- done when the change of representation is expanded out.
- if not Change_Of_Representation (N) then
+ if not Crep then
Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs);
end if;
-- If the type is private without discriminants, and the full type
-- has discriminants (necessarily with defaults) a check may still be
- -- necessary if the Lhs is aliased. The private determinants must be
+ -- necessary if the Lhs is aliased. The private discriminants must be
-- visible to build the discriminant constraints.
- -- What is a "determinant"???
-- Only an explicit dereference that comes from source indicates
-- aliasing. Access to formals of protected operations and entries
and then Comes_From_Source (Lhs)
then
declare
- Lt : constant Entity_Id := Etype (Lhs);
+ Lt : constant Entity_Id := Etype (Lhs);
+ Ubt : Entity_Id := Base_Type (Typ);
+
begin
- Set_Etype (Lhs, Typ);
- Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
- Apply_Discriminant_Check (Rhs, Typ, Lhs);
+ -- In the case of an expander-generated record subtype whose base
+ -- type still appears private, Typ will have been set to that
+ -- private type rather than the underlying record type (because
+ -- Underlying type will have returned the record subtype), so it's
+ -- necessary to apply Underlying_Type again to the base type to
+ -- get the record type we need for the discriminant check. Such
+ -- subtypes can be created for assignments in certain cases, such
+ -- as within an instantiation passed this kind of private type.
+ -- It would be good to avoid this special test, but making changes
+ -- to prevent this odd form of record subtype seems difficult. ???
+
+ if Is_Private_Type (Ubt) then
+ Ubt := Underlying_Type (Ubt);
+ end if;
+
+ Set_Etype (Lhs, Ubt);
+ Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs));
+ Apply_Discriminant_Check (Rhs, Ubt, Lhs);
Set_Etype (Lhs, Lt);
end;
-- Skip discriminant check if change of representation. Will be
-- done when the change of representation is expanded out.
- if not Change_Of_Representation (N) then
+ if not Crep then
Apply_Discriminant_Check (Rhs, Etype (Lhs));
end if;
Apply_Constraint_Check (Rhs, Etype (Lhs));
end if;
- -- Case of assignment to a bit packed array element
+ -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
+ -- stand-alone obj of an anonymous access type.
+
+ if Is_Access_Type (Typ)
+ and then Is_Entity_Name (Lhs)
+ and then Present (Effective_Extra_Accessibility (Entity (Lhs))) then
+ declare
+ function Lhs_Entity return Entity_Id;
+ -- Look through renames to find the underlying entity.
+ -- For assignment to a rename, we don't care about the
+ -- Enclosing_Dynamic_Scope of the rename declaration.
+
+ ----------------
+ -- Lhs_Entity --
+ ----------------
+
+ function Lhs_Entity return Entity_Id is
+ Result : Entity_Id := Entity (Lhs);
+
+ begin
+ while Present (Renamed_Object (Result)) loop
+
+ -- Renamed_Object must return an Entity_Name here
+ -- because of preceding "Present (E_E_A (...))" test.
+
+ Result := Entity (Renamed_Object (Result));
+ end loop;
+
+ return Result;
+ end Lhs_Entity;
+
+ -- Local Declarations
+
+ Access_Check : constant Node_Id :=
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Dynamic_Accessibility_Level (Rhs),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval =>
+ Scope_Depth
+ (Enclosing_Dynamic_Scope
+ (Lhs_Entity)))),
+ Reason => PE_Accessibility_Check_Failed);
+
+ Access_Level_Update : constant Node_Id :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Effective_Extra_Accessibility
+ (Entity (Lhs)), Loc),
+ Expression =>
+ Dynamic_Accessibility_Level (Rhs));
+
+ begin
+ if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
+ Insert_Action (N, Access_Check);
+ end if;
+
+ Insert_Action (N, Access_Level_Update);
+ end;
+ end if;
+
+ -- Case of assignment to a bit packed array element. If there is a
+ -- change of representation this must be expanded into components,
+ -- otherwise this is a bit-field assignment.
if Nkind (Lhs) = N_Indexed_Component
and then Is_Bit_Packed_Array (Etype (Prefix (Lhs)))
then
- Expand_Bit_Packed_Element_Set (N);
- return;
+ -- Normal case, no change of representation
+
+ if not Crep then
+ Expand_Bit_Packed_Element_Set (N);
+ return;
+
+ -- Change of representation case
+
+ else
+ -- Generate the following, to force component-by-component
+ -- assignments in an efficient way. Otherwise each component
+ -- will require a temporary and two bit-field manipulations.
+
+ -- T1 : Elmt_Type;
+ -- T1 := RhS;
+ -- Lhs := T1;
+
+ declare
+ Tnn : constant Entity_Id := Make_Temporary (Loc, 'T');
+ Stats : List_Id;
+
+ begin
+ Stats :=
+ New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Lhs), Loc)),
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Tnn, Loc),
+ Expression => Relocate_Node (Rhs)),
+ Make_Assignment_Statement (Loc,
+ Name => Relocate_Node (Lhs),
+ Expression => New_Occurrence_Of (Tnn, Loc)));
+
+ Insert_Actions (N, Stats);
+ Rewrite (N, Make_Null_Statement (Loc));
+ Analyze (N);
+ end;
+ end if;
-- Build-in-place function call case. Note that we're not yet doing
-- build-in-place for user-written assignment statements (the assignment
-- If the type is tagged, we may as well use the predefined
-- primitive assignment. This avoids inlining a lot of code
- -- and in the class-wide case, the assignment is replaced by
- -- dispatch call to _assign. Note that this cannot be done when
- -- discriminant checks are locally suppressed (as in extension
- -- aggregate expansions) because otherwise the discriminant
- -- check will be performed within the _assign call. It is also
- -- suppressed for assignments created by the expander that
- -- correspond to initializations, where we do want to copy the
- -- tag (No_Ctrl_Actions flag set True) by the expander and we
- -- do not need to mess with tags ever (Expand_Ctrl_Actions flag
- -- is set True in this case). Finally, it is suppressed if the
- -- restriction No_Dispatching_Calls is in force because in that
- -- case predefined primitives are not generated.
+ -- and in the class-wide case, the assignment is replaced
+ -- by a dispatching call to _assign. It is suppressed in the
+ -- case of assignments created by the expander that correspond
+ -- to initializations, where we do want to copy the tag
+ -- (Expand_Ctrl_Actions flag is set True in this case). It is
+ -- also suppressed if restriction No_Dispatching_Calls is in
+ -- force because in that case predefined primitives are not
+ -- generated.
or else (Is_Tagged_Type (Typ)
and then not Is_Value_Type (Etype (Lhs))
and then Chars (Current_Scope) /= Name_uAssign
and then Expand_Ctrl_Actions
- and then not Discriminant_Checks_Suppressed (Empty)
and then
not Restriction_Active (No_Dispatching_Calls))
then
+ if Is_Limited_Type (Typ) then
+
+ -- This can happen in an instance when the formal is an
+ -- extension of a limited interface, and the actual is
+ -- limited. This is an error according to AI05-0087, but
+ -- is not caught at the point of instantiation in earlier
+ -- versions.
+
+ -- This is wrong, error messages cannot be issued during
+ -- expansion, since they would be missed in -gnatc mode ???
+
+ Error_Msg_N ("assignment not available on limited type", N);
+ return;
+ end if;
+
-- Fetch the primitive op _assign and proper type to call it.
-- Because of possible conflicts between private and full view,
-- fetch the proper type directly from the operation profile.
Append_To (L,
Make_Raise_Constraint_Error (Loc,
Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Lhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag)),
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag))),
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Lhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag)),
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag))),
Reason => CE_Tag_Check_Failed));
end if;
if Compile_Time_Known_Value (Expr) then
Alt := Find_Static_Alternative (N);
+ Process_Statements_For_Controlled_Objects (Alt);
+
-- Move statements from this alternative after the case statement.
-- They are already analyzed, so will be skipped by the analyzer.
Kill_Dead_Code (Expression (N));
declare
- A : Node_Id;
+ Dead_Alt : Node_Id;
begin
-- Loop through case alternatives, skipping pragmas, and skipping
-- the one alternative that we select (and therefore retain).
- A := First (Alternatives (N));
- while Present (A) loop
- if A /= Alt
- and then Nkind (A) = N_Case_Statement_Alternative
+ Dead_Alt := First (Alternatives (N));
+ while Present (Dead_Alt) loop
+ if Dead_Alt /= Alt
+ and then Nkind (Dead_Alt) = N_Case_Statement_Alternative
then
- Kill_Dead_Code (Statements (A), Warn_On_Deleted_Code);
+ Kill_Dead_Code (Statements (Dead_Alt), Warn_On_Deleted_Code);
end if;
- Next (A);
+ Next (Dead_Alt);
end loop;
end;
Len := List_Length (Alternatives (N));
if Len = 1 then
- -- We still need to evaluate the expression if it has any
- -- side effects.
+
+ -- We still need to evaluate the expression if it has any side
+ -- effects.
Remove_Side_Effects (Expression (N));
- Insert_List_After (N, Statements (First (Alternatives (N))));
+ Alt := First (Alternatives (N));
+
+ Process_Statements_For_Controlled_Objects (Alt);
+ Insert_List_After (N, Statements (Alt));
-- That leaves the case statement as a shell. The alternative that
-- will be executed is reset to a null list. So now we can kill
Kill_Dead_Code (Expression (N));
Rewrite (N, Make_Null_Statement (Loc));
return;
- end if;
-- An optimization. If there are only two alternatives, and only
-- a single choice, then rewrite the whole case statement as an
-- simple form, but also with generated code (discriminant check
-- functions in particular)
- if Len = 2 then
+ elsif Len = 2 then
Chlist := Discrete_Choices (First (Alternatives (N)));
if List_Length (Chlist) = 1 then
(Others_Node, Discrete_Choices (Last_Alt));
Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
end if;
+
+ Alt := First (Alternatives (N));
+ while Present (Alt)
+ and then Nkind (Alt) = N_Case_Statement_Alternative
+ loop
+ Process_Statements_For_Controlled_Objects (Alt);
+ Next (Alt);
+ end loop;
end;
end Expand_N_Case_Statement;
-- these warnings for expander generated code.
begin
+ Process_Statements_For_Controlled_Objects (N);
+
Adjust_Condition (Condition (N));
-- The following loop deals with constant conditions for the IF. We
if Present (Elsif_Parts (N)) then
E := First (Elsif_Parts (N));
while Present (E) loop
+ Process_Statements_For_Controlled_Objects (E);
+
Adjust_Condition (Condition (E));
-- If there are condition actions, then rewrite the if statement
Loc : constant Source_Ptr := Sloc (N);
Container : constant Node_Id := Name (I_Spec);
- Container_Typ : constant Entity_Id := Etype (Container);
+ Container_Typ : constant Entity_Id := Base_Type (Etype (Container));
Cursor : Entity_Id;
+ Iterator : Entity_Id;
New_Loop : Node_Id;
Stats : List_Id := Statements (N);
-- the array.
if Of_Present (I_Spec) then
- Cursor := Make_Temporary (Loc, 'C');
+ Iterator := Make_Temporary (Loc, 'C');
-- Generate:
- -- Element : Component_Type renames Container (Cursor);
+ -- Element : Component_Type renames Container (Iterator);
Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
Make_Indexed_Component (Loc,
Prefix => Relocate_Node (Container),
Expressions => New_List (
- New_Reference_To (Cursor, Loc)))));
+ New_Reference_To (Iterator, Loc)))));
-- for Index in Array loop
- --
- -- This case utilizes the already given cursor name
+
+ -- This case utilizes the already given iterator name
else
- Cursor := Id;
+ Iterator := Id;
end if;
-- Generate:
- -- for Cursor in [reverse] Container'Range loop
- -- Element : Component_Type renames Container (Cursor);
+ -- for Iterator in [reverse] Container'Range loop
+ -- Element : Component_Type renames Container (Iterator);
-- -- for the "of" form
- --
+
-- <original loop statements>
-- end loop;
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Cursor,
+ Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Container),
-- Processing for containers
else
+ -- For an "of" iterator the name is a container expression, which
+ -- is transformed into a call to the default iterator.
+
+ -- For an iterator of the form "in" the name is a function call
+ -- that delivers an iterator type.
+
+ -- In both cases, analysis of the iterator has introduced an object
+ -- declaration to capture the domain, so that Container is an entity.
+
-- The for loop is expanded into a while loop which uses a container
- -- specific cursor to examine each element.
+ -- specific cursor to desgnate each element.
- -- Cursor : Pack.Cursor := Container.First;
- -- while Cursor /= Pack.No_Element loop
+ -- Iter : Iterator_Type := Container.Iterate;
+ -- Cursor : Cursor_type := First (Iter);
+ -- while Has_Element (Iter) loop
-- declare
- -- -- the block is added when Element_Type is controlled
+ -- -- The block is added when Element_Type is controlled
-- Obj : Pack.Element_Type := Element (Cursor);
-- -- for the "of" loop form
-- <original loop statements>
-- end;
- -- Pack.Next (Cursor);
+ -- Cursor := Iter.Next (Cursor);
-- end loop;
-- If "reverse" is present, then the initialization of the cursor
-- uses Last and the step becomes Prev. Pack is the name of the
- -- package which instantiates the container.
+ -- scope where the container package is instantiated.
declare
Element_Type : constant Entity_Id := Etype (Id);
- Pack : constant Entity_Id :=
- Scope (Base_Type (Container_Typ));
+ Iter_Type : Entity_Id;
+ Pack : Entity_Id;
Decl : Node_Id;
- Cntr : Node_Id;
Name_Init : Name_Id;
Name_Step : Name_Id;
begin
- -- The "of" case uses an internally generated cursor
-
- if Of_Present (I_Spec) then
- Cursor := Make_Temporary (Loc, 'C');
+ -- The type of the iterator is the return type of the Iterate
+ -- function used. For the "of" form this is the default iterator
+ -- for the type, otherwise it is the type of the explicit
+ -- function used in the iterator specification. The most common
+ -- case will be an Iterate function in the container package.
+
+ -- The primitive operations of the container type may not be
+ -- use-visible, so we introduce the name of the enclosing package
+ -- in the declarations below. The Iterator type is declared in a
+ -- an instance within the container package itself.
+
+ -- If the container type is a derived type, the cursor type is
+ -- found in the package of the parent type.
+
+ if Is_Derived_Type (Container_Typ) then
+ Pack := Scope (Root_Type (Container_Typ));
else
- Cursor := Id;
+ Pack := Scope (Container_Typ);
end if;
- -- The code below only handles containers where Element is not a
- -- primitive operation of the container. This excludes for now the
- -- Hi-Lite formal containers.
+ Iter_Type := Etype (Name (I_Spec));
+
+ -- The "of" case uses an internally generated cursor whose type
+ -- is found in the container package. The domain of iteration
+ -- is expanded into a call to the default Iterator function, but
+ -- this expansion does not take place in quantified expressions
+ -- that are analyzed with expansion disabled, and in that case the
+ -- type of the iterator must be obtained from the aspect.
if Of_Present (I_Spec) then
+ declare
+ Default_Iter : constant Entity_Id :=
+ Entity
+ (Find_Aspect
+ (Etype (Container),
+ Aspect_Default_Iterator));
- -- Generate:
- -- Id : Element_Type := Pack.Element (Cursor);
+ Container_Arg : Node_Id;
+ Ent : Entity_Id;
- Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Id,
- Subtype_Mark =>
- New_Reference_To (Element_Type, Loc),
- Name =>
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Chars => Name_Element)),
- Expressions => New_List (
- New_Reference_To (Cursor, Loc))));
-
- -- When the container holds controlled objects, wrap the loop
- -- statements and element renaming declaration with a block.
- -- This ensures that the transient result of Element (Cursor)
- -- is cleaned up after each iteration of the loop.
-
- if Needs_Finalization (Element_Type) then
+ begin
+ Cursor := Make_Temporary (Loc, 'I');
+
+ -- For an container element iterator, the iterator type
+ -- is obtained from the corresponding aspect.
+
+ Iter_Type := Etype (Default_Iter);
+ Pack := Scope (Iter_Type);
+
+ -- Rewrite domain of iteration as a call to the default
+ -- iterator for the container type. If the container is
+ -- a derived type and the aspect is inherited, convert
+ -- container to parent type. The Cursor type is also
+ -- inherited from the scope of the parent.
+
+ if Base_Type (Etype (Container)) =
+ Base_Type (Etype (First_Formal (Default_Iter)))
+ then
+ Container_Arg := New_Copy_Tree (Container);
+
+ else
+ Container_Arg :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Etype (First_Formal (Default_Iter)), Loc),
+ Expression => New_Copy_Tree (Container));
+ end if;
+
+ Rewrite (Name (I_Spec),
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Default_Iter, Loc),
+ Parameter_Associations =>
+ New_List (Container_Arg)));
+ Analyze_And_Resolve (Name (I_Spec));
+
+ -- Find cursor type in proper iterator package, which is an
+ -- instantiation of Iterator_Interfaces.
+
+ Ent := First_Entity (Pack);
+ while Present (Ent) loop
+ if Chars (Ent) = Name_Cursor then
+ Set_Etype (Cursor, Etype (Ent));
+ exit;
+ end if;
+ Next_Entity (Ent);
+ end loop;
-- Generate:
- -- declare
- -- Id : Element_Type := Pack.Element (Cursor);
- -- begin
- -- <original loop statments>
- -- end;
+ -- Id : Element_Type renames Container (Cursor);
+ -- This assumes that the container type has an indexing
+ -- operation with Cursor. The check that this operation
+ -- exists is performed in Check_Container_Indexing.
- Stats := New_List (
- Make_Block_Statement (Loc,
- Declarations => New_List (Decl),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stats)));
- else
- Prepend_To (Stats, Decl);
- end if;
+ Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Id,
+ Subtype_Mark =>
+ New_Reference_To (Element_Type, Loc),
+ Name =>
+ Make_Indexed_Component (Loc,
+ Prefix => Relocate_Node (Container_Arg),
+ Expressions =>
+ New_List (New_Occurrence_Of (Cursor, Loc))));
+
+ -- If the container holds controlled objects, wrap the loop
+ -- statements and element renaming declaration with a block.
+ -- This ensures that the result of Element (Cusor) is
+ -- cleaned up after each iteration of the loop.
+
+ if Needs_Finalization (Element_Type) then
+
+ -- Generate:
+ -- declare
+ -- Id : Element_Type := Element (curosr);
+ -- begin
+ -- <original loop statements>
+ -- end;
+
+ Stats := New_List (
+ Make_Block_Statement (Loc,
+ Declarations => New_List (Decl),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stats)));
+
+ -- Elements do not need finalization
+
+ else
+ Prepend_To (Stats, Decl);
+ end if;
+ end;
+
+ -- X in Iterate (S) : type of iterator is type of explicitly
+ -- given Iterate function, and the loop variable is the cursor.
+ -- It will be assigned in the loop and must be a variable.
+
+ else
+ Cursor := Id;
+ Set_Ekind (Cursor, E_Variable);
end if;
+ Iterator := Make_Temporary (Loc, 'I');
+
-- Determine the advancement and initialization steps for the
-- cursor.
- -- Must verify that the container has a reverse iterator ???
+ -- Analysis of the expanded loop will verify that the container
+ -- has a reverse iterator.
if Reverse_Present (I_Spec) then
Name_Init := Name_Last;
Name_Step := Name_Previous;
+
else
Name_Init := Name_First;
Name_Step := Name_Next;
-- For both iterator forms, add a call to the step operation to
-- advance the cursor. Generate:
- --
- -- Pack.[Next | Prev] (Cursor);
- Append_To (Stats,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Step)),
+ -- Cursor := Iterator.Next (Cursor);
+
+ -- or else
+
+ -- Cursor := Next (Cursor);
+
+ declare
+ Rhs : Node_Id;
+
+ begin
+ Rhs :=
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iterator, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Step)),
+ Parameter_Associations => New_List (
+ New_Reference_To (Cursor, Loc)));
- Parameter_Associations => New_List (
- New_Reference_To (Cursor, Loc))));
+ Append_To (Stats,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Cursor, Loc),
+ Expression => Rhs));
+ end;
-- Generate:
- -- while Cursor /= Pack.No_Element loop
+ -- while Iterator.Has_Element loop
-- <Stats>
-- end loop;
+ -- Has_Element is the second actual in the iterator package
+
New_Loop :=
Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- New_Reference_To (Cursor, Loc),
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_No_Element)))),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (
+ Next_Entity (First_Entity (Pack)), Loc),
+ Parameter_Associations =>
+ New_List (
+ New_Reference_To (Cursor, Loc)))),
+
Statements => Stats,
End_Label => Empty);
- Cntr := Relocate_Node (Container);
-
- -- When the container is provided by a function call, create an
- -- explicit renaming of the function result. Generate:
- --
- -- Cnn : Container_Typ renames Func_Call (...);
- --
- -- The renaming avoids the generation of a transient scope when
- -- initializing the cursor and the premature finalization of the
- -- container.
-
- if Nkind (Cntr) = N_Function_Call then
- declare
- Ren_Id : constant Entity_Id := Make_Temporary (Loc, 'C');
+ -- Create the declarations for Iterator and cursor and insert them
+ -- before the source loop. Given that the domain of iteration is
+ -- already an entity, the iterator is just a renaming of that
+ -- entity. Possible optimization ???
+ -- Generate:
- begin
- Insert_Action (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Ren_Id,
- Subtype_Mark =>
- New_Reference_To (Container_Typ, Loc),
- Name => Cntr));
+ -- I : Iterator_Type renames Container;
+ -- C : Cursor_Type := Container.[First | Last];
- Cntr := New_Reference_To (Ren_Id, Loc);
- end;
- end if;
+ Insert_Action (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Iterator,
+ Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
+ Name => Relocate_Node (Name (I_Spec))));
- -- Create the declaration of the cursor and insert it before the
- -- source loop. Generate:
- --
- -- C : Pack.Cursor_Type := Container.[First | Last];
+ -- Create declaration for cursor
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cursor,
- Object_Definition =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Reference_To (Pack, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Cursor)),
+ declare
+ Decl : Node_Id;
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => Cntr,
- Selector_Name =>
- Make_Identifier (Loc, Name_Init))));
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cursor,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Cursor), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Reference_To (Iterator, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Init)));
+
+ -- The cursor is only modified in expanded code, so it appears
+ -- as unassigned to the warning machinery. We must suppress
+ -- this spurious warning explicitly.
+
+ Set_Warnings_Off (Cursor);
+ Set_Assignment_OK (Decl);
+
+ Insert_Action (N, Decl);
+ end;
-- If the range of iteration is given by a function call that
-- returns a container, the finalization actions have been saved
return;
end if;
+ Process_Statements_For_Controlled_Objects (N);
+
-- Deal with condition for C/Fortran Boolean
if Present (Isc) then
Statements => Statements (N)))),
End_Label => End_Label (N)));
+
+ -- The loop parameter's entity must be removed from the loop
+ -- scope's entity list, since it will now be located in the
+ -- new block scope. Any other entities already associated with
+ -- the loop scope, such as the loop parameter's subtype, will
+ -- remain there.
+
+ pragma Assert (First_Entity (Scope (Loop_Id)) = Loop_Id);
+ Set_First_Entity (Scope (Loop_Id), Next_Entity (Loop_Id));
+
+ if Last_Entity (Scope (Loop_Id)) = Loop_Id then
+ Set_Last_Entity (Scope (Loop_Id), Empty);
+ end if;
+
Analyze (N);
-- Nothing to do with other cases of for loops
------------------------------
function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (N);
+ Asn : constant Node_Id := Relocate_Node (N);
L : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Res : constant List_Id := New_List;
T : constant Entity_Id := Underlying_Type (Etype (L));
+ Comp_Asn : constant Boolean := Is_Fully_Repped_Tagged_Type (T);
Ctrl_Act : constant Boolean := Needs_Finalization (T)
and then not No_Ctrl_Actions (N);
-
- Component_Assign : constant Boolean :=
- Is_Fully_Repped_Tagged_Type (T);
-
Save_Tag : constant Boolean := Is_Tagged_Type (T)
- and then not Component_Assign
+ and then not Comp_Asn
and then not No_Ctrl_Actions (N)
and then Tagged_Type_Expansion;
-- Tags are not saved and restored when VM_Target because VM tags are
-- represented implicitly in objects.
- Res : List_Id;
- Tag_Tmp : Entity_Id;
-
- Prev_Tmp : Entity_Id;
- Next_Tmp : Entity_Id;
- Ctrl_Ref : Node_Id;
+ Next_Id : Entity_Id;
+ Prev_Id : Entity_Id;
+ Tag_Id : Entity_Id;
begin
- Res := New_List;
-
-- Finalize the target of the assignment when controlled
-- We have two exceptions here:
null;
else
- Append_List_To (Res,
+ Append_To (Res,
Make_Final_Call
- (Ref => Duplicate_Subexpr_No_Checks (L),
- Typ => Etype (L),
- With_Detach => New_Reference_To (Standard_False, Loc)));
+ (Obj_Ref => Duplicate_Subexpr_No_Checks (L),
+ Typ => Etype (L)));
end if;
- -- Save the Tag in a local variable Tag_Tmp
+ -- Save the Tag in a local variable Tag_Id
if Save_Tag then
- Tag_Tmp := Make_Temporary (Loc, 'A');
+ Tag_Id := Make_Temporary (Loc, 'A');
Append_To (Res,
Make_Object_Declaration (Loc,
- Defining_Identifier => Tag_Tmp,
- Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
- Expression =>
+ Defining_Identifier => Tag_Id,
+ Object_Definition => New_Reference_To (RTE (RE_Tag), Loc),
+ Expression =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (L),
- Selector_Name => New_Reference_To (First_Tag_Component (T),
- Loc))));
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (T), Loc))));
- -- Otherwise Tag_Tmp not used
+ -- Otherwise Tag_Id is not used
else
- Tag_Tmp := Empty;
+ Tag_Id := Empty;
end if;
- if Ctrl_Act then
- if VM_Target /= No_VM then
-
- -- Cannot assign part of the object in a VM context, so instead
- -- fallback to the previous mechanism, even though it is not
- -- completely correct ???
-
- -- Save the Finalization Pointers in local variables Prev_Tmp and
- -- Next_Tmp. For objects with Has_Controlled_Component set, these
- -- pointers are in the Record_Controller
-
- Ctrl_Ref := Duplicate_Subexpr (L);
-
- if Has_Controlled_Component (T) then
- Ctrl_Ref :=
- Make_Selected_Component (Loc,
- Prefix => Ctrl_Ref,
- Selector_Name =>
- New_Reference_To (Controller_Component (T), Loc));
- end if;
-
- Prev_Tmp := Make_Temporary (Loc, 'B');
-
- Append_To (Res,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Prev_Tmp,
-
- Object_Definition =>
- New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
-
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Finalizable), Ctrl_Ref),
- Selector_Name => Make_Identifier (Loc, Name_Prev))));
-
- Next_Tmp := Make_Temporary (Loc, 'C');
-
- Append_To (Res,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Next_Tmp,
-
- Object_Definition =>
- New_Reference_To (RTE (RE_Finalizable_Ptr), Loc),
-
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Finalizable),
- New_Copy_Tree (Ctrl_Ref)),
- Selector_Name => Make_Identifier (Loc, Name_Next))));
-
- -- Do the Assignment
-
- Append_To (Res, Relocate_Node (N));
-
- else
- -- Regular (non VM) processing for controlled types and types with
- -- controlled components
-
- -- Variables of such types contain pointers used to chain them in
- -- finalization lists, in addition to user data. These pointers
- -- are specific to each object of the type, not to the value being
- -- assigned.
-
- -- Thus they need to be left intact during the assignment. We
- -- achieve this by constructing a Storage_Array subtype, and by
- -- overlaying objects of this type on the source and target of the
- -- assignment. The assignment is then rewritten to assignments of
- -- slices of these arrays, copying the user data, and leaving the
- -- pointers untouched.
-
- Controlled_Actions : declare
- Prev_Ref : Node_Id;
- -- A reference to the Prev component of the record controller
-
- First_After_Root : Node_Id := Empty;
- -- Index of first byte to be copied (used to skip
- -- Root_Controlled in controlled objects).
-
- Last_Before_Hole : Node_Id := Empty;
- -- Index of last byte to be copied before outermost record
- -- controller data.
-
- Hole_Length : Node_Id := Empty;
- -- Length of record controller data (Prev and Next pointers)
-
- First_After_Hole : Node_Id := Empty;
- -- Index of first byte to be copied after outermost record
- -- controller data.
-
- Expr, Source_Size : Node_Id;
- Source_Actual_Subtype : Entity_Id;
- -- Used for computation of the size of the data to be copied
-
- Range_Type : Entity_Id;
- Opaque_Type : Entity_Id;
-
- function Build_Slice
- (Rec : Entity_Id;
- Lo : Node_Id;
- Hi : Node_Id) return Node_Id;
- -- Build and return a slice of an array of type S overlaid on
- -- object Rec, with bounds specified by Lo and Hi. If either
- -- bound is empty, a default of S'First (respectively S'Last)
- -- is used.
-
- -----------------
- -- Build_Slice --
- -----------------
-
- function Build_Slice
- (Rec : Node_Id;
- Lo : Node_Id;
- Hi : Node_Id) return Node_Id
- is
- Lo_Bound : Node_Id;
- Hi_Bound : Node_Id;
-
- Opaque : constant Node_Id :=
- Unchecked_Convert_To (Opaque_Type,
- Make_Attribute_Reference (Loc,
- Prefix => Rec,
- Attribute_Name => Name_Address));
- -- Access value designating an opaque storage array of type
- -- S overlaid on record Rec.
-
- begin
- -- Compute slice bounds using S'First (1) and S'Last as
- -- default values when not specified by the caller.
-
- if No (Lo) then
- Lo_Bound := Make_Integer_Literal (Loc, 1);
- else
- Lo_Bound := Lo;
- end if;
-
- if No (Hi) then
- Hi_Bound := Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Range_Type, Loc),
- Attribute_Name => Name_Last);
- else
- Hi_Bound := Hi;
- end if;
-
- return Make_Slice (Loc,
- Prefix =>
- Opaque,
- Discrete_Range => Make_Range (Loc,
- Lo_Bound, Hi_Bound));
- end Build_Slice;
-
- -- Start of processing for Controlled_Actions
+ -- Save the Prev and Next fields on .NET/JVM. This is not needed on non
+ -- VM targets since the fields are not part of the object.
- begin
- -- Create a constrained subtype of Storage_Array whose size
- -- corresponds to the value being assigned.
-
- -- subtype G is Storage_Offset range
- -- 1 .. (Expr'Size + Storage_Unit - 1) / Storage_Unit
-
- Expr := Duplicate_Subexpr_No_Checks (Expression (N));
-
- if Nkind (Expr) = N_Qualified_Expression then
- Expr := Expression (Expr);
- end if;
-
- Source_Actual_Subtype := Etype (Expr);
-
- if Has_Discriminants (Source_Actual_Subtype)
- and then not Is_Constrained (Source_Actual_Subtype)
- then
- Append_To (Res,
- Build_Actual_Subtype (Source_Actual_Subtype, Expr));
- Source_Actual_Subtype := Defining_Identifier (Last (Res));
- end if;
-
- Source_Size :=
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Source_Actual_Subtype, Loc),
- Attribute_Name => Name_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => System_Storage_Unit - 1));
-
- Source_Size :=
- Make_Op_Divide (Loc,
- Left_Opnd => Source_Size,
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => System_Storage_Unit));
-
- Range_Type := Make_Temporary (Loc, 'G');
-
- Append_To (Res,
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Range_Type,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Storage_Offset), Loc),
- Constraint => Make_Range_Constraint (Loc,
- Range_Expression =>
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Source_Size)))));
-
- -- subtype S is Storage_Array (G)
-
- Append_To (Res,
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'S'),
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Storage_Array), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints =>
- New_List (New_Reference_To (Range_Type, Loc))))));
-
- -- type A is access S
-
- Opaque_Type := Make_Temporary (Loc, 'A');
-
- Append_To (Res,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Opaque_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (
- Defining_Identifier (Last (Res)), Loc))));
-
- -- Generate appropriate slice assignments
-
- First_After_Root := Make_Integer_Literal (Loc, 1);
-
- -- For controlled object, skip Root_Controlled part
-
- if Is_Controlled (T) then
- First_After_Root :=
- Make_Op_Add (Loc,
- First_After_Root,
- Make_Op_Divide (Loc,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Root_Controlled), Loc),
- Attribute_Name => Name_Size),
- Make_Integer_Literal (Loc, System_Storage_Unit)));
- end if;
-
- -- For the case of a record with controlled components, skip
- -- record controller Prev/Next components. These components
- -- constitute a 'hole' in the middle of the data to be copied.
-
- if Has_Controlled_Component (T) then
- Prev_Ref :=
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (L),
- Selector_Name =>
- New_Reference_To (Controller_Component (T), Loc)),
- Selector_Name => Make_Identifier (Loc, Name_Prev));
-
- -- Last index before hole: determined by position of the
- -- _Controller.Prev component.
-
- Last_Before_Hole := Make_Temporary (Loc, 'L');
-
- Append_To (Res,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Last_Before_Hole,
- Object_Definition => New_Occurrence_Of (
- RTE (RE_Storage_Offset), Loc),
- Constant_Present => True,
- Expression =>
- Make_Op_Add (Loc,
- Make_Attribute_Reference (Loc,
- Prefix => Prev_Ref,
- Attribute_Name => Name_Position),
- Make_Attribute_Reference (Loc,
- Prefix => New_Copy_Tree (Prefix (Prev_Ref)),
- Attribute_Name => Name_Position))));
-
- -- Hole length: size of the Prev and Next components
-
- Hole_Length :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Make_Integer_Literal (Loc, Uint_2),
- Right_Opnd =>
- Make_Op_Divide (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Copy_Tree (Prev_Ref),
- Attribute_Name => Name_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => System_Storage_Unit)));
-
- -- First index after hole
-
- First_After_Hole := Make_Temporary (Loc, 'F');
+ if VM_Target /= No_VM
+ and then Is_Controlled (T)
+ then
+ Prev_Id := Make_Temporary (Loc, 'P');
+ Next_Id := Make_Temporary (Loc, 'N');
- Append_To (Res,
- Make_Object_Declaration (Loc,
- Defining_Identifier => First_After_Hole,
- Object_Definition => New_Occurrence_Of (
- RTE (RE_Storage_Offset), Loc),
- Constant_Present => True,
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Op_Add (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Last_Before_Hole, Loc),
- Right_Opnd => Hole_Length),
- Right_Opnd => Make_Integer_Literal (Loc, 1))));
-
- Last_Before_Hole :=
- New_Occurrence_Of (Last_Before_Hole, Loc);
- First_After_Hole :=
- New_Occurrence_Of (First_After_Hole, Loc);
- end if;
+ -- Generate:
+ -- Pnn : Root_Controlled_Ptr := Root_Controlled (L).Prev;
- -- Assign the first slice (possibly skipping Root_Controlled,
- -- up to the beginning of the record controller if present,
- -- up to the end of the object if not).
-
- Append_To (Res, Make_Assignment_Statement (Loc,
- Name => Build_Slice (
- Rec => Duplicate_Subexpr_No_Checks (L),
- Lo => First_After_Root,
- Hi => Last_Before_Hole),
-
- Expression => Build_Slice (
- Rec => Expression (N),
- Lo => First_After_Root,
- Hi => New_Copy_Tree (Last_Before_Hole))));
-
- if Present (First_After_Hole) then
-
- -- If a record controller is present, copy the second slice,
- -- from right after the _Controller.Next component up to the
- -- end of the object.
-
- Append_To (Res, Make_Assignment_Statement (Loc,
- Name => Build_Slice (
- Rec => Duplicate_Subexpr_No_Checks (L),
- Lo => First_After_Hole,
- Hi => Empty),
- Expression => Build_Slice (
- Rec => Duplicate_Subexpr_No_Checks (Expression (N)),
- Lo => New_Copy_Tree (First_After_Hole),
- Hi => Empty)));
- end if;
- end Controlled_Actions;
- end if;
+ Append_To (Res,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Prev_Id,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Prev))));
- -- Not controlled case
+ -- Generate:
+ -- Nnn : Root_Controlled_Ptr := Root_Controlled (L).Next;
- else
- declare
- Asn : constant Node_Id := Relocate_Node (N);
+ Append_To (Res,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Next_Id,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Root_Controlled_Ptr), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Next))));
+ end if;
- begin
- -- If this is the case of a tagged type with a full rep clause,
- -- we must expand it into component assignments, so we mark the
- -- node as unanalyzed, to get it reanalyzed, but flag it has
- -- requiring component-wise assignment so we don't get infinite
- -- recursion.
-
- if Component_Assign then
- Set_Analyzed (Asn, False);
- Set_Componentwise_Assignment (Asn, True);
- end if;
+ -- If the tagged type has a full rep clause, expand the assignment into
+ -- component-wise assignments. Mark the node as unanalyzed in order to
+ -- generate the proper code and propagate this scenario by setting a
+ -- flag to avoid infinite recursion.
- Append_To (Res, Asn);
- end;
+ if Comp_Asn then
+ Set_Analyzed (Asn, False);
+ Set_Componentwise_Assignment (Asn, True);
end if;
+ Append_To (Res, Asn);
+
-- Restore the tag
if Save_Tag then
Append_To (Res,
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr_No_Checks (L),
- Selector_Name => New_Reference_To (First_Tag_Component (T),
- Loc)),
- Expression => New_Reference_To (Tag_Tmp, Loc)));
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (T), Loc)),
+ Expression => New_Reference_To (Tag_Id, Loc)));
end if;
- if Ctrl_Act then
- if VM_Target /= No_VM then
- -- Restore the finalization pointers
+ -- Restore the Prev and Next fields on .NET/JVM
- Append_To (Res,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Finalizable),
- New_Copy_Tree (Ctrl_Ref)),
- Selector_Name => Make_Identifier (Loc, Name_Prev)),
- Expression => New_Reference_To (Prev_Tmp, Loc)));
+ if VM_Target /= No_VM
+ and then Is_Controlled (T)
+ then
+ -- Generate:
+ -- Root_Controlled (L).Prev := Prev_Id;
- Append_To (Res,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_Finalizable),
- New_Copy_Tree (Ctrl_Ref)),
- Selector_Name => Make_Identifier (Loc, Name_Next)),
- Expression => New_Reference_To (Next_Tmp, Loc)));
- end if;
+ Append_To (Res,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Prev)),
+ Expression => New_Reference_To (Prev_Id, Loc)));
- -- Adjust the target after the assignment when controlled (not in the
- -- init proc since it is an initialization more than an assignment).
+ -- Generate:
+ -- Root_Controlled (L).Next := Next_Id;
- Append_List_To (Res,
- Make_Adjust_Call (
- Ref => Duplicate_Subexpr_Move_Checks (L),
- Typ => Etype (L),
- Flist_Ref => New_Reference_To (RTE (RE_Global_Final_List), Loc),
- With_Attach => Make_Integer_Literal (Loc, 0)));
+ Append_To (Res,
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (RTE (RE_Root_Controlled), New_Copy_Tree (L)),
+ Selector_Name => Make_Identifier (Loc, Name_Next)),
+ Expression => New_Reference_To (Next_Id, Loc)));
+ end if;
+
+ -- Adjust the target after the assignment when controlled (not in the
+ -- init proc since it is an initialization more than an assignment).
+
+ if Ctrl_Act then
+ Append_To (Res,
+ Make_Adjust_Call
+ (Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
+ Typ => Etype (L)));
end if;
return Res;
exception
+
-- Could use comment here ???
when RE_Not_Available =>
OSDN Git Service
