-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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 Exp_Ch9; use Exp_Ch9;
with Exp_Tss; use Exp_Tss;
with Freeze; use Freeze;
-with Hostparm; use Hostparm;
with Itypes; use Itypes;
with Lib; use Lib;
+with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
- Target : Node_Id;
+ Lhs : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
- Expression : Node_Id;
- Self_Ref : Boolean := False) return Node_Id;
+ Expression : Node_Id) return Node_Id;
-- This is like Make_Assignment_Statement, except that Assignment_OK
-- is set in the left operand. All assignments built by this unit
-- use this routine. This is needed to deal with assignments to
-- initialized constants that are done in place.
- -- If Self_Ref is true, the aggregate contains an access reference to the
- -- enclosing type, obtained from a default initialization. The reference
- -- as to be expanded into a reference to the enclosing object, which is
- -- obtained from the Name in the assignment. The value of Self_Ref is
- -- inherited from the aggregate itself.
function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
-- Given an array aggregate, this function handles the case of a packed
-- 4. The array type of N does not follow the Fortran layout convention
-- or if it does it must be 1 dimensional.
- -- 5. The array component type is tagged, which may necessitate
- -- reassignment of proper tags.
+ -- 5. The array component type may not be tagged (which could necessitate
+ -- reassignment of proper tags).
- -- 6. The array component type might have unaligned bit components
+ -- 6. The array component type must not have unaligned bit components
+
+ -- 7. None of the components of the aggregate may be bit unaligned
+ -- components.
+
+ -- 8. There cannot be delayed components, since we do not know enough
+ -- at this stage to know if back end processing is possible.
+
+ -- 9. There cannot be any discriminated record components, since the
+ -- back end cannot handle this complex case.
function Backend_Processing_Possible (N : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (N);
-- Typ is the correct constrained array subtype of the aggregate
- function Static_Check (N : Node_Id; Index : Node_Id) return Boolean;
- -- Recursively checks that N is fully positional, returns true if so
+ function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
+ -- This routine checks components of aggregate N, enforcing checks
+ -- 1, 7, 8, and 9. In the multi-dimensional case, these checks are
+ -- performed on subaggregates. The Index value is the current index
+ -- being checked in the multi-dimensional case.
- ------------------
- -- Static_Check --
- ------------------
+ ---------------------
+ -- Component_Check --
+ ---------------------
- function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is
+ function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
Expr : Node_Id;
begin
- -- Check for component associations
+ -- Checks 1: (no component associations)
if Present (Component_Associations (N)) then
return False;
end if;
+ -- Checks on components
+
-- Recurse to check subaggregates, which may appear in qualified
-- expressions. If delayed, the front-end will have to expand.
-- If the component is a discriminated record, treat as non-static,
Expr := First (Expressions (N));
while Present (Expr) loop
+
+ -- Checks 8: (no delayed components)
+
if Is_Delayed_Aggregate (Expr) then
return False;
end if;
+ -- Checks 9: (no discriminated records)
+
if Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr))
and then Has_Discriminants (Etype (Expr))
return False;
end if;
+ -- Checks 7. Component must not be bit aligned component
+
+ if Possible_Bit_Aligned_Component (Expr) then
+ return False;
+ end if;
+
+ -- Recursion to following indexes for multiple dimension case
+
if Present (Next_Index (Index))
- and then not Static_Check (Expr, Next_Index (Index))
+ and then not Component_Check (Expr, Next_Index (Index))
then
return False;
end if;
+ -- All checks for that component finished, on to next
+
Next (Expr);
end loop;
return True;
- end Static_Check;
+ end Component_Check;
-- Start of processing for Backend_Processing_Possible
return False;
end if;
- -- Checks 1 (aggregate must be fully positional)
+ -- Checks on components
- if not Static_Check (N, First_Index (Typ)) then
+ if not Component_Check (N, First_Index (Typ)) then
return False;
end if;
- -- Checks 5 (if the component type is tagged, then we may need
- -- to do tag adjustments; perhaps this should be refined to check for
- -- any component associations that actually need tag adjustment,
- -- along the lines of the test that is carried out in
- -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
+ -- Checks 5 (if the component type is tagged, then we may need to do
+ -- tag adjustments. Perhaps this should be refined to check for any
+ -- component associations that actually need tag adjustment, similar
+ -- to the test in Component_Not_OK_For_Backend for record aggregates
-- with tagged components, but not clear whether it's worthwhile ???;
-- in the case of the JVM, object tags are handled implicitly)
- if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
+ if Is_Tagged_Type (Component_Type (Typ)) and then VM_Target = No_VM then
return False;
end if;
-- Backend processing is possible
- Set_Compile_Time_Known_Aggregate (N, True);
Set_Size_Known_At_Compile_Time (Etype (N), True);
return True;
end Backend_Processing_Possible;
if Present (Comp_Type)
and then Is_Tagged_Type (Comp_Type)
- and then not Java_VM
+ and then VM_Target = No_VM
then
A :=
Make_OK_Assignment_Statement (Loc,
Append_To (L, A);
end if;
- -- Adjust and Attach the component to the proper final list
- -- which can be the controller of the outer record object or
- -- the final list associated with the scope
+ -- Adjust and attach the component to the proper final list, which
+ -- can be the controller of the outer record object or the final
+ -- list associated with the scope.
- if Present (Comp_Type) and then Controlled_Type (Comp_Type) then
+ -- If the component is itself an array of controlled types, whose
+ -- value is given by a sub-aggregate, then the attach calls have
+ -- been generated when individual subcomponent are assigned, and
+ -- and must not be done again to prevent malformed finalization
+ -- chains (see comments above, concerning the creation of a block
+ -- to hold inner finalization actions).
+
+ if Present (Comp_Type)
+ and then Controlled_Type (Comp_Type)
+ and then
+ (not Is_Array_Type (Comp_Type)
+ or else not Is_Controlled (Component_Type (Comp_Type))
+ or else Nkind (Expr) /= N_Aggregate)
+ then
Append_List_To (L,
Make_Adjust_Call (
Ref => New_Copy_Tree (Indexed_Comp),
Iteration_Scheme => L_Iteration_Scheme,
Statements => L_Body));
- return S;
+ -- A small optimization: if the aggregate is initialized with a
+ -- box and the component type has no initialization procedure,
+ -- remove the useless empty loop.
+
+ if Nkind (First (S)) = N_Loop_Statement
+ and then Is_Empty_List (Statements (First (S)))
+ then
+ return New_List (Make_Null_Statement (Loc));
+ else
+ return S;
+ end if;
end Gen_Loop;
---------------
function Build_Record_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
- Target : Node_Id;
+ Lhs : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
Comp : Node_Id;
Instr : Node_Id;
Ref : Node_Id;
+ Target : Entity_Id;
F : Node_Id;
Comp_Type : Entity_Id;
Selector : Entity_Id;
Attach : Node_Id;
Ctrl_Stuff_Done : Boolean := False;
- -- Could use comments here ???
+ -- True if Gen_Ctrl_Actions_For_Aggr has already been called; calls
+ -- after the first do nothing.
function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
-- Returns the value that the given discriminant of an ancestor
-- assumed that both bounds are integer ranges.
procedure Gen_Ctrl_Actions_For_Aggr;
- -- Deal with the various controlled type data structure
- -- initializations.
+ -- Deal with the various controlled type data structure initializations
+ -- (but only if it hasn't been done already).
function Get_Constraint_Association (T : Entity_Id) return Node_Id;
-- Returns the first discriminant association in the constraint
F : Node_Id;
Attach : Node_Id;
Init_Pr : Boolean) return List_Id;
- -- returns the list of statements necessary to initialize the internal
- -- controller of the (possible) ancestor typ into target and attach
- -- it to finalization list F. Init_Pr conditions the call to the
- -- init proc since it may already be done due to ancestor initialization
+ -- Returns the list of statements necessary to initialize the internal
+ -- controller of the (possible) ancestor typ into target and attach it
+ -- to finalization list F. Init_Pr conditions the call to the init proc
+ -- since it may already be done due to ancestor initialization.
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds
end Get_Constraint_Association;
---------------------
- -- Init_controller --
+ -- Init_Controller --
---------------------
function Init_Controller
-------------------------------
procedure Gen_Ctrl_Actions_For_Aggr is
+ Alloc : Node_Id := Empty;
+
begin
- if not Ctrl_Stuff_Done then
- Ctrl_Stuff_Done := True;
- else
+ -- Do the work only the first time this is called
+
+ if Ctrl_Stuff_Done then
return;
end if;
+ Ctrl_Stuff_Done := True;
+
if Present (Obj)
- and then Finalize_Storage_Only (Typ)
- and then (Is_Library_Level_Entity (Obj)
- or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
- Standard_True)
+ and then Finalize_Storage_Only (Typ)
+ and then
+ (Is_Library_Level_Entity (Obj)
+ or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
+ Standard_True)
+
+ -- why not Is_True (Expr_Value (RTE (RE_Garbaage_Collected) ???
then
Attach := Make_Integer_Literal (Loc, 0);
elsif Nkind (Parent (N)) = N_Qualified_Expression
and then Nkind (Parent (Parent (N))) = N_Allocator
then
+ Alloc := Parent (Parent (N));
Attach := Make_Integer_Literal (Loc, 2);
else
-- potentially transient current scope.
if Controlled_Type (Typ) then
- if Present (Flist) then
+
+ -- The current aggregate belongs to an allocator which acts as
+ -- the root of a coextension chain.
+
+ if Present (Alloc)
+ and then Is_Coextension_Root (Alloc)
+ then
+ if No (Associated_Final_Chain (Etype (Alloc))) then
+ Build_Final_List (Alloc, Etype (Alloc));
+ end if;
+
+ External_Final_List :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Reference_To (
+ Associated_Final_Chain (Etype (Alloc)), Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_F));
+
+ elsif Present (Flist) then
External_Final_List := New_Copy_Tree (Flist);
elsif Is_Entity_Name (Target)
and then Present (Scope (Entity (Target)))
then
- External_Final_List
- := Find_Final_List (Scope (Entity (Target)));
+ External_Final_List :=
+ Find_Final_List (Scope (Entity (Target)));
else
External_Final_List := Find_Final_List (Current_Scope);
end if;
-
else
External_Final_List := Empty;
end if;
if not Has_Controlled_Component (Typ) then
Ref := New_Copy_Tree (Target);
Set_Assignment_OK (Ref);
- Append_To (L,
- Make_Attach_Call (
- Obj_Ref => Ref,
- Flist_Ref => New_Copy_Tree (External_Final_List),
- With_Attach => Attach));
+
+ -- This is an aggregate of a coextension. Do not produce a
+ -- finalization call, but rather attach the reference of the
+ -- aggregate to its coextension chain.
+
+ if Present (Alloc)
+ and then Is_Coextension (Alloc)
+ then
+ if No (Coextensions (Alloc)) then
+ Set_Coextensions (Alloc, New_Elmt_List);
+ end if;
+
+ Append_Elmt (Ref, Coextensions (Alloc));
+ else
+ Append_To (L,
+ Make_Attach_Call (
+ Obj_Ref => Ref,
+ Flist_Ref => New_Copy_Tree (External_Final_List),
+ With_Attach => Attach));
+ end if;
end if;
end if;
Typ => Init_Typ,
F => F,
Attach => Attach,
- Init_Pr => Ancestor_Is_Expression));
+ Init_Pr => False));
+
+ -- Note: Init_Pr is False because the ancestor part has
+ -- already been initialized either way (by default, if
+ -- given by a type name, otherwise from the expression).
+
end if;
end;
end if;
end Gen_Ctrl_Actions_For_Aggr;
+ function Replace_Type (Expr : Node_Id) return Traverse_Result;
+ -- If the aggregate contains a self-reference, traverse each
+ -- expression to replace a possible self-reference with a reference
+ -- to the proper component of the target of the assignment.
+
+ ------------------
+ -- Replace_Type --
+ ------------------
+
+ function Replace_Type (Expr : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Expr))
+ and then Is_Type (Entity (Prefix (Expr)))
+ then
+ if Is_Entity_Name (Lhs) then
+ Rewrite (Prefix (Expr),
+ New_Occurrence_Of (Entity (Lhs), Loc));
+
+ elsif Nkind (Lhs) = N_Selected_Component then
+ Rewrite (Expr,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unrestricted_Access,
+ Prefix => New_Copy_Tree (Prefix (Lhs))));
+ Set_Analyzed (Parent (Expr), False);
+
+ else
+ Rewrite (Expr,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unrestricted_Access,
+ Prefix => New_Copy_Tree (Lhs)));
+ Set_Analyzed (Parent (Expr), False);
+ end if;
+ end if;
+
+ return OK;
+ end Replace_Type;
+
+ procedure Replace_Self_Reference is
+ new Traverse_Proc (Replace_Type);
+
-- Start of processing for Build_Record_Aggr_Code
begin
+ if Has_Self_Reference (N) then
+ Replace_Self_Reference (N);
+ end if;
+
+ -- If the target of the aggregate is class-wide, we must convert it
+ -- to the actual type of the aggregate, so that the proper components
+ -- are visible. We know already that the types are compatible.
+
+ if Present (Etype (Lhs))
+ and then Is_Interface (Etype (Lhs))
+ then
+ Target := Unchecked_Convert_To (Typ, Lhs);
+ else
+ Target := Lhs;
+ end if;
+
-- Deal with the ancestor part of extension aggregates
-- or with the discriminants of the root type
if Nkind (N) = N_Extension_Aggregate then
declare
- A : constant Node_Id := Ancestor_Part (N);
+ A : constant Node_Id := Ancestor_Part (N);
Assign : List_Id;
begin
Build_Record_Aggr_Code (
N => Unqualify (A),
Typ => Etype (Unqualify (A)),
- Target => Target,
+ Lhs => Target,
Flist => Flist,
Obj => Obj,
Is_Limited_Ancestor_Expansion => True));
Assign := New_List (
Make_OK_Assignment_Statement (Loc,
Name => Ref,
- Expression => A,
- Self_Ref => Has_Self_Reference (N)));
+ Expression => A));
Set_No_Ctrl_Actions (First (Assign));
-- Assign the tag now to make sure that the dispatching call in
- -- the subsequent deep_adjust works properly (unless Java_VM,
+ -- the subsequent deep_adjust works properly (unless VM_Target,
-- where tags are implicit).
- if not Java_VM then
+ if VM_Target = No_VM then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
Set_Assignment_OK (Name (Instr));
Append_To (Assign, Instr);
+
+ -- Ada 2005 (AI-251): If tagged type has progenitors we must
+ -- also initialize tags of the secondary dispatch tables.
+
+ if Present (Abstract_Interfaces (Base_Type (Typ)))
+ and then not
+ Is_Empty_Elmt_List
+ (Abstract_Interfaces (Base_Type (Typ)))
+ then
+ Init_Secondary_Tags
+ (Typ => Base_Type (Typ),
+ Target => Target,
+ Stmts_List => Assign);
+ end if;
end if;
-- Call Adjust manually
Instr :=
Make_OK_Assignment_Statement (Loc,
Name => Comp_Expr,
- Expression => Expression (Comp),
- Self_Ref => Has_Self_Reference (N));
+ Expression => Expression (Comp));
Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr);
-- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for the Java VM
- -- where tags are implicit.
+ -- conversions), unless compiling for a VM where tags are
+ -- implicit.
-- tmp.comp._tag := comp_typ'tag;
- if Is_Tagged_Type (Comp_Type) and then not Java_VM then
+ if Is_Tagged_Type (Comp_Type) and then VM_Target = No_VM then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
pragma Assert (Present (D_Val));
- Append_To (L,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => New_Copy_Tree (Node (D_Val)),
- Right_Opnd => Expression (Comp)),
- Reason => CE_Discriminant_Check_Failed));
+ -- This check cannot performed for components that are
+ -- constrained by a current instance, because this is not a
+ -- value that can be compared with the actual constraint.
+
+ if Nkind (Node (D_Val)) /= N_Attribute_Reference
+ or else not Is_Entity_Name (Prefix (Node (D_Val)))
+ or else not Is_Type (Entity (Prefix (Node (D_Val))))
+ then
+ Append_To (L,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => New_Copy_Tree (Node (D_Val)),
+ Right_Opnd => Expression (Comp)),
+ Reason => CE_Discriminant_Check_Failed));
+
+ else
+ -- Find self-reference in previous discriminant
+ -- assignment, and replace with proper expression.
+
+ declare
+ Ass : Node_Id;
+
+ begin
+ Ass := First (L);
+ while Present (Ass) loop
+ if Nkind (Ass) = N_Assignment_Statement
+ and then Nkind (Name (Ass)) = N_Selected_Component
+ and then Chars (Selector_Name (Name (Ass))) =
+ Chars (Disc)
+ then
+ Set_Expression
+ (Ass, New_Copy_Tree (Expression (Comp)));
+ exit;
+ end if;
+ Next (Ass);
+ end loop;
+ end;
+ end if;
end;
end if;
if Ancestor_Is_Expression then
null;
- elsif Is_Tagged_Type (Typ) and then not Java_VM then
+ elsif Is_Tagged_Type (Typ) and then VM_Target = No_VM then
Instr :=
Make_OK_Assignment_Statement (Loc,
Name =>
-- ??? Dubious actual for Obj: expect 'the original object
-- being initialized'
- Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
- Insert_Actions_After (Decl, L);
+ if Has_Task (Typ) then
+ Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
+ Insert_Actions_After (Decl, L);
+ else
+ Insert_Actions_After (Decl, Init_Stmts);
+ end if;
end;
else
return;
end if;
- if Requires_Transient_Scope (Typ) then
+ -- If the context is an extended return statement, it has its own
+ -- finalization machinery (i.e. works like a transient scope) and
+ -- we do not want to create an additional one, because objects on
+ -- the finalization list of the return must be moved to the caller's
+ -- finalization list to complete the return.
+
+ if Requires_Transient_Scope (Typ)
+ and then Ekind (Current_Scope) /= E_Return_Statement
+ then
Establish_Transient_Scope (Aggr, Sec_Stack =>
Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
end if;
end if;
-- Just set the Delay flag in the following cases where the
- -- transformation will be done top down from above
+ -- transformation will be done top down from above:
-- - internal aggregate (transformed when expanding the parent)
+
-- - allocators (see Convert_Aggr_In_Allocator)
+
-- - object decl (see Convert_Aggr_In_Object_Decl)
+
-- - safe assignments (see Convert_Aggr_Assignments)
-- so far only the assignments in the init procs are taken
-- into account
+ -- - (Ada 2005) A limited type in a return statement, which will
+ -- be rewritten as an extended return and may have its own
+ -- finalization machinery.
+
if Parent_Kind = N_Aggregate
or else Parent_Kind = N_Extension_Aggregate
or else Parent_Kind = N_Component_Association
or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
+ or else
+ (Is_Limited_Record (Typ)
+ and then Present (Parent (Parent (N)))
+ and then Nkind (Parent (Parent (N))) = N_Return_Statement)
then
Set_Expansion_Delayed (N);
return;
is
Typ : constant Entity_Id := Etype (N);
+ Static_Components : Boolean := True;
+
+ procedure Check_Static_Components;
+ -- Check whether all components of the aggregate are compile-time
+ -- known values, and can be passed as is to the back-end without
+ -- further expansion.
+
function Flatten
(N : Node_Id;
Ix : Node_Id;
-- Return True iff the array N is flat (which is not rivial
-- in the case of multidimensionsl aggregates).
+ -----------------------------
+ -- Check_Static_Components --
+ -----------------------------
+
+ procedure Check_Static_Components is
+ Expr : Node_Id;
+
+ begin
+ Static_Components := True;
+
+ if Nkind (N) = N_String_Literal then
+ null;
+
+ elsif Present (Expressions (N)) then
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ if Nkind (Expr) /= N_Aggregate
+ or else not Compile_Time_Known_Aggregate (Expr)
+ or else Expansion_Delayed (Expr)
+ then
+ Static_Components := False;
+ exit;
+ end if;
+
+ Next (Expr);
+ end loop;
+ end if;
+
+ if Nkind (N) = N_Aggregate
+ and then Present (Component_Associations (N))
+ then
+ Expr := First (Component_Associations (N));
+ while Present (Expr) loop
+ if Nkind (Expression (Expr)) = N_Integer_Literal then
+ null;
+
+ elsif Nkind (Expression (Expr)) /= N_Aggregate
+ or else
+ not Compile_Time_Known_Aggregate (Expression (Expr))
+ or else Expansion_Delayed (Expression (Expr))
+ then
+ Static_Components := False;
+ exit;
+ end if;
+
+ Next (Expr);
+ end loop;
+ end if;
+ end Check_Static_Components;
+
-------------
-- Flatten --
-------------
return True;
end if;
- -- Only handle bounds starting at the base type low bound
- -- for now since the compiler isn't able to handle different low
- -- bounds yet. Case such as new String'(3..5 => ' ') will get
- -- the wrong bounds, though it seems that the aggregate should
- -- retain the bounds set on its Etype (see C64103E and CC1311B).
+ if not Compile_Time_Known_Value (Lo)
+ or else not Compile_Time_Known_Value (Hi)
+ then
+ return False;
+ end if;
Lov := Expr_Value (Lo);
Hiv := Expr_Value (Hi);
if Hiv < Lov
or else not Compile_Time_Known_Value (Blo)
- or else (Lov /= Expr_Value (Blo))
then
return False;
end if;
return;
end if;
+ Check_Static_Components;
+
+ -- If the size is known, or all the components are static, try to
+ -- build a fully positional aggregate.
+
+ -- The size of the type may not be known for an aggregate with
+ -- discriminated array components, but if the components are static
+ -- it is still possible to verify statically that the length is
+ -- compatible with the upper bound of the type, and therefore it is
+ -- worth flattening such aggregates as well.
+
+ -- For now the back-end expands these aggregates into individual
+ -- assignments to the target anyway, but it is conceivable that
+ -- it will eventually be able to treat such aggregates statically???
+
if Aggr_Size_OK (Typ)
- and then
- Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
+ and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
then
+ if Static_Components then
+ Set_Compile_Time_Known_Aggregate (N);
+ Set_Expansion_Delayed (N, False);
+ end if;
+
Analyze_And_Resolve (N, Typ);
end if;
end Convert_To_Positional;
-- At this point we try to convert to positional form
- Convert_To_Positional (N);
+ if Ekind (Current_Scope) = E_Package
+ and then Static_Elaboration_Desired (Current_Scope)
+ then
+ Convert_To_Positional (N, Max_Others_Replicate => 100);
+
+ else
+ Convert_To_Positional (N);
+ end if;
-- if the result is no longer an aggregate (e.g. it may be a string
-- literal, or a temporary which has the needed value), then we are
return;
end if;
+ -- If all aggregate components are compile-time known and
+ -- the aggregate has been flattened, nothing left to do.
+
+ if Compile_Time_Known_Aggregate (N) then
+ Set_Expansion_Delayed (N, False);
+ return;
+ end if;
+
-- Now see if back end processing is possible
if Backend_Processing_Possible (N) then
or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc)
then
- Set_Expansion_Delayed (N);
- return;
+ if Static_Array_Aggregate (N)
+ or else Compile_Time_Known_Aggregate (N)
+ then
+ Set_Expansion_Delayed (N, False);
+ return;
+ else
+ Set_Expansion_Delayed (N);
+ return;
+ end if;
end if;
-- STEP 4
else
Expand_Array_Aggregate (N);
end if;
-
exception
when RE_Not_Available =>
return;
else
Set_Etype (N, Typ);
- -- No tag is needed in the case of Java_VM
-
- if Java_VM then
- Expand_Record_Aggregate (N,
- Parent_Expr => A);
- else
+ if VM_Target = No_VM then
Expand_Record_Aggregate (N,
Orig_Tag =>
New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
Parent_Expr => A);
+ else
+ -- No tag is needed in the case of a VM
+ Expand_Record_Aggregate (N,
+ Parent_Expr => A);
end if;
end if;
Typ : constant Entity_Id := Etype (N);
Base_Typ : constant Entity_Id := Base_Type (Typ);
- function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean;
- -- Checks the presence of a nested aggregate which needs Late_Expansion
- -- or the presence of tagged components which may need tag adjustment.
+ Static_Components : Boolean := True;
+ -- Flag to indicate whether all components are compile-time known,
+ -- and the aggregate can be constructed statically and handled by
+ -- the back-end.
- --------------------------------------------------
- -- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps --
- --------------------------------------------------
+ function Component_Not_OK_For_Backend return Boolean;
+ -- Check for presence of component which makes it impossible for the
+ -- backend to process the aggregate, thus requiring the use of a series
+ -- of assignment statements. Cases checked for are a nested aggregate
+ -- needing Late_Expansion, the presence of a tagged component which may
+ -- need tag adjustment, and a bit unaligned component reference.
- function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is
+ ----------------------------------
+ -- Component_Not_OK_For_Backend --
+ ----------------------------------
+
+ function Component_Not_OK_For_Backend return Boolean is
C : Node_Id;
Expr_Q : Node_Id;
-- These are cases where the source expression may have
-- a tag that could differ from the component tag (e.g.,
-- can occur for type conversions and formal parameters).
- -- (Tag adjustment is not needed if Java_VM because object
+ -- (Tag adjustment is not needed if VM_Target because object
-- tags are implicit in the JVM.)
if Is_Tagged_Type (Etype (Expr_Q))
and then (Nkind (Expr_Q) = N_Type_Conversion
- or else (Is_Entity_Name (Expr_Q)
- and then Ekind (Entity (Expr_Q)) in Formal_Kind))
- and then not Java_VM
+ or else (Is_Entity_Name (Expr_Q)
+ and then
+ Ekind (Entity (Expr_Q)) in Formal_Kind))
+ and then VM_Target = No_VM
then
+ Static_Components := False;
return True;
- end if;
- if Is_Delayed_Aggregate (Expr_Q) then
+ elsif Is_Delayed_Aggregate (Expr_Q) then
+ Static_Components := False;
+ return True;
+
+ elsif Possible_Bit_Aligned_Component (Expr_Q) then
+ Static_Components := False;
return True;
end if;
+ if Is_Scalar_Type (Etype (Expr_Q)) then
+ if not Compile_Time_Known_Value (Expr_Q) then
+ Static_Components := False;
+ end if;
+
+ elsif Nkind (Expr_Q) /= N_Aggregate
+ or else not Compile_Time_Known_Aggregate (Expr_Q)
+ then
+ Static_Components := False;
+ end if;
+
Next (C);
end loop;
return False;
- end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps;
+ end Component_Not_OK_For_Backend;
-- Remaining Expand_Record_Aggregate variables
elsif Has_Default_Init_Comps (N) then
Convert_To_Assignments (N, Typ);
- elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then
+ -- Check components
+
+ elsif Component_Not_OK_For_Backend then
Convert_To_Assignments (N, Typ);
-- If an ancestor is private, some components are not inherited and
elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
Convert_To_Assignments (N, Typ);
+ -- If the tagged types covers interface types we need to initialize all
+ -- the hidden components containing the pointers to secondary dispatch
+ -- tables.
+
+ elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then
+ Convert_To_Assignments (N, Typ);
+
-- If some components are mutable, the size of the aggregate component
-- may be disctinct from the default size of the type component, so
-- we need to expand to insure that the back-end copies the proper
-- can be handled by gigi.
else
+ if Nkind (N) = N_Aggregate then
+
+ -- If the aggregate is static and can be handled by the
+ -- back-end, nothing left to do.
+
+ if Static_Components then
+ Set_Compile_Time_Known_Aggregate (N);
+ Set_Expansion_Delayed (N, False);
+ end if;
+ end if;
+
-- If no discriminants, nothing special to do
if not Has_Discriminants (Typ) then
if Present (Orig_Tag) then
Tag_Value := Orig_Tag;
- elsif Java_VM then
+ elsif VM_Target /= No_VM then
Tag_Value := Empty;
else
Tag_Value :=
end;
-- For a root type, the tag component is added (unless compiling
- -- for the Java VM, where tags are implicit).
+ -- for the VMs, where tags are implicit).
- elsif not Java_VM then
+ elsif VM_Target = No_VM then
declare
Tag_Name : constant Node_Id :=
New_Occurrence_Of
end if;
end if;
end if;
+
end Expand_Record_Aggregate;
----------------------------
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
Name : Node_Id;
- Expression : Node_Id;
- Self_Ref : Boolean := False) return Node_Id
+ Expression : Node_Id) return Node_Id
is
- function Replace_Type (Expr : Node_Id) return Traverse_Result;
- -- If the aggregate contains a self-reference, traverse each
- -- expression to replace a possible self-reference with a reference
- -- to the proper component of the target of the assignment.
-
- ------------------
- -- Replace_Type --
- ------------------
-
- function Replace_Type (Expr : Node_Id) return Traverse_Result is
- begin
- if Nkind (Expr) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Expr))
- and then Is_Type (Entity (Prefix (Expr)))
- then
- if Is_Entity_Name (Prefix (Name)) then
- Rewrite (Prefix (Expr),
- New_Occurrence_Of (Entity (Prefix (Name)), Sloc));
- else
- Rewrite (Expr,
- Make_Attribute_Reference (Sloc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => New_Copy_Tree (Prefix (Name))));
- Set_Analyzed (Parent (Expr), False);
- end if;
- end if;
- return OK;
- end Replace_Type;
-
- procedure Replace_Self_Reference is
- new Traverse_Proc (Replace_Type);
-
- -- Start of processing for Make_OK_Assignment_Statement
-
begin
Set_Assignment_OK (Name);
- if Self_Ref then
- Replace_Self_Reference (Expression);
- end if;
-
return Make_Assignment_Statement (Sloc, Name, Expression);
end Make_OK_Assignment_Statement;
return False;
end if;
+ if not Is_Scalar_Type (Component_Type (Typ))
+ and then Has_Non_Standard_Rep (Component_Type (Typ))
+ then
+ return False;
+ end if;
+
declare
Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
end loop;
end Sort_Case_Table;
+ ----------------------------
+ -- Static_Array_Aggregate --
+ ----------------------------
+
+ function Static_Array_Aggregate (N : Node_Id) return Boolean is
+ Bounds : constant Node_Id := Aggregate_Bounds (N);
+
+ Typ : constant Entity_Id := Etype (N);
+ Comp_Type : constant Entity_Id := Component_Type (Typ);
+ Agg : Node_Id;
+ Expr : Node_Id;
+ Lo : Node_Id;
+ Hi : Node_Id;
+
+ begin
+ if Is_Tagged_Type (Typ)
+ or else Is_Controlled (Typ)
+ or else Is_Packed (Typ)
+ then
+ return False;
+ end if;
+
+ if Present (Bounds)
+ and then Nkind (Bounds) = N_Range
+ and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
+ and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
+ then
+ Lo := Low_Bound (Bounds);
+ Hi := High_Bound (Bounds);
+
+ if No (Component_Associations (N)) then
+
+ -- Verify that all components are static integers.
+
+ Expr := First (Expressions (N));
+ while Present (Expr) loop
+ if Nkind (Expr) /= N_Integer_Literal then
+ return False;
+ end if;
+
+ Next (Expr);
+ end loop;
+
+ return True;
+
+ else
+ -- We allow only a single named association, either a static
+ -- range or an others_clause, with a static expression.
+
+ Expr := First (Component_Associations (N));
+
+ if Present (Expressions (N)) then
+ return False;
+
+ elsif Present (Next (Expr)) then
+ return False;
+
+ elsif Present (Next (First (Choices (Expr)))) then
+ return False;
+
+ else
+ -- The aggregate is static if all components are literals,
+ -- or else all its components are static aggregates for the
+ -- component type.
+
+ if Is_Array_Type (Comp_Type)
+ or else Is_Record_Type (Comp_Type)
+ then
+ if Nkind (Expression (Expr)) /= N_Aggregate
+ or else
+ not Compile_Time_Known_Aggregate (Expression (Expr))
+ then
+ return False;
+ end if;
+
+ elsif Nkind (Expression (Expr)) /= N_Integer_Literal then
+ return False;
+ end if;
+
+ -- Create a positional aggregate with the right number of
+ -- copies of the expression.
+
+ Agg := Make_Aggregate (Sloc (N), New_List, No_List);
+
+ for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
+ loop
+ Append_To
+ (Expressions (Agg), New_Copy (Expression (Expr)));
+ Set_Etype (Last (Expressions (Agg)), Component_Type (Typ));
+ end loop;
+
+ Set_Aggregate_Bounds (Agg, Bounds);
+ Set_Etype (Agg, Typ);
+ Set_Analyzed (Agg);
+ Rewrite (N, Agg);
+ Set_Compile_Time_Known_Aggregate (N);
+
+ return True;
+ end if;
+ end if;
+
+ else
+ return False;
+ end if;
+ end Static_Array_Aggregate;
end Exp_Aggr;
projects / gcc.git / commitdiff