-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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 Atree; use Atree;
+with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
else
if No (Actions (Fnode)) then
Set_Actions (Fnode, L);
-
else
Append_List (L, Actions (Fnode));
end if;
-
end if;
end Append_Freeze_Actions;
-- local to the init proc for the array type, and is called for each one
-- of the components. The constructed image has the form of an indexed
-- component, whose prefix is the outer variable of the array type.
- -- The n-dimensional array type has known indices Index, Index2...
+ -- The n-dimensional array type has known indexes Index, Index2...
-- Id_Ref is an indexed component form created by the enclosing init proc.
- -- Its successive indices are Val1, Val2, ... which are the loop variables
+ -- Its successive indexes are Val1, Val2, ... which are the loop variables
-- in the loops that call the individual task init proc on each component.
-- The generated function has the following structure:
Pos : Entity_Id;
-- Running index for substring assignments
- Pref : Entity_Id;
+ Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
-- Name of enclosing variable, prefix of resulting name
Res : Entity_Id;
-- String to hold result
Val : Node_Id;
- -- Value of successive indices
+ -- Value of successive indexes
Sum : Node_Id;
-- Expression to compute total size of string
Stats : constant List_Id := New_List;
begin
- Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-
-- For a dynamic task, the name comes from the target variable.
-- For a static one it is a formal of the enclosing init proc.
Val := First (Expressions (Id_Ref));
for J in 1 .. Dims loop
- T := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+ T := Make_Temporary (Loc, 'T');
Temps (J) := T;
Append_To (Decls,
Expression =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Image,
- Prefix =>
- New_Occurrence_Of (Etype (Indx), Loc),
- Expressions => New_List (
- New_Copy_Tree (Val)))));
+ Prefix => New_Occurrence_Of (Etype (Indx), Loc),
+ Expressions => New_List (New_Copy_Tree (Val)))));
Next_Index (Indx);
Next (Val);
if Restriction_Active (No_Implicit_Heap_Allocations)
or else Global_Discard_Names
then
- T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+ T_Id := Make_Temporary (Loc, 'J');
Name_Len := 0;
return
Expression => New_Occurrence_Of (Res, Loc)));
Spec := Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
- Result_Definition => New_Occurrence_Of (Standard_String, Loc));
+ Defining_Unit_Name => Make_Temporary (Loc, 'F'),
+ Result_Definition => New_Occurrence_Of (Standard_String, Loc));
-- Calls to 'Image use the secondary stack, which must be cleaned
-- up after the task name is built.
Stats : List_Id)
is
begin
- Len := Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
+ Len := Make_Temporary (Loc, 'L', Sum);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Len,
- Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
- Expression => Sum));
+ Object_Definition => New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Sum));
- Res := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Res := Make_Temporary (Loc, 'R');
Append_To (Decls,
Make_Object_Declaration (Loc,
Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => New_Occurrence_Of (Len, Loc)))))));
- Pos := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Pos := Make_Temporary (Loc, 'P');
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Pos,
- Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
+ Object_Definition => New_Occurrence_Of (Standard_Integer, Loc)));
-- Pos := Prefix'Length;
Expression =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Prefix, Loc),
- Expressions =>
- New_List (Make_Integer_Literal (Loc, 1)))));
+ Prefix => New_Occurrence_Of (Prefix, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, 1)))));
-- Res (1 .. Pos) := Prefix;
Append_To (Stats,
- Make_Assignment_Statement (Loc,
- Name => Make_Slice (Loc,
- Prefix => New_Occurrence_Of (Res, Loc),
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Slice (Loc,
+ Prefix => New_Occurrence_Of (Res, Loc),
Discrete_Range =>
Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
+ Low_Bound => Make_Integer_Literal (Loc, 1),
High_Bound => New_Occurrence_Of (Pos, Loc))),
- Expression => New_Occurrence_Of (Prefix, Loc)));
+ Expression => New_Occurrence_Of (Prefix, Loc)));
Append_To (Stats,
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Pos, Loc),
+ Name => New_Occurrence_Of (Pos, Loc),
Expression =>
Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Pos, Loc),
+ Left_Opnd => New_Occurrence_Of (Pos, Loc),
Right_Opnd => Make_Integer_Literal (Loc, 1))));
end Build_Task_Image_Prefix;
Res : Entity_Id;
-- String to hold result
- Pref : Entity_Id;
+ Pref : constant Entity_Id := Make_Temporary (Loc, 'P');
-- Name of enclosing variable, prefix of resulting name
Sum : Node_Id;
Stats : constant List_Id := New_List;
begin
- Pref := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-
- -- For a dynamic task, the name comes from the target variable.
- -- For a static one it is a formal of the enclosing init proc.
+ -- For a dynamic task, the name comes from the target variable. For a
+ -- static one it is a formal of the enclosing init proc.
if Dyn then
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
Name => Make_Identifier (Loc, Name_uTask_Name)));
end if;
- Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Sel := Make_Temporary (Loc, 'S');
Get_Name_String (Chars (Selector_Name (Id_Ref)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Sel,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression =>
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer)));
----------------------------------
function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
+ UT : Entity_Id;
+
begin
-- If no component clause, then everything is fine, since the back end
-- never bit-misaligns by default, even if there is a pragma Packed for
-- the record.
- if No (Component_Clause (Comp)) then
+ if No (Comp) or else No (Component_Clause (Comp)) then
return False;
end if;
+ UT := Underlying_Type (Etype (Comp));
+
-- It is only array and record types that cause trouble
- if not Is_Record_Type (Etype (Comp))
- and then not Is_Array_Type (Etype (Comp))
+ if not Is_Record_Type (UT)
+ and then not Is_Array_Type (UT)
then
return False;
- -- If we know that we have a small (64 bits or less) record
- -- or bit-packed array, then everything is fine, since the
- -- back end can handle these cases correctly.
+ -- If we know that we have a small (64 bits or less) record or small
+ -- bit-packed array, then everything is fine, since the back end can
+ -- handle these cases correctly.
elsif Esize (Comp) <= 64
- and then (Is_Record_Type (Etype (Comp))
- or else Is_Bit_Packed_Array (Etype (Comp)))
+ and then (Is_Record_Type (UT)
+ or else Is_Bit_Packed_Array (UT))
then
return False;
IR : Node_Id;
begin
- -- An itype reference must only be created if this is a local
- -- itype, so that gigi can elaborate it on the proper objstack.
+ -- An itype reference must only be created if this is a local itype, so
+ -- that gigi can elaborate it on the proper objstack.
if Is_Itype (Typ)
and then Scope (Typ) = Current_Scope
begin
-- In general we cannot build the subtype if expansion is disabled,
-- because internal entities may not have been defined. However, to
- -- avoid some cascaded errors, we try to continue when the expression
- -- is an array (or string), because it is safe to compute the bounds.
- -- It is in fact required to do so even in a generic context, because
- -- there may be constants that depend on bounds of string literal.
+ -- avoid some cascaded errors, we try to continue when the expression is
+ -- an array (or string), because it is safe to compute the bounds. It is
+ -- in fact required to do so even in a generic context, because there
+ -- may be constants that depend on the bounds of a string literal, both
+ -- standard string types and more generally arrays of characters.
if not Expander_Active
and then (No (Etype (Exp))
- or else Base_Type (Etype (Exp)) /= Standard_String)
+ or else not Is_String_Type (Etype (Exp)))
then
return;
end if;
end if;
else
- T :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ T := Make_Temporary (Loc, 'T');
Insert_Action (N,
Make_Subtype_Declaration (Loc,
Rewrite (Subtype_Indic, New_Reference_To (T, Loc));
- -- nothing needs to be done for private types with unknown discriminants
- -- if the underlying type is not an unconstrained composite type.
+ -- Nothing needs to be done for private types with unknown discriminants
+ -- if the underlying type is not an unconstrained composite type or it
+ -- is an unchecked union.
elsif Is_Private_Type (Unc_Type)
and then Has_Unknown_Discriminants (Unc_Type)
and then (not Is_Composite_Type (Underlying_Type (Unc_Type))
- or else Is_Constrained (Underlying_Type (Unc_Type)))
+ or else Is_Constrained (Underlying_Type (Unc_Type))
+ or else Is_Unchecked_Union (Underlying_Type (Unc_Type)))
then
null;
pragma Assert (Is_Class_Wide_Type (Unc_Type));
null;
- -- In Ada95, nothing to be done if the type of the expression is
- -- limited, because in this case the expression cannot be copied,
- -- and its use can only be by reference.
+ -- In Ada95 nothing to be done if the type of the expression is limited,
+ -- because in this case the expression cannot be copied, and its use can
+ -- only be by reference.
-- In Ada2005, the context can be an object declaration whose expression
-- is a function that returns in place. If the nominal subtype has
-- Handle access types
if Is_Access_Type (Typ) then
- Typ := Directly_Designated_Type (Typ);
+ Typ := Designated_Type (Typ);
end if;
-- Handle task and protected types implementing interfaces
-- Handle access types
if Is_Access_Type (Typ) then
- Typ := Directly_Designated_Type (Typ);
+ Typ := Designated_Type (Typ);
end if;
-- Handle class-wide types
exit when Chars (Op) = Name
and then
(Name /= Name_Op_Eq
- or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op)));
+ or else Etype (First_Formal (Op)) = Etype (Last_Formal (Op)));
Next_Elmt (Prim);
Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
end Force_Evaluation;
+ ---------------------------------
+ -- Fully_Qualified_Name_String --
+ ---------------------------------
+
+ function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
+ procedure Internal_Full_Qualified_Name (E : Entity_Id);
+ -- Compute recursively the qualified name without NUL at the end, adding
+ -- it to the currently started string being generated
+
+ ----------------------------------
+ -- Internal_Full_Qualified_Name --
+ ----------------------------------
+
+ procedure Internal_Full_Qualified_Name (E : Entity_Id) is
+ Ent : Entity_Id;
+
+ begin
+ -- Deal properly with child units
+
+ if Nkind (E) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (E);
+ else
+ Ent := E;
+ end if;
+
+ -- Compute qualification recursively (only "Standard" has no scope)
+
+ if Present (Scope (Scope (Ent))) then
+ Internal_Full_Qualified_Name (Scope (Ent));
+ Store_String_Char (Get_Char_Code ('.'));
+ end if;
+
+ -- Every entity should have a name except some expanded blocks
+ -- don't bother about those.
+
+ if Chars (Ent) = No_Name then
+ return;
+ end if;
+
+ -- Generates the entity name in upper case
+
+ Get_Decoded_Name_String (Chars (Ent));
+ Set_All_Upper_Case;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ return;
+ end Internal_Full_Qualified_Name;
+
+ -- Start of processing for Full_Qualified_Name
+
+ begin
+ Start_String;
+ Internal_Full_Qualified_Name (E);
+ Store_String_Char (Get_Char_Code (ASCII.NUL));
+ return End_String;
+ end Fully_Qualified_Name_String;
+
------------------------
-- Generate_Poll_Call --
------------------------
if Nkind (Cond) = N_And_Then
or else Nkind (Cond) = N_Op_And
then
- -- Don't ever try to invert a condition that is of the form
- -- of an AND or AND THEN (since we are not doing sufficiently
- -- general processing to allow this).
+ -- Don't ever try to invert a condition that is of the form of an
+ -- AND or AND THEN (since we are not doing sufficiently general
+ -- processing to allow this).
if Sens = False then
Op := N_Empty;
end;
-- ELSIF part. Condition is known true within the referenced
- -- ELSIF, known False in any subsequent ELSIF or ELSE part, and
- -- unknown before the ELSE part or after the IF statement.
+ -- ELSIF, known False in any subsequent ELSIF or ELSE part,
+ -- and unknown before the ELSE part or after the IF statement.
elsif Nkind (CV) = N_Elsif_Part then
+
+ -- if the Elsif_Part had condition_actions, the elsif has been
+ -- rewritten as a nested if, and the original elsif_part is
+ -- detached from the tree, so there is no way to obtain useful
+ -- information on the current value of the variable.
+ -- Can this be improved ???
+
+ if No (Parent (CV)) then
+ return;
+ end if;
+
Stm := Parent (CV);
-- Before start of ELSIF part
begin
-- Only consider record types
- if Ekind (Typ) /= E_Record_Type
- and then Ekind (Typ) /= E_Record_Subtype
- then
+ if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then
return False;
end if;
if Ekind (D_Typ) = E_Anonymous_Access_Type
and then
- (Is_Controlled (Directly_Designated_Type (D_Typ))
+ (Is_Controlled (Designated_Type (D_Typ))
or else
- Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
+ Is_Concurrent_Type (Designated_Type (D_Typ)))
then
return True;
end if;
return False;
end Has_Controlled_Coextensions;
+ ------------------------
+ -- Has_Address_Clause --
+ ------------------------
+
+ -- Should this function check the private part in a package ???
+
+ function Has_Following_Address_Clause (D : Node_Id) return Boolean is
+ Id : constant Entity_Id := Defining_Identifier (D);
+ Decl : Node_Id;
+
+ begin
+ Decl := Next (D);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_At_Clause
+ and then Chars (Identifier (Decl)) = Chars (Id)
+ then
+ return True;
+
+ elsif Nkind (Decl) = N_Attribute_Definition_Clause
+ and then Chars (Decl) = Name_Address
+ and then Chars (Name (Decl)) = Chars (Id)
+ then
+ return True;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return False;
+ end Has_Following_Address_Clause;
+
--------------------
-- Homonym_Number --
--------------------
ElseX : constant Node_Id := Next (ThenX);
begin
- -- Actions belong to the then expression, temporarily
- -- place them as Then_Actions of the conditional expr.
- -- They will be moved to the proper place later when
- -- the conditional expression is expanded.
+ -- If the enclosing expression is already analyzed, as
+ -- is the case for nested elaboration checks, insert the
+ -- conditional further out.
- if N = ThenX then
+ if Analyzed (P) then
+ null;
+
+ -- Actions belong to the then expression, temporarily place
+ -- them as Then_Actions of the conditional expr. They will
+ -- be moved to the proper place later when the conditional
+ -- expression is expanded.
+
+ elsif N = ThenX then
if Present (Then_Actions (P)) then
Insert_List_After_And_Analyze
(Last (Then_Actions (P)), Ins_Actions);
end if;
end;
+ -- Alternative of case expression, we place the action in the
+ -- Actions field of the case expression alternative, this will
+ -- be handled when the case expression is expanded.
+
+ when N_Case_Expression_Alternative =>
+ if Present (Actions (P)) then
+ Insert_List_After_And_Analyze
+ (Last (Actions (P)), Ins_Actions);
+ else
+ Set_Actions (P, Ins_Actions);
+ Analyze_List (Then_Actions (P));
+ end if;
+
+ return;
+
+ -- Case of appearing within an Expressions_With_Actions node. We
+ -- prepend the actions to the list of actions already there, if
+ -- the node has not been analyzed yet. Otherwise find insertion
+ -- location further up the tree.
+
+ when N_Expression_With_Actions =>
+ if not Analyzed (P) then
+ Prepend_List (Ins_Actions, Actions (P));
+ return;
+ end if;
+
-- Case of appearing in the condition of a while expression or
-- elsif. We insert the actions into the Condition_Actions field.
-- They will be moved further out when the while loop or elsif
else
Set_Condition_Actions (P, Ins_Actions);
- -- Set the parent of the insert actions explicitly.
- -- This is not a syntactic field, but we need the
- -- parent field set, in particular so that freeze
- -- can understand that it is dealing with condition
- -- actions, and properly insert the freezing actions.
+ -- Set the parent of the insert actions explicitly. This
+ -- is not a syntactic field, but we need the parent field
+ -- set, in particular so that freeze can understand that
+ -- it is dealing with condition actions, and properly
+ -- insert the freezing actions.
Set_Parent (Ins_Actions, P);
Analyze_List (Condition_Actions (P));
N_Package_Declaration |
N_Package_Instantiation |
N_Package_Renaming_Declaration |
+ N_Parameterized_Expression |
N_Private_Extension_Declaration |
N_Private_Type_Declaration |
N_Procedure_Instantiation |
-- subsequent use in the back end: within a package spec the
-- loop is part of the elaboration procedure and is only
-- elaborated during the second pass.
+
-- If the loop comes from source, or the entity is local to
-- the loop itself it must remain within.
return;
end if;
- -- A special case, N_Raise_xxx_Error can act either as a
- -- statement or a subexpression. We tell the difference
- -- by looking at the Etype. It is set to Standard_Void_Type
- -- in the statement case.
+ -- A special case, N_Raise_xxx_Error can act either as a statement
+ -- or a subexpression. We tell the difference by looking at the
+ -- Etype. It is set to Standard_Void_Type in the statement case.
when
N_Raise_xxx_Error =>
Decl : Node_Id;
begin
- -- Check whether these actions were generated
- -- by a declaration that is part of the loop_
- -- actions for the component_association.
+ -- Check whether these actions were generated by a
+ -- declaration that is part of the loop_ actions
+ -- for the component_association.
Decl := Assoc_Node;
while Present (Decl) loop
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
+ N_Aspect_Specification |
+ N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Compilation_Unit |
N_Index_Or_Discriminant_Constraint |
N_Indexed_Component |
N_Integer_Literal |
+ N_Iterator_Specification |
N_Itype_Reference |
N_Label |
N_Loop_Parameter_Specification |
N_Push_Program_Error_Label |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
+ N_Quantified_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
N_Real_Range_Specification |
N_Record_Definition |
N_Reference |
+ N_SCIL_Dispatch_Table_Tag_Init |
+ N_SCIL_Dispatching_Call |
+ N_SCIL_Membership_Test |
N_Selected_Component |
N_Signed_Integer_Type_Definition |
N_Single_Protected_Declaration |
if Nkind (Parent (N)) = N_Subunit then
- -- This is the proper body corresponding to a stub. Insertion
- -- must be done at the point of the stub, which is in the decla-
- -- rative part of the parent unit.
+ -- This is the proper body corresponding to a stub. Insertion must
+ -- be done at the point of the stub, which is in the declarative
+ -- part of the parent unit.
P := Corresponding_Stub (Parent (N));
return True;
end Is_All_Null_Statements;
+ ---------------------------------
+ -- Is_Fully_Repped_Tagged_Type --
+ ---------------------------------
+
+ function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
+ U : constant Entity_Id := Underlying_Type (T);
+ Comp : Entity_Id;
+
+ begin
+ if No (U) or else not Is_Tagged_Type (U) then
+ return False;
+ elsif Has_Discriminants (U) then
+ return False;
+ elsif not Has_Specified_Layout (U) then
+ return False;
+ end if;
+
+ -- Here we have a tagged type, see if it has any unlayed out fields
+ -- other than a possible tag and parent fields. If so, we return False.
+
+ Comp := First_Component (U);
+ while Present (Comp) loop
+ if not Is_Tag (Comp)
+ and then Chars (Comp) /= Name_uParent
+ and then No (Component_Clause (Comp))
+ then
+ return False;
+ else
+ Next_Component (Comp);
+ end if;
+ end loop;
+
+ -- All components are layed out
+
+ return True;
+ end Is_Fully_Repped_Tagged_Type;
+
----------------------------------
-- Is_Library_Level_Tagged_Type --
----------------------------------
end if;
end if;
+ -- The following code is historical, it used to be present but it
+ -- is too cautious, because the front-end does not know the proper
+ -- default alignments for the target. Also, if the alignment is
+ -- not known, the front end can't know in any case! If a copy is
+ -- needed, the back-end will take care of it. This whole section
+ -- including this comment can be removed later ???
+
-- If the component reference is for a record that has a specified
-- alignment, and we either know it is too small, or cannot tell,
- -- then the component may be unaligned
+ -- then the component may be unaligned.
- if Known_Alignment (Etype (P))
- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
- and then M > Alignment (Etype (P))
- then
- return True;
- end if;
+ -- if Known_Alignment (Etype (P))
+ -- and then Alignment (Etype (P)) < Ttypes.Maximum_Alignment
+ -- and then M > Alignment (Etype (P))
+ -- then
+ -- return True;
+ -- end if;
-- Case of component clause present which may specify an
-- unaligned position.
function Is_Renamed_Object (N : Node_Id) return Boolean is
Pnod : constant Node_Id := Parent (N);
Kind : constant Node_Kind := Nkind (Pnod);
-
begin
if Kind = N_Object_Renaming_Declaration then
return True;
-
- elsif Kind = N_Indexed_Component
- or else Kind = N_Selected_Component
- then
+ elsif Nkind_In (Kind, N_Indexed_Component, N_Selected_Component) then
return Is_Renamed_Object (Pnod);
-
else
return False;
end if;
--------------------
procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
+ W : Boolean := Warn;
+ -- Set False if warnings suppressed
+
begin
if Present (N) then
Remove_Warning_Messages (N);
- if Warn then
- Error_Msg_F
- ("?this code can never be executed and has been deleted!", N);
+ -- Generate warning if appropriate
+
+ if W then
+
+ -- We suppress the warning if this code is under control of an
+ -- if statement, whose condition is a simple identifier, and
+ -- either we are in an instance, or warnings off is set for this
+ -- identifier. The reason for killing it in the instance case is
+ -- that it is common and reasonable for code to be deleted in
+ -- instances for various reasons.
+
+ if Nkind (Parent (N)) = N_If_Statement then
+ declare
+ C : constant Node_Id := Condition (Parent (N));
+ begin
+ if Nkind (C) = N_Identifier
+ and then
+ (In_Instance
+ or else (Present (Entity (C))
+ and then Has_Warnings_Off (Entity (C))))
+ then
+ W := False;
+ end if;
+ end;
+ end if;
+
+ -- Generate warning if not suppressed
+
+ if W then
+ Error_Msg_F
+ ("?this code can never be executed and has been deleted!", N);
+ end if;
end if;
-- Recurse into block statements and bodies to process declarations
- -- and statements
+ -- and statements.
if Nkind (N) = N_Block_Statement
or else Nkind (N) = N_Subprogram_Body
-- Make_CW_Equivalent_Type --
-----------------------------
- -- Create a record type used as an equivalent of any member
- -- of the class which takes its size from exp.
+ -- Create a record type used as an equivalent of any member of the class
+ -- which takes its size from exp.
-- Generate the following code:
Sizexpr : Node_Id;
begin
- if not Has_Discriminants (Root_Typ) then
+ -- If the root type is already constrained, there are no discriminants
+ -- in the expression.
+
+ if not Has_Discriminants (Root_Typ)
+ or else Is_Constrained (Root_Typ)
+ then
Constr_Root := Root_Typ;
else
- Constr_Root :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Constr_Root := Make_Temporary (Loc, 'R');
-- subtype cstr__n is T (List of discr constraints taken from Exp)
Append_To (List_Def,
Make_Subtype_Declaration (Loc,
Defining_Identifier => Constr_Root,
- Subtype_Indication =>
- Make_Subtype_From_Expr (E, Root_Typ)));
+ Subtype_Indication => Make_Subtype_From_Expr (E, Root_Typ)));
end if;
-- Generate the range subtype declaration
- Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
+ Range_Type := Make_Temporary (Loc, 'G');
if not Is_Interface (Root_Typ) then
+
-- subtype rg__xx is
-- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
-- subtype str__nn is Storage_Array (rg__x);
- Str_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Str_Type := Make_Temporary (Loc, 'S');
Append_To (List_Def,
Make_Subtype_Declaration (Loc,
Defining_Identifier => Str_Type,
-- E : Str_Type;
-- end Equiv_T;
- Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
-
- -- When the target requires front-end layout, it's necessary to allow
- -- the equivalent type to be frozen so that layout can occur (when the
- -- associated class-wide subtype is frozen, the equivalent type will
- -- be frozen, see freeze.adb). For other targets, Gigi wants to have
- -- the equivalent type marked as frozen and deals with this type itself.
- -- In the Gigi case this will also avoid the generation of an init
- -- procedure for the type.
-
- if not Frontend_Layout_On_Target then
- Set_Is_Frozen (Equiv_Type);
- end if;
-
+ Equiv_Type := Make_Temporary (Loc, 'T');
Set_Ekind (Equiv_Type, E_Record_Type);
Set_Parent_Subtype (Equiv_Type, Constr_Root);
+ -- Set Is_Class_Wide_Equivalent_Type very early to trigger the special
+ -- treatment for this type. In particular, even though _parent's type
+ -- is a controlled type or contains controlled components, we do not
+ -- want to set Has_Controlled_Component on it to avoid making it gain
+ -- an unwanted _controller component.
+
+ Set_Is_Class_Wide_Equivalent_Type (Equiv_Type);
+
if not Is_Interface (Root_Typ) then
Append_To (Comp_List,
Make_Component_Declaration (Loc,
Append_To (Comp_List,
Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('C')),
+ Defining_Identifier => Make_Temporary (Loc, 'C'),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
return Equiv_Type;
end Make_CW_Equivalent_Type;
+ -------------------------
+ -- Make_Invariant_Call --
+ -------------------------
+
+ function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Typ : constant Entity_Id := Etype (Expr);
+
+ begin
+ pragma Assert
+ (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
+
+ if Check_Enabled (Name_Invariant)
+ or else
+ Check_Enabled (Name_Assertion)
+ then
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+
+ else
+ return
+ Make_Null_Statement (Loc);
+ end if;
+ end Make_Invariant_Call;
+
------------------------
-- Make_Literal_Range --
------------------------
Make_Integer_Literal (Loc, 0));
end Make_Non_Empty_Check;
+ -------------------------
+ -- Make_Predicate_Call --
+ -------------------------
+
+ function Make_Predicate_Call
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ pragma Assert (Present (Predicate_Function (Typ)));
+
+ return
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Predicate_Function (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+ end Make_Predicate_Call;
+
+ --------------------------
+ -- Make_Predicate_Check --
+ --------------------------
+
+ function Make_Predicate_Check
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ return
+ Make_Pragma (Loc,
+ Pragma_Identifier => Make_Identifier (Loc, Name_Check),
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Predicate)),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Predicate_Call (Typ, Expr))));
+ end Make_Predicate_Check;
+
----------------------------
-- Make_Subtype_From_Expr --
----------------------------
-- actual or an explicit subtype.
Utyp := Underlying_Type (Base_Type (Unc_Typ));
- Full_Subtyp := Make_Defining_Identifier (Loc,
- New_Internal_Name ('C'));
+ Full_Subtyp := Make_Temporary (Loc, 'C');
Full_Exp :=
- Unchecked_Convert_To
- (Utyp, Duplicate_Subexpr_No_Checks (E));
+ Unchecked_Convert_To (Utyp, Duplicate_Subexpr_No_Checks (E));
Set_Parent (Full_Exp, Parent (E));
- Priv_Subtyp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Priv_Subtyp := Make_Temporary (Loc, 'P');
Insert_Action (E,
Make_Subtype_Declaration (Loc,
if Is_Tagged_Type (Priv_Subtyp) then
Set_Class_Wide_Type
(Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
- Set_Primitive_Operations (Priv_Subtyp,
- Primitive_Operations (Unc_Typ));
+ Set_Direct_Primitive_Operations (Priv_Subtyp,
+ Direct_Primitive_Operations (Unc_Typ));
end if;
Set_Full_View (Priv_Subtyp, Full_Subtyp);
-- additional intermediate type to handle the assignment).
if Expander_Active and then Tagged_Type_Expansion then
+
+ -- If this is the class_wide type of a completion that is
+ -- a record subtype, set the type of the class_wide type
+ -- to be the full base type, for use in the expanded code
+ -- for the equivalent type. Should this be done earlier when
+ -- the completion is analyzed ???
+
+ if Is_Private_Type (Etype (Unc_Typ))
+ and then
+ Ekind (Full_View (Etype (Unc_Typ))) = E_Record_Subtype
+ then
+ Set_Etype (Unc_Typ, Base_Type (Full_View (Etype (Unc_Typ))));
+ end if;
+
EQ_Typ := Make_CW_Equivalent_Type (Unc_Typ, E);
end if;
CW_Subtype := New_Class_Wide_Subtype (Unc_Typ, E);
Set_Equivalent_Type (CW_Subtype, EQ_Typ);
-
- if Present (EQ_Typ) then
- Set_Is_Class_Wide_Equivalent_Type (EQ_Typ);
- end if;
-
Set_Cloned_Subtype (CW_Subtype, Base_Type (Unc_Typ));
return New_Occurrence_Of (CW_Subtype, Loc);
end May_Generate_Large_Temp;
----------------------------
+ -- Needs_Constant_Address --
+ ----------------------------
+
+ function Needs_Constant_Address
+ (Decl : Node_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ begin
+
+ -- If we have no initialization of any kind, then we don't need to
+ -- place any restrictions on the address clause, because the object
+ -- will be elaborated after the address clause is evaluated. This
+ -- happens if the declaration has no initial expression, or the type
+ -- has no implicit initialization, or the object is imported.
+
+ -- The same holds for all initialized scalar types and all access
+ -- types. Packed bit arrays of size up to 64 are represented using a
+ -- modular type with an initialization (to zero) and can be processed
+ -- like other initialized scalar types.
+
+ -- If the type is controlled, code to attach the object to a
+ -- finalization chain is generated at the point of declaration,
+ -- and therefore the elaboration of the object cannot be delayed:
+ -- the address expression must be a constant.
+
+ if No (Expression (Decl))
+ and then not Needs_Finalization (Typ)
+ and then
+ (not Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Imported (Defining_Identifier (Decl)))
+ then
+ return False;
+
+ elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
+ or else Is_Access_Type (Typ)
+ or else
+ (Is_Bit_Packed_Array (Typ)
+ and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
+ then
+ return False;
+
+ else
+
+ -- Otherwise, we require the address clause to be constant because
+ -- the call to the initialization procedure (or the attach code) has
+ -- to happen at the point of the declaration.
+
+ -- Actually the IP call has been moved to the freeze actions
+ -- anyway, so maybe we can relax this restriction???
+
+ return True;
+ end if;
+ end Needs_Constant_Address;
+
+ ----------------------------
-- New_Class_Wide_Subtype --
----------------------------
Set_Ekind (Res, E_Class_Wide_Subtype);
Set_Next_Entity (Res, Empty);
Set_Etype (Res, Base_Type (CW_Typ));
-
- -- For targets where front-end layout is required, reset the Is_Frozen
- -- status of the subtype to False (it can be implicitly set to true
- -- from the copy of the class-wide type). For other targets, Gigi
- -- doesn't want the class-wide subtype to go through the freezing
- -- process (though it's unclear why that causes problems and it would
- -- be nice to allow freezing to occur normally for all targets ???).
-
- if Frontend_Layout_On_Target then
- Set_Is_Frozen (Res, False);
- end if;
-
+ Set_Is_Frozen (Res, False);
Set_Freeze_Node (Res, Empty);
return (Res);
end New_Class_Wide_Subtype;
or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
end if;
+ -- If the prefix is an explicit dereference then this construct is a
+ -- variable reference, which means it is to be considered to have
+ -- side effects if Variable_Ref is True.
+
+ -- We do NOT exclude dereferences of access-to-constant types because
+ -- we handle them as constant view of variables.
+
+ -- Exception is an access to an entity that is a constant or an
+ -- in-parameter.
+
+ elsif Nkind (Prefix (N)) = N_Explicit_Dereference
+ and then Variable_Ref
+ then
+ declare
+ DDT : constant Entity_Id :=
+ Designated_Type (Etype (Prefix (Prefix (N))));
+ begin
+ return Ekind_In (DDT, E_Constant, E_In_Parameter);
+ end;
+
-- The following test is the simplest way of solving a complex
-- problem uncovered by BB08-010: Side effect on loop bound that
-- is a subcomponent of a global variable:
function Side_Effect_Free (N : Node_Id) return Boolean is
begin
- -- Note on checks that could raise Constraint_Error. Strictly, if
- -- we take advantage of 11.6, these checks do not count as side
- -- effects. However, we would just as soon consider that they are
- -- side effects, since the backend CSE does not work very well on
- -- expressions which can raise Constraint_Error. On the other
- -- hand, if we do not consider them to be side effect free, then
- -- we get some awkward expansions in -gnato mode, resulting in
- -- code insertions at a point where we do not have a clear model
- -- for performing the insertions.
+ -- Note on checks that could raise Constraint_Error. Strictly, if we
+ -- take advantage of 11.6, these checks do not count as side effects.
+ -- However, we would prefer to consider that they are side effects,
+ -- since the backend CSE does not work very well on expressions which
+ -- can raise Constraint_Error. On the other hand if we don't consider
+ -- them to be side effect free, then we get some awkward expansions
+ -- in -gnato mode, resulting in code insertions at a point where we
+ -- do not have a clear model for performing the insertions.
-- Special handling for entity names
-- already rewritten a variable node with a constant as
-- a result of an earlier Force_Evaluation call.
- if Ekind (Entity (N)) = E_Constant
- or else Ekind (Entity (N)) = E_In_Parameter
- then
+ if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then
return True;
-- Functions are not side effect free
-- some cases, and an assignment can modify the component
-- designated by N, so we need to create a temporary for it.
+ -- The guard testing for Entity being present is needed at least
+ -- in the case of rewritten predicate expressions, and may be
+ -- appropriate elsewhere. Obviously we can't go testing the entity
+ -- field if it does not exist, so it's reasonable to say that this
+ -- is not the renaming case if it does not exist.
+
elsif Is_Entity_Name (Original_Node (N))
+ and then Present (Entity (Original_Node (N)))
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
return False;
+
+ -- Remove_Side_Effects generates an object renaming declaration to
+ -- capture the expression of a class-wide expression. In VM targets
+ -- the frontend performs no expansion for dispatching calls to
+ -- class-wide types since they are handled by the VM. Hence, we must
+ -- locate here if this node corresponds to a previous invocation of
+ -- Remove_Side_Effects to avoid a never ending loop in the frontend.
+
+ elsif VM_Target /= No_VM
+ and then not Comes_From_Source (N)
+ and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
+ and then Is_Class_Wide_Type (Etype (N))
+ then
+ return True;
end if;
-- For other than entity names and compile time known values,
Scope_Suppress := (others => True);
-- If it is a scalar type and we need to capture the value, just make
- -- a copy. Likewise for a function call, an attribute reference or an
- -- operator. And if we have a volatile reference and Name_Req is not
- -- set (see comments above for Side_Effect_Free).
+ -- a copy. Likewise for a function call, an attribute reference, an
+ -- allocator, or an operator. And if we have a volatile reference and
+ -- Name_Req is not set (see comments above for Side_Effect_Free).
if Is_Elementary_Type (Exp_Type)
and then (Variable_Ref
or else Nkind (Exp) = N_Function_Call
or else Nkind (Exp) = N_Attribute_Reference
+ or else Nkind (Exp) = N_Allocator
or else Nkind (Exp) in N_Op
or else (not Name_Req and then Is_Volatile_Reference (Exp)))
then
Set_Etype (Def_Id, Exp_Type);
Res := New_Reference_To (Def_Id, Loc);
+ -- If the expression is a packed reference, it must be reanalyzed
+ -- and expanded, depending on context. This is the case for actuals
+ -- where a constraint check may capture the actual before expansion
+ -- of the call is complete.
+
+ if Nkind (Exp) = N_Indexed_Component
+ and then Is_Packed (Etype (Prefix (Exp)))
+ then
+ Set_Analyzed (Exp, False);
+ Set_Analyzed (Prefix (Exp), False);
+ end if;
+
E :=
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
end if;
-- For expressions that denote objects, we can use a renaming scheme.
- -- We skip using this if we have a volatile reference and we do not
- -- have Name_Req set true (see comments above for Side_Effect_Free).
+ -- This is needed for correctness in the case of a volatile object
+ -- of a non-volatile type because the Make_Reference call of the
+ -- "default" approach would generate an illegal access value (an access
+ -- value cannot designate such an object - see Analyze_Reference).
+ -- We skip using this scheme if we have an object of a volatile type
+ -- and we do not have Name_Req set true (see comments above for
+ -- Side_Effect_Free).
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
- and then (Name_Req or else not Is_Volatile_Reference (Exp))
+ and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
then
Def_Id := Make_Temporary (Loc, 'R', Exp);
-- to accommodate functions returning limited objects by reference.
if Nkind (Exp) = N_Function_Call
- and then Is_Inherently_Limited_Type (Etype (Exp))
+ and then Is_Immutably_Limited_Type (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
then
declare
Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
Defining_Identifier => Obj,
Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
Expression => Relocate_Node (Exp));
+
Insert_Action (Exp, Decl);
Set_Etype (Obj, Exp_Type);
Rewrite (Exp, New_Occurrence_Of (Obj, Loc));
end;
end if;
- Ref_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Ref_Type := Make_Temporary (Loc, 'A');
Ptr_Typ_Decl :=
Make_Full_Type_Declaration (Loc,
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
Object_Definition => New_Reference_To (Ref_Type, Loc),
+ Constant_Present => True,
Expression => New_Exp));
end if;
declare
CS : constant Boolean := Comes_From_Source (N);
begin
- Rewrite (N, Make_Identifier (Sloc (N), Chars => Chars (E)));
+ Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
Set_Entity (N, E);
Set_Comes_From_Source (N, CS);
Set_Analyzed (N, True);
OSDN Git Service
