-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1992-2001, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Aggr; use Exp_Aggr;
with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch11; use Exp_Ch11;
-with Hostparm; use Hostparm;
with Inline; use Inline;
with Itypes; use Itypes;
with Lib; use Lib;
-with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
+with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
+with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
+with Urealp; use Urealp;
with Validsw; use Validsw;
package body Exp_Util is
(Loc : Source_Ptr;
Id_Ref : Node_Id;
A_Type : Entity_Id;
- Dyn : Boolean := False)
- return Node_Id;
+ Dyn : Boolean := False) return Node_Id;
-- Build function to generate the image string for a task that is an
-- array component, concatenating the images of each index. To avoid
-- storage leaks, the string is built with successive slice assignments.
(Loc : Source_Ptr;
Decls : List_Id;
Stats : List_Id;
- Res : Entity_Id)
- return Node_Id;
+ Res : Entity_Id) return Node_Id;
-- Common processing for Task_Array_Image and Task_Record_Image.
-- Build function body that computes image.
function Build_Task_Record_Image
(Loc : Source_Ptr;
Id_Ref : Node_Id;
- A_Type : Entity_Id;
- Dyn : Boolean := False)
- return Node_Id;
+ Dyn : Boolean := False) return Node_Id;
-- Build function to generate the image string for a task that is a
-- record component. Concatenate name of variable with that of selector.
-- The flag Dyn indicates whether this is called for the initialization
-- created task that is assigned to a selected component.
function Make_CW_Equivalent_Type
- (T : Entity_Id;
- E : Node_Id)
- return Entity_Id;
+ (T : Entity_Id;
+ E : Node_Id) return Entity_Id;
-- T is a class-wide type entity, E is the initial expression node that
-- constrains T in case such as: " X: T := E" or "new T'(E)"
-- This function returns the entity of the Equivalent type and inserts
-- on the fly the necessary declaration such as:
+ --
-- type anon is record
-- _parent : Root_Type (T); constrained with E discriminants (if any)
-- Extension : String (1 .. expr to match size of E);
function Make_Literal_Range
(Loc : Source_Ptr;
- Literal_Typ : Entity_Id;
- Index_Typ : Entity_Id)
- return Node_Id;
+ Literal_Typ : Entity_Id) return Node_Id;
-- Produce a Range node whose bounds are:
- -- Index_Typ'first .. Index_Typ'First + Length (Literal_Typ)
+ -- Low_Bound (Literal_Type) ..
+ -- Low_Bound (Literal_Type) + Length (Literal_Typ) - 1
-- this is used for expanding declarations like X : String := "sdfgdfg";
function New_Class_Wide_Subtype
(CW_Typ : Entity_Id;
- N : Node_Id)
- return Entity_Id;
- -- Create an implicit subtype of CW_Typ attached to node N.
+ N : Node_Id) return Entity_Id;
+ -- Create an implicit subtype of CW_Typ attached to node N
----------------------
-- Adjust_Condition --
--------------------------
procedure Append_Freeze_Action (T : Entity_Id; N : Node_Id) is
- Fnode : Node_Id := Freeze_Node (T);
+ Fnode : Node_Id;
begin
Ensure_Freeze_Node (T);
Fnode := Freeze_Node (T);
- if not Present (Actions (Fnode)) then
+ if No (Actions (Fnode)) then
Set_Actions (Fnode, New_List);
end if;
function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id is
begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (RTE (RE), Loc));
+ -- If entity is not available, we can skip making the call (this avoids
+ -- junk duplicated error messages in a number of cases).
+
+ if not RTE_Available (RE) then
+ return Make_Null_Statement (Loc);
+ else
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RE), Loc));
+ end if;
end Build_Runtime_Call;
- -----------------------------
- -- Build_Task_Array_Image --
- -----------------------------
+ ----------------------------
+ -- Build_Task_Array_Image --
+ ----------------------------
-- This function generates the body for a function that constructs the
-- image string for a task that is an array component. The function is
- -- local to the init_proc for the array type, and is called for each one
+ -- 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...
- -- Id_Ref is an indexed component form created by the enclosing init_proc.
+ -- Id_Ref is an indexed component form created by the enclosing init proc.
-- Its successive indices are Val1, Val2,.. which are the loop variables
- -- in the loops that call the individual task init_proc on each component.
+ -- in the loops that call the individual task init proc on each component.
-- The generated function has the following structure:
- -- function F return Task_Image_Type is
- -- Pref : string := Task_Id.all;
- -- T1 : String := Index1'Image (Val1);
+ -- function F return String is
+ -- Pref : string renames Task_Name;
+ -- T1 : String := Index1'Image (Val1);
-- ...
- -- Tn : String := indexn'image (Valn);
- -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
+ -- Tn : String := indexn'image (Valn);
+ -- Len : Integer := T1'Length + ... + Tn'Length + n + 1;
-- -- Len includes commas and the end parentheses.
- -- Res : String (1..Len);
- -- Pos : Integer := Pref'Length;
+ -- Res : String (1..Len);
+ -- Pos : Integer := Pref'Length;
--
-- begin
-- Res (1 .. Pos) := Pref;
-- Res (Pos .. Pos + Tn'Length - 1) := Tn;
-- Res (Len) := ')';
--
- -- return new String (Res);
+ -- return Res;
-- end F;
--
-- Needless to say, multidimensional arrays of tasks are rare enough
(Loc : Source_Ptr;
Id_Ref : Node_Id;
A_Type : Entity_Id;
- Dyn : Boolean := False)
- return Node_Id
+ Dyn : Boolean := False) return Node_Id
is
Dims : constant Nat := Number_Dimensions (A_Type);
- -- Number of dimensions for array of tasks.
+ -- Number of dimensions for array of tasks
Temps : array (1 .. Dims) of Entity_Id;
- -- Array of temporaries to hold string for each index.
+ -- Array of temporaries to hold string for each index
Indx : Node_Id;
-- Index expression
Pref : Entity_Id;
-- Name of enclosing variable, prefix of resulting name
- P_Nam : Node_Id;
- -- string expression for Pref.
-
Res : Entity_Id;
-- String to hold result
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 static one it is a formal of the enclosing init proc.
if Dyn then
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
- P_Nam :=
- Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer)));
+
else
- P_Nam :=
- Make_Explicit_Dereference (Loc,
- Prefix => Make_Identifier (Loc, Name_uTask_Id));
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
+ Name => Make_Identifier (Loc, Name_uTask_Name)));
end if;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Pref,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => P_Nam));
-
Indx := First_Index (A_Type);
Val := First (Expressions (Id_Ref));
Make_Character_Literal (Loc,
Chars => Name_Find,
Char_Literal_Value =>
- Char_Code (Character'Pos ('(')))));
+ UI_From_Int (Character'Pos ('(')))));
Append_To (Stats,
Make_Assignment_Statement (Loc,
Make_Character_Literal (Loc,
Chars => Name_Find,
Char_Literal_Value =>
- Char_Code (Character'Pos (',')))));
+ UI_From_Int (Character'Pos (',')))));
Append_To (Stats,
Make_Assignment_Statement (Loc,
Make_Character_Literal (Loc,
Chars => Name_Find,
Char_Literal_Value =>
- Char_Code (Character'Pos (')')))));
+ UI_From_Int (Character'Pos (')')))));
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Array_Image;
----------------------------
function Build_Task_Image_Decls
- (Loc : Source_Ptr;
- Id_Ref : Node_Id;
- A_Type : Entity_Id)
- return List_Id
+ (Loc : Source_Ptr;
+ Id_Ref : Node_Id;
+ A_Type : Entity_Id;
+ In_Init_Proc : Boolean := False) return List_Id
is
+ Decls : constant List_Id := New_List;
T_Id : Entity_Id := Empty;
Decl : Node_Id;
- Decls : List_Id := New_List;
Expr : Node_Id := Empty;
Fun : Node_Id := Empty;
Is_Dyn : constant Boolean :=
- Nkind (Parent (Id_Ref)) = N_Assignment_Statement
- and then Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
+ Nkind (Parent (Id_Ref)) = N_Assignment_Statement
+ and then
+ Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
begin
- -- If Discard_Names is in effect, generate a dummy declaration only.
+ -- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
+ -- generate a dummy declaration only.
- if Global_Discard_Names then
- T_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ if Restriction_Active (No_Implicit_Heap_Allocations)
+ or else Global_Discard_Names
+ then
+ T_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+ Name_Len := 0;
return
New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => T_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc)));
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer)));
else
if Nkind (Id_Ref) = N_Identifier
or else Nkind (Id_Ref) = N_Defining_Identifier
then
- -- For a simple variable, the image of the task is the name
- -- of the variable.
+ -- For a simple variable, the image of the task is built from
+ -- the name of the variable. To avoid possible conflict with
+ -- the anonymous type created for a single protected object,
+ -- add a numeric suffix.
T_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Id_Ref), 'I'));
+ New_External_Name (Chars (Id_Ref), 'T', 1));
Get_Name_String (Chars (Id_Ref));
Expr :=
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal
- (Loc, Strval => String_From_Name_Buffer)));
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer);
elsif Nkind (Id_Ref) = N_Selected_Component then
T_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (Selector_Name (Id_Ref)), 'I'));
- Fun := Build_Task_Record_Image (Loc, Id_Ref, A_Type, Is_Dyn);
+ New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
+ Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
elsif Nkind (Id_Ref) = N_Indexed_Component then
T_Id :=
Make_Defining_Identifier (Loc,
- New_External_Name (Chars (A_Type), 'I'));
+ New_External_Name (Chars (A_Type), 'N'));
Fun := Build_Task_Array_Image (Loc, Id_Ref, A_Type, Is_Dyn);
end if;
if Present (Fun) then
Append (Fun, Decls);
+ Expr := Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
- Expr :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Defining_Entity (Fun), Loc));
+ if not In_Init_Proc and then VM_Target = No_VM then
+ Set_Uses_Sec_Stack (Defining_Entity (Fun));
+ end if;
end if;
Decl := Make_Object_Declaration (Loc,
Defining_Identifier => T_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc),
- Expression => Expr);
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Constant_Present => True,
+ Expression => Expr);
Append (Decl, Decls);
return Decls;
(Loc : Source_Ptr;
Decls : List_Id;
Stats : List_Id;
- Res : Entity_Id)
- return Node_Id
+ Res : Entity_Id) return Node_Id
is
Spec : Node_Id;
begin
Append_To (Stats,
Make_Return_Statement (Loc,
- Expression =>
- Make_Allocator (Loc,
- Expression =>
- Make_Qualified_Expression (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression => New_Occurrence_Of (Res, Loc)))));
-
- Spec := Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
- Subtype_Mark => New_Occurrence_Of (RTE (RE_Task_Image_Type), Loc));
+ 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));
+
+ -- Calls to 'Image use the secondary stack, which must be cleaned
+ -- up after the task name is built.
return Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stats));
+ Make_Handled_Sequence_Of_Statements (Loc, Statements => Stats));
end Build_Task_Image_Function;
-----------------------------
function Build_Task_Record_Image
(Loc : Source_Ptr;
Id_Ref : Node_Id;
- A_Type : Entity_Id;
- Dyn : Boolean := False)
- return Node_Id
+ Dyn : Boolean := False) return Node_Id
is
Len : Entity_Id;
-- Total length of generated name
Pref : Entity_Id;
-- Name of enclosing variable, prefix of resulting name
- P_Nam : Node_Id;
- -- string expression for Pref.
-
Sum : Node_Id;
- -- Expression to compute total size of string.
+ -- Expression to compute total size of string
Sel : Entity_Id;
-- Entity for selector name
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 static one it is a formal of the enclosing init proc.
if Dyn then
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
- P_Nam :=
- Make_String_Literal (Loc, Strval => String_From_Name_Buffer);
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer)));
+
else
- P_Nam :=
- Make_Explicit_Dereference (Loc,
- Prefix => Make_Identifier (Loc, Name_uTask_Id));
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Pref,
+ Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
+ Name => Make_Identifier (Loc, Name_uTask_Name)));
end if;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Pref,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => P_Nam));
-
Sel := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Get_Name_String (Chars (Selector_Name (Id_Ref)));
Defining_Identifier => Sel,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
Expression =>
- Make_String_Literal (Loc, Strval => String_From_Name_Buffer)));
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer)));
Sum := Make_Integer_Literal (Loc, Nat (Name_Len + 1));
Make_Character_Literal (Loc,
Chars => Name_Find,
Char_Literal_Value =>
- Char_Code (Character'Pos ('.')))));
+ UI_From_Int (Character'Pos ('.')))));
Append_To (Stats,
Make_Assignment_Statement (Loc,
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image;
+ ----------------------------------
+ -- Component_May_Be_Bit_Aligned --
+ ----------------------------------
+
+ function Component_May_Be_Bit_Aligned (Comp : Entity_Id) return Boolean is
+ 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
+ return False;
+ end if;
+
+ -- 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))
+ 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.
+
+ elsif Esize (Comp) <= 64
+ and then (Is_Record_Type (Etype (Comp))
+ or else Is_Bit_Packed_Array (Etype (Comp)))
+ then
+ return False;
+
+ -- Otherwise if the component is not byte aligned, we
+ -- know we have the nasty unaligned case.
+
+ elsif Normalized_First_Bit (Comp) /= Uint_0
+ or else Esize (Comp) mod System_Storage_Unit /= Uint_0
+ then
+ return True;
+
+ -- If we are large and byte aligned, then OK at this level
+
+ else
+ return False;
+ end if;
+ end Component_May_Be_Bit_Aligned;
+
-------------------------------
-- Convert_To_Actual_Subtype --
-------------------------------
function Duplicate_Subexpr
(Exp : Node_Id;
- Name_Req : Boolean := False)
- return Node_Id
+ Name_Req : Boolean := False) return Node_Id
is
begin
Remove_Side_Effects (Exp, Name_Req);
return New_Copy_Tree (Exp);
end Duplicate_Subexpr;
+ ---------------------------------
+ -- Duplicate_Subexpr_No_Checks --
+ ---------------------------------
+
+ function Duplicate_Subexpr_No_Checks
+ (Exp : Node_Id;
+ Name_Req : Boolean := False) return Node_Id
+ is
+ New_Exp : Node_Id;
+
+ begin
+ Remove_Side_Effects (Exp, Name_Req);
+ New_Exp := New_Copy_Tree (Exp);
+ Remove_Checks (New_Exp);
+ return New_Exp;
+ end Duplicate_Subexpr_No_Checks;
+
+ -----------------------------------
+ -- Duplicate_Subexpr_Move_Checks --
+ -----------------------------------
+
+ function Duplicate_Subexpr_Move_Checks
+ (Exp : Node_Id;
+ Name_Req : Boolean := False) return Node_Id
+ is
+ New_Exp : Node_Id;
+
+ begin
+ Remove_Side_Effects (Exp, Name_Req);
+ New_Exp := New_Copy_Tree (Exp);
+ Remove_Checks (Exp);
+ return New_Exp;
+ end Duplicate_Subexpr_Move_Checks;
+
--------------------
-- Ensure_Defined --
--------------------
-- in gigi.
P := Parent (N);
-
while Present (P)
and then Nkind (P) /= N_Subprogram_Body
loop
-- objects which are constrained by an initial expression. Basically it
-- transforms an unconstrained subtype indication into a constrained one.
-- The expression may also be transformed in certain cases in order to
- -- avoid multiple evaulation. In the static allocation case, the general
- -- scheme is :
+ -- avoid multiple evaluation. In the static allocation case, the general
+ -- scheme is:
-- Val : T := Expr;
-- Val : T := Expr;
--
-- <elsif Expr is an entity_name>
- -- Val : T (contraints taken from Expr) := Expr;
+ -- Val : T (constraints taken from Expr) := Expr;
--
-- <else>
-- type Axxx is access all T;
-- Rval : Axxx := Expr'ref;
- -- Val : T (contraints taken from Rval) := Rval.all;
+ -- Val : T (constraints taken from Rval) := Rval.all;
-- ??? note: when the Expression is allocated in the secondary stack
-- we could use it directly instead of copying it by declaring
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Literal_Range (Loc,
- Literal_Typ => Exp_Typ,
- Index_Typ => Etype (First_Index (Unc_Type)))))));
+ Literal_Typ => Exp_Typ)))));
elsif Is_Constrained (Exp_Typ)
and then not Is_Class_Wide_Type (Unc_Type)
then
if Is_Itype (Exp_Typ) then
- -- No need to generate a new one.
+ -- Within an initialization procedure, a selected component
+ -- denotes a component of the enclosing record, and it appears
+ -- as an actual in a call to its own initialization procedure.
+ -- If this component depends on the outer discriminant, we must
+ -- generate the proper actual subtype for it.
+
+ if Nkind (Exp) = N_Selected_Component
+ and then Within_Init_Proc
+ then
+ declare
+ Decl : constant Node_Id :=
+ Build_Actual_Subtype_Of_Component (Exp_Typ, Exp);
+ begin
+ if Present (Decl) then
+ Insert_Action (N, Decl);
+ T := Defining_Identifier (Decl);
+ else
+ T := Exp_Typ;
+ end if;
+ end;
- T := Exp_Typ;
+ -- No need to generate a new one (new what???)
+
+ else
+ T := Exp_Typ;
+ end if;
else
T :=
then
null;
+ -- Nothing to be done for derived types with unknown discriminants if
+ -- the parent type also has unknown discriminants.
+
+ elsif Is_Record_Type (Unc_Type)
+ and then not Is_Class_Wide_Type (Unc_Type)
+ and then Has_Unknown_Discriminants (Unc_Type)
+ and then Has_Unknown_Discriminants (Underlying_Type (Unc_Type))
+ then
+ 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 Ada2005, the context can be an object declaration whose expression
+ -- is a function that returns in place. If the nominal subtype has
+ -- unknown discriminants, the call still provides constraints on the
+ -- object, and we have to create an actual subtype from it.
+
+ -- If the type is class-wide, the expression is dynamically tagged and
+ -- we do not create an actual subtype either. Ditto for an interface.
+
+ elsif Is_Limited_Type (Exp_Typ)
+ and then
+ (Is_Class_Wide_Type (Exp_Typ)
+ or else Is_Interface (Exp_Typ)
+ or else not Has_Unknown_Discriminants (Exp_Typ)
+ or else not Is_Composite_Type (Unc_Type))
+ then
+ null;
+
+ -- For limited interfaces, nothing to be done
+
+ -- This branch may be redundant once the limited interface issue is
+ -- sorted out???
+
+ elsif Is_Interface (Exp_Typ)
+ and then Is_Limited_Interface (Exp_Typ)
+ then
+ null;
+
else
Remove_Side_Effects (Exp);
Rewrite (Subtype_Indic,
end if;
end Expand_Subtype_From_Expr;
- ------------------
- -- Find_Prim_Op --
- ------------------
-
- function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
- Prim : Elmt_Id;
- Typ : Entity_Id := T;
+ ------------------------
+ -- Find_Interface_ADT --
+ ------------------------
- begin
- if Is_Class_Wide_Type (Typ) then
- Typ := Root_Type (Typ);
- end if;
+ function Find_Interface_ADT
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
+ is
+ ADT : Elmt_Id;
+ Found : Boolean := False;
+ Typ : Entity_Id := T;
- Typ := Underlying_Type (Typ);
+ procedure Find_Secondary_Table (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
- Prim := First_Elmt (Primitive_Operations (Typ));
- while Chars (Node (Prim)) /= Name loop
- Next_Elmt (Prim);
- pragma Assert (Present (Prim));
- end loop;
+ --------------------------
+ -- Find_Secondary_Table --
+ --------------------------
- return Node (Prim);
- end Find_Prim_Op;
+ procedure Find_Secondary_Table (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+ AI : Node_Id;
- ----------------------
- -- Force_Evaluation --
- ----------------------
+ begin
+ pragma Assert (Typ /= Iface);
- procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
- begin
- Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
- end Force_Evaluation;
+ -- Climb to the ancestor (if any) handling synchronized interface
+ -- derivations and private types
- ------------------------
- -- Generate_Poll_Call --
- ------------------------
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
- procedure Generate_Poll_Call (N : Node_Id) is
- begin
- -- No poll call if polling not active
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Secondary_Table (Etype (First (Iface_List)));
+ end if;
+ end;
- if not Polling_Required then
- return;
+ elsif Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Find_Secondary_Table (Full_View (Etype (Typ)));
+ end if;
- -- Otherwise generate require poll call
+ elsif Etype (Typ) /= Typ then
+ Find_Secondary_Table (Etype (Typ));
+ end if;
- else
- Insert_Before_And_Analyze (N,
- Make_Procedure_Call_Statement (Sloc (N),
- Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
- end if;
- end Generate_Poll_Call;
+ -- Traverse the list of interfaces implemented by the type
- --------------------
- -- Homonym_Number --
- --------------------
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
+ then
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ AI := Node (AI_Elmt);
- function Homonym_Number (Subp : Entity_Id) return Nat is
- Count : Nat;
- Hom : Entity_Id;
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ Found := True;
+ return;
+ end if;
- begin
- Count := 1;
- Hom := Homonym (Subp);
- while Present (Hom) loop
- if Scope (Hom) = Scope (Subp) then
- Count := Count + 1;
+ Next_Elmt (ADT);
+ Next_Elmt (AI_Elmt);
+ end loop;
end if;
+ end Find_Secondary_Table;
- Hom := Homonym (Hom);
- end loop;
+ -- Start of processing for Find_Interface_ADT
- return Count;
- end Homonym_Number;
+ begin
+ pragma Assert (Is_Interface (Iface));
- ------------------------------
- -- In_Unconditional_Context --
- ------------------------------
+ -- Handle private types
- function In_Unconditional_Context (Node : Node_Id) return Boolean is
- P : Node_Id;
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
- begin
- P := Node;
- while Present (P) loop
- case Nkind (P) is
- when N_Subprogram_Body =>
- return True;
+ -- Handle access types
- when N_If_Statement =>
- return False;
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
- when N_Loop_Statement =>
- return False;
+ -- Handle task and protected types implementing interfaces
- when N_Case_Statement =>
- return False;
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
- when others =>
- P := Parent (P);
- end case;
- end loop;
+ pragma Assert
+ (not Is_Class_Wide_Type (Typ)
+ and then Ekind (Typ) /= E_Incomplete_Type);
- return False;
- end In_Unconditional_Context;
+ ADT := Next_Elmt (First_Elmt (Access_Disp_Table (Typ)));
+ pragma Assert (Present (Node (ADT)));
+ Find_Secondary_Table (Typ);
+ pragma Assert (Found);
+ return Node (ADT);
+ end Find_Interface_ADT;
- -------------------
- -- Insert_Action --
- -------------------
+ ------------------------
+ -- Find_Interface_Tag --
+ ------------------------
- procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
- begin
- if Present (Ins_Action) then
- Insert_Actions (Assoc_Node, New_List (Ins_Action));
- end if;
- end Insert_Action;
+ function Find_Interface_Tag
+ (T : Entity_Id;
+ Iface : Entity_Id) return Entity_Id
+ is
+ AI_Tag : Entity_Id;
+ Found : Boolean := False;
+ Typ : Entity_Id := T;
- -- Version with check(s) suppressed
+ Is_Primary_Tag : Boolean := False;
- procedure Insert_Action
- (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
- is
- begin
- Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
- end Insert_Action;
+ Is_Sync_Typ : Boolean := False;
+ -- In case of non concurrent-record-types each parent-type has the
+ -- tags associated with the interface types that are not implemented
+ -- by the ancestors; concurrent-record-types have their whole list of
+ -- interface tags (and this case requires some special management).
- --------------------
- -- Insert_Actions --
- --------------------
+ procedure Find_Tag (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
- procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
- N : Node_Id;
- P : Node_Id;
+ --------------
+ -- Find_Tag --
+ --------------
- Wrapped_Node : Node_Id := Empty;
+ procedure Find_Tag (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+ AI : Node_Id;
- begin
- if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
- return;
- end if;
+ begin
+ -- Check if the interface is an immediate ancestor of the type and
+ -- therefore shares the main tag.
- -- Ignore insert of actions from inside default expression in the
- -- special preliminary analyze mode. Any insertions at this point
- -- have no relevance, since we are only doing the analyze to freeze
- -- the types of any static expressions. See section "Handling of
- -- Default Expressions" in the spec of package Sem for further details.
+ if Typ = Iface then
+ if Is_Sync_Typ then
+ Is_Primary_Tag := True;
+ else
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := First_Tag_Component (Typ);
+ end if;
- if In_Default_Expression then
- return;
- end if;
+ Found := True;
+ return;
+ end if;
- -- If the action derives from stuff inside a record, then the actions
+ -- Handle synchronized interface derivations
+
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Tag (Etype (First (Iface_List)));
+ end if;
+ end;
+
+ -- Climb to the root type handling private types
+
+ elsif Present (Full_View (Etype (Typ))) then
+ if Full_View (Etype (Typ)) /= Typ then
+ Find_Tag (Full_View (Etype (Typ)));
+ end if;
+
+ elsif Etype (Typ) /= Typ then
+ Find_Tag (Etype (Typ));
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ then
+ -- Skip the tag associated with the primary table
+
+ if not Is_Sync_Typ then
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ pragma Assert (Present (AI_Tag));
+ end if;
+
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ AI := Node (AI_Elmt);
+
+ if AI = Iface or else Is_Ancestor (Iface, AI) then
+ Found := True;
+ return;
+ end if;
+
+ AI_Tag := Next_Tag_Component (AI_Tag);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Tag;
+
+ -- Start of processing for Find_Interface_Tag
+
+ begin
+ pragma Assert (Is_Interface (Iface));
+
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Etype (Typ);
+ end if;
+
+ -- Handle entities from the limited view
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Typ)));
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if not Is_Concurrent_Record_Type (Typ) then
+ Find_Tag (Typ);
+ pragma Assert (Found);
+ return AI_Tag;
+
+ -- Concurrent record types
+
+ else
+ Is_Sync_Typ := True;
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ Find_Tag (Typ);
+ pragma Assert (Found);
+
+ if Is_Primary_Tag then
+ return First_Tag_Component (Typ);
+ else
+ return AI_Tag;
+ end if;
+ end if;
+ end Find_Interface_Tag;
+
+ --------------------
+ -- Find_Interface --
+ --------------------
+
+ function Find_Interface
+ (T : Entity_Id;
+ Comp : Entity_Id) return Entity_Id
+ is
+ AI_Tag : Entity_Id;
+ Found : Boolean := False;
+ Iface : Entity_Id;
+ Typ : Entity_Id := T;
+
+ Is_Sync_Typ : Boolean := False;
+ -- In case of non concurrent-record-types each parent-type has the
+ -- tags associated with the interface types that are not implemented
+ -- by the ancestors; concurrent-record-types have their whole list of
+ -- interface tags (and this case requires some special management).
+
+ procedure Find_Iface (Typ : Entity_Id);
+ -- Internal subprogram used to recursively climb to the ancestors
+
+ ----------------
+ -- Find_Iface --
+ ----------------
+
+ procedure Find_Iface (Typ : Entity_Id) is
+ AI_Elmt : Elmt_Id;
+
+ begin
+ -- Climb to the root type
+
+ -- Handle sychronized interface derivations
+
+ if Is_Concurrent_Record_Type (Typ) then
+ declare
+ Iface_List : constant List_Id := Abstract_Interface_List (Typ);
+ begin
+ if Is_Non_Empty_List (Iface_List) then
+ Find_Iface (Etype (First (Iface_List)));
+ end if;
+ end;
+
+ -- Handle the common case
+
+ elsif Etype (Typ) /= Typ then
+ pragma Assert (not Present (Full_View (Etype (Typ))));
+ Find_Iface (Etype (Typ));
+ end if;
+
+ -- Traverse the list of interfaces implemented by the type
+
+ if not Found
+ and then Present (Abstract_Interfaces (Typ))
+ and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
+ then
+ -- Skip the tag associated with the primary table
+
+ if not Is_Sync_Typ then
+ pragma Assert
+ (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ pragma Assert (Present (AI_Tag));
+ end if;
+
+ AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
+ while Present (AI_Elmt) loop
+ if AI_Tag = Comp then
+ Iface := Node (AI_Elmt);
+ Found := True;
+ return;
+ end if;
+
+ AI_Tag := Next_Tag_Component (AI_Tag);
+ Next_Elmt (AI_Elmt);
+ end loop;
+ end if;
+ end Find_Iface;
+
+ -- Start of processing for Find_Interface
+
+ begin
+ -- Handle private types
+
+ if Has_Private_Declaration (Typ)
+ and then Present (Full_View (Typ))
+ then
+ Typ := Full_View (Typ);
+ end if;
+
+ -- Handle access types
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ -- Handle task and protected types implementing interfaces
+
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Etype (Typ);
+ end if;
+
+ -- Handle entities from the limited view
+
+ if Ekind (Typ) = E_Incomplete_Type then
+ pragma Assert (Present (Non_Limited_View (Typ)));
+ Typ := Non_Limited_View (Typ);
+ end if;
+
+ if Is_Concurrent_Record_Type (Typ) then
+ Is_Sync_Typ := True;
+ AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
+ end if;
+
+ Find_Iface (Typ);
+ pragma Assert (Found);
+ return Iface;
+ end Find_Interface;
+
+ ------------------
+ -- Find_Prim_Op --
+ ------------------
+
+ function Find_Prim_Op (T : Entity_Id; Name : Name_Id) return Entity_Id is
+ Prim : Elmt_Id;
+ Typ : Entity_Id := T;
+ Op : Entity_Id;
+
+ begin
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ := Underlying_Type (Typ);
+
+ -- Loop through primitive operations
+
+ Prim := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim) loop
+ Op := Node (Prim);
+
+ -- We can retrieve primitive operations by name if it is an internal
+ -- name. For equality we must check that both of its operands have
+ -- the same type, to avoid confusion with user-defined equalities
+ -- than may have a non-symmetric signature.
+
+ exit when Chars (Op) = Name
+ and then
+ (Name /= Name_Op_Eq
+ or else Etype (First_Entity (Op)) = Etype (Last_Entity (Op)));
+
+ Next_Elmt (Prim);
+ pragma Assert (Present (Prim));
+ end loop;
+
+ return Node (Prim);
+ end Find_Prim_Op;
+
+ ------------------
+ -- Find_Prim_Op --
+ ------------------
+
+ function Find_Prim_Op
+ (T : Entity_Id;
+ Name : TSS_Name_Type) return Entity_Id
+ is
+ Prim : Elmt_Id;
+ Typ : Entity_Id := T;
+
+ begin
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Typ := Underlying_Type (Typ);
+
+ Prim := First_Elmt (Primitive_Operations (Typ));
+ while not Is_TSS (Node (Prim), Name) loop
+ Next_Elmt (Prim);
+ pragma Assert (Present (Prim));
+ end loop;
+
+ return Node (Prim);
+ end Find_Prim_Op;
+
+ ----------------------
+ -- Force_Evaluation --
+ ----------------------
+
+ procedure Force_Evaluation (Exp : Node_Id; Name_Req : Boolean := False) is
+ begin
+ Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
+ end Force_Evaluation;
+
+ ------------------------
+ -- Generate_Poll_Call --
+ ------------------------
+
+ procedure Generate_Poll_Call (N : Node_Id) is
+ begin
+ -- No poll call if polling not active
+
+ if not Polling_Required then
+ return;
+
+ -- Otherwise generate require poll call
+
+ else
+ Insert_Before_And_Analyze (N,
+ Make_Procedure_Call_Statement (Sloc (N),
+ Name => New_Occurrence_Of (RTE (RE_Poll), Sloc (N))));
+ end if;
+ end Generate_Poll_Call;
+
+ ---------------------------------
+ -- Get_Current_Value_Condition --
+ ---------------------------------
+
+ -- Note: the implementation of this procedure is very closely tied to the
+ -- implementation of Set_Current_Value_Condition. In the Get procedure, we
+ -- interpret Current_Value fields set by the Set procedure, so the two
+ -- procedures need to be closely coordinated.
+
+ procedure Get_Current_Value_Condition
+ (Var : Node_Id;
+ Op : out Node_Kind;
+ Val : out Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Var);
+ Ent : constant Entity_Id := Entity (Var);
+
+ procedure Process_Current_Value_Condition
+ (N : Node_Id;
+ S : Boolean);
+ -- N is an expression which holds either True (S = True) or False (S =
+ -- False) in the condition. This procedure digs out the expression and
+ -- if it refers to Ent, sets Op and Val appropriately.
+
+ -------------------------------------
+ -- Process_Current_Value_Condition --
+ -------------------------------------
+
+ procedure Process_Current_Value_Condition
+ (N : Node_Id;
+ S : Boolean)
+ is
+ Cond : Node_Id;
+ Sens : Boolean;
+
+ begin
+ Cond := N;
+ Sens := S;
+
+ -- Deal with NOT operators, inverting sense
+
+ while Nkind (Cond) = N_Op_Not loop
+ Cond := Right_Opnd (Cond);
+ Sens := not Sens;
+ end loop;
+
+ -- Deal with AND THEN and AND cases
+
+ 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).
+
+ if Sens = False then
+ Op := N_Empty;
+ Val := Empty;
+ return;
+ end if;
+
+ -- Recursively process AND and AND THEN branches
+
+ Process_Current_Value_Condition (Left_Opnd (Cond), True);
+
+ if Op /= N_Empty then
+ return;
+ end if;
+
+ Process_Current_Value_Condition (Right_Opnd (Cond), True);
+ return;
+
+ -- Case of relational operator
+
+ elsif Nkind (Cond) in N_Op_Compare then
+ Op := Nkind (Cond);
+
+ -- Invert sense of test if inverted test
+
+ if Sens = False then
+ case Op is
+ when N_Op_Eq => Op := N_Op_Ne;
+ when N_Op_Ne => Op := N_Op_Eq;
+ when N_Op_Lt => Op := N_Op_Ge;
+ when N_Op_Gt => Op := N_Op_Le;
+ when N_Op_Le => Op := N_Op_Gt;
+ when N_Op_Ge => Op := N_Op_Lt;
+ when others => raise Program_Error;
+ end case;
+ end if;
+
+ -- Case of entity op value
+
+ if Is_Entity_Name (Left_Opnd (Cond))
+ and then Ent = Entity (Left_Opnd (Cond))
+ and then Compile_Time_Known_Value (Right_Opnd (Cond))
+ then
+ Val := Right_Opnd (Cond);
+
+ -- Case of value op entity
+
+ elsif Is_Entity_Name (Right_Opnd (Cond))
+ and then Ent = Entity (Right_Opnd (Cond))
+ and then Compile_Time_Known_Value (Left_Opnd (Cond))
+ then
+ Val := Left_Opnd (Cond);
+
+ -- We are effectively swapping operands
+
+ case Op is
+ when N_Op_Eq => null;
+ when N_Op_Ne => null;
+ when N_Op_Lt => Op := N_Op_Gt;
+ when N_Op_Gt => Op := N_Op_Lt;
+ when N_Op_Le => Op := N_Op_Ge;
+ when N_Op_Ge => Op := N_Op_Le;
+ when others => raise Program_Error;
+ end case;
+
+ else
+ Op := N_Empty;
+ end if;
+
+ return;
+
+ -- Case of Boolean variable reference, return as though the
+ -- reference had said var = True.
+
+ else
+ if Is_Entity_Name (Cond)
+ and then Ent = Entity (Cond)
+ then
+ Val := New_Occurrence_Of (Standard_True, Sloc (Cond));
+
+ if Sens = False then
+ Op := N_Op_Ne;
+ else
+ Op := N_Op_Eq;
+ end if;
+ end if;
+ end if;
+ end Process_Current_Value_Condition;
+
+ -- Start of processing for Get_Current_Value_Condition
+
+ begin
+ Op := N_Empty;
+ Val := Empty;
+
+ -- Immediate return, nothing doing, if this is not an object
+
+ if Ekind (Ent) not in Object_Kind then
+ return;
+ end if;
+
+ -- Otherwise examine current value
+
+ declare
+ CV : constant Node_Id := Current_Value (Ent);
+ Sens : Boolean;
+ Stm : Node_Id;
+
+ begin
+ -- If statement. Condition is known true in THEN section, known False
+ -- in any ELSIF or ELSE part, and unknown outside the IF statement.
+
+ if Nkind (CV) = N_If_Statement then
+
+ -- Before start of IF statement
+
+ if Loc < Sloc (CV) then
+ return;
+
+ -- After end of IF statement
+
+ elsif Loc >= Sloc (CV) + Text_Ptr (UI_To_Int (End_Span (CV))) then
+ return;
+ end if;
+
+ -- At this stage we know that we are within the IF statement, but
+ -- unfortunately, the tree does not record the SLOC of the ELSE so
+ -- we cannot use a simple SLOC comparison to distinguish between
+ -- the then/else statements, so we have to climb the tree.
+
+ declare
+ N : Node_Id;
+
+ begin
+ N := Parent (Var);
+ while Parent (N) /= CV loop
+ N := Parent (N);
+
+ -- If we fall off the top of the tree, then that's odd, but
+ -- perhaps it could occur in some error situation, and the
+ -- safest response is simply to assume that the outcome of
+ -- the condition is unknown. No point in bombing during an
+ -- attempt to optimize things.
+
+ if No (N) then
+ return;
+ end if;
+ end loop;
+
+ -- Now we have N pointing to a node whose parent is the IF
+ -- statement in question, so now we can tell if we are within
+ -- the THEN statements.
+
+ if Is_List_Member (N)
+ and then List_Containing (N) = Then_Statements (CV)
+ then
+ Sens := True;
+
+ -- If the variable reference does not come from source, we
+ -- cannot reliably tell whether it appears in the else part.
+ -- In particular, if if appears in generated code for a node
+ -- that requires finalization, it may be attached to a list
+ -- that has not been yet inserted into the code. For now,
+ -- treat it as unknown.
+
+ elsif not Comes_From_Source (N) then
+ return;
+
+ -- Otherwise we must be in ELSIF or ELSE part
+
+ else
+ Sens := False;
+ end if;
+ 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 Nkind (CV) = N_Elsif_Part then
+ Stm := Parent (CV);
+
+ -- Before start of ELSIF part
+
+ if Loc < Sloc (CV) then
+ return;
+
+ -- After end of IF statement
+
+ elsif Loc >= Sloc (Stm) +
+ Text_Ptr (UI_To_Int (End_Span (Stm)))
+ then
+ return;
+ end if;
+
+ -- Again we lack the SLOC of the ELSE, so we need to climb the
+ -- tree to see if we are within the ELSIF part in question.
+
+ declare
+ N : Node_Id;
+
+ begin
+ N := Parent (Var);
+ while Parent (N) /= Stm loop
+ N := Parent (N);
+
+ -- If we fall off the top of the tree, then that's odd, but
+ -- perhaps it could occur in some error situation, and the
+ -- safest response is simply to assume that the outcome of
+ -- the condition is unknown. No point in bombing during an
+ -- attempt to optimize things.
+
+ if No (N) then
+ return;
+ end if;
+ end loop;
+
+ -- Now we have N pointing to a node whose parent is the IF
+ -- statement in question, so see if is the ELSIF part we want.
+ -- the THEN statements.
+
+ if N = CV then
+ Sens := True;
+
+ -- Otherwise we must be in susbequent ELSIF or ELSE part
+
+ else
+ Sens := False;
+ end if;
+ end;
+
+ -- Iteration scheme of while loop. The condition is known to be
+ -- true within the body of the loop.
+
+ elsif Nkind (CV) = N_Iteration_Scheme then
+ declare
+ Loop_Stmt : constant Node_Id := Parent (CV);
+
+ begin
+ -- Before start of body of loop
+
+ if Loc < Sloc (Loop_Stmt) then
+ return;
+
+ -- After end of LOOP statement
+
+ elsif Loc >= Sloc (End_Label (Loop_Stmt)) then
+ return;
+
+ -- We are within the body of the loop
+
+ else
+ Sens := True;
+ end if;
+ end;
+
+ -- All other cases of Current_Value settings
+
+ else
+ return;
+ end if;
+
+ -- If we fall through here, then we have a reportable condition, Sens
+ -- is True if the condition is true and False if it needs inverting.
+
+ Process_Current_Value_Condition (Condition (CV), Sens);
+ end;
+ end Get_Current_Value_Condition;
+
+ ---------------------------------
+ -- Has_Controlled_Coextensions --
+ ---------------------------------
+
+ function Has_Controlled_Coextensions (Typ : Entity_Id) return Boolean is
+ D_Typ : Entity_Id;
+ Discr : Entity_Id;
+
+ begin
+ -- Only consider record types
+
+ if Ekind (Typ) /= E_Record_Type
+ and then Ekind (Typ) /= E_Record_Subtype
+ then
+ return False;
+ end if;
+
+ if Has_Discriminants (Typ) then
+ Discr := First_Discriminant (Typ);
+ while Present (Discr) loop
+ D_Typ := Etype (Discr);
+
+ if Ekind (D_Typ) = E_Anonymous_Access_Type
+ and then
+ (Is_Controlled (Directly_Designated_Type (D_Typ))
+ or else
+ Is_Concurrent_Type (Directly_Designated_Type (D_Typ)))
+ then
+ return True;
+ end if;
+
+ Next_Discriminant (Discr);
+ end loop;
+ end if;
+
+ return False;
+ end Has_Controlled_Coextensions;
+
+ --------------------
+ -- Homonym_Number --
+ --------------------
+
+ function Homonym_Number (Subp : Entity_Id) return Nat is
+ Count : Nat;
+ Hom : Entity_Id;
+
+ begin
+ Count := 1;
+ Hom := Homonym (Subp);
+ while Present (Hom) loop
+ if Scope (Hom) = Scope (Subp) then
+ Count := Count + 1;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+
+ return Count;
+ end Homonym_Number;
+
+ ------------------------------
+ -- In_Unconditional_Context --
+ ------------------------------
+
+ function In_Unconditional_Context (Node : Node_Id) return Boolean is
+ P : Node_Id;
+
+ begin
+ P := Node;
+ while Present (P) loop
+ case Nkind (P) is
+ when N_Subprogram_Body =>
+ return True;
+
+ when N_If_Statement =>
+ return False;
+
+ when N_Loop_Statement =>
+ return False;
+
+ when N_Case_Statement =>
+ return False;
+
+ when others =>
+ P := Parent (P);
+ end case;
+ end loop;
+
+ return False;
+ end In_Unconditional_Context;
+
+ -------------------
+ -- Insert_Action --
+ -------------------
+
+ procedure Insert_Action (Assoc_Node : Node_Id; Ins_Action : Node_Id) is
+ begin
+ if Present (Ins_Action) then
+ Insert_Actions (Assoc_Node, New_List (Ins_Action));
+ end if;
+ end Insert_Action;
+
+ -- Version with check(s) suppressed
+
+ procedure Insert_Action
+ (Assoc_Node : Node_Id; Ins_Action : Node_Id; Suppress : Check_Id)
+ is
+ begin
+ Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
+ end Insert_Action;
+
+ --------------------
+ -- Insert_Actions --
+ --------------------
+
+ procedure Insert_Actions (Assoc_Node : Node_Id; Ins_Actions : List_Id) is
+ N : Node_Id;
+ P : Node_Id;
+
+ Wrapped_Node : Node_Id := Empty;
+
+ begin
+ if No (Ins_Actions) or else Is_Empty_List (Ins_Actions) then
+ return;
+ end if;
+
+ -- Ignore insert of actions from inside default expression in the
+ -- special preliminary analyze mode. Any insertions at this point
+ -- have no relevance, since we are only doing the analyze to freeze
+ -- the types of any static expressions. See section "Handling of
+ -- Default Expressions" in the spec of package Sem for further details.
+
+ if In_Default_Expression then
+ return;
+ end if;
+
+ -- If the action derives from stuff inside a record, then the actions
-- are attached to the current scope, to be inserted and analyzed on
-- exit from the scope. The reason for this is that we may also
-- be generating freeze actions at the same time, and they must
not Is_Procedure_Attribute_Name
(Attribute_Name (Assoc_Node)))
then
- P := Assoc_Node; -- ????? does not agree with above!
+ P := Assoc_Node; -- ??? does not agree with above!
N := Parent (Assoc_Node);
-- Non-subexpression case. Note that N is initially Empty in this
-- Capture root of the transient scope
if Scope_Is_Transient then
- Wrapped_Node := Node_To_Be_Wrapped;
+ Wrapped_Node := Node_To_Be_Wrapped;
end if;
loop
return;
end if;
- -- Statements, declarations, pragmas, representation clauses.
+ -- Statements, declarations, pragmas, representation clauses
when
-- Statements
N_Entry_Body |
N_Exception_Declaration |
N_Exception_Renaming_Declaration |
+ N_Formal_Abstract_Subprogram_Declaration |
+ N_Formal_Concrete_Subprogram_Declaration |
N_Formal_Object_Declaration |
- N_Formal_Subprogram_Declaration |
N_Formal_Type_Declaration |
N_Full_Type_Declaration |
N_Function_Instantiation |
null;
-- Do not insert if parent of P is an N_Component_Association
- -- node (i.e. we are in the context of an N_Aggregate node.
- -- In this case we want to insert before the entire aggregate.
+ -- node (i.e. we are in the context of an N_Aggregate or
+ -- N_Extension_Aggregate node. In this case we want to insert
+ -- before the entire aggregate.
elsif Nkind (Parent (P)) = N_Component_Association then
null;
-- Otherwise we can go ahead and do the insertion
- elsif P = Wrapped_Node then
+ elsif P = Wrapped_Node then
Store_Before_Actions_In_Scope (Ins_Actions);
return;
-- If a component association appears within a loop created for
-- an array aggregate, attach the actions to the association so
-- they can be subsequently inserted within the loop. For other
- -- component associations insert outside of the aggregate.
+ -- component associations insert outside of the aggregate. For
+ -- an association that will generate a loop, its Loop_Actions
+ -- attribute is already initialized (see exp_aggr.adb).
-- The list of loop_actions can in turn generate additional ones,
-- that are inserted before the associated node. If the associated
when
N_Component_Association =>
if Nkind (Parent (P)) = N_Aggregate
- and then Present (Aggregate_Bounds (Parent (P)))
- and then Nkind (First (Choices (P))) = N_Others_Choice
- and then Nkind (First (Ins_Actions)) /= N_Freeze_Entity
+ and then Present (Loop_Actions (P))
then
- if No (Loop_Actions (P)) then
+ if Is_Empty_List (Loop_Actions (P)) then
Set_Loop_Actions (P, Ins_Actions);
Analyze_List (Ins_Actions);
else
declare
- Decl : Node_Id := Assoc_Node;
+ Decl : Node_Id;
begin
-- 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
exit when Parent (Decl) = P
and then Is_List_Member (Decl)
N_Compilation_Unit_Aux |
N_Component_Clause |
N_Component_Declaration |
+ N_Component_Definition |
N_Component_List |
N_Constrained_Array_Definition |
N_Decimal_Fixed_Point_Definition |
N_Package_Specification |
N_Parameter_Association |
N_Parameter_Specification |
+ N_Pop_Constraint_Error_Label |
+ N_Pop_Program_Error_Label |
+ N_Pop_Storage_Error_Label |
N_Pragma_Argument_Association |
N_Procedure_Specification |
N_Protected_Body |
N_Protected_Definition |
+ N_Push_Constraint_Error_Label |
+ N_Push_Program_Error_Label |
+ N_Push_Storage_Error_Label |
N_Qualified_Expression |
N_Range |
N_Range_Constraint |
N_Variant |
N_Variant_Part |
N_Validate_Unchecked_Conversion |
- N_With_Clause |
- N_With_Type_Clause
+ N_With_Clause
=>
null;
P := Parent (N);
end if;
end loop;
-
end Insert_Actions;
-- Version with check(s) suppressed
procedure Insert_Actions
- (Assoc_Node : Node_Id; Ins_Actions : List_Id; Suppress : Check_Id)
+ (Assoc_Node : Node_Id;
+ Ins_Actions : List_Id;
+ Suppress : Check_Id)
is
begin
if Suppress = All_Checks then
declare
- Svg : constant Suppress_Record := Scope_Suppress;
-
+ Svg : constant Suppress_Array := Scope_Suppress;
begin
Scope_Suppress := (others => True);
Insert_Actions (Assoc_Node, Ins_Actions);
else
declare
- Svg : constant Boolean := Get_Scope_Suppress (Suppress);
-
+ Svg : constant Boolean := Scope_Suppress (Suppress);
begin
- Set_Scope_Suppress (Suppress, True);
+ Scope_Suppress (Suppress) := True;
Insert_Actions (Assoc_Node, Ins_Actions);
- Set_Scope_Suppress (Suppress, Svg);
+ Scope_Suppress (Suppress) := Svg;
end;
end if;
end Insert_Actions;
Aux : constant Node_Id := Aux_Decls_Node (Cunit (Main_Unit));
begin
- New_Scope (Cunit_Entity (Main_Unit));
+ Push_Scope (Cunit_Entity (Main_Unit));
+ -- ??? should this be Current_Sem_Unit instead of Main_Unit?
if No (Actions (Aux)) then
Set_Actions (Aux, New_List (N));
begin
if Is_Non_Empty_List (L) then
- New_Scope (Cunit_Entity (Main_Unit));
+ Push_Scope (Cunit_Entity (Main_Unit));
+ -- ??? should this be Current_Sem_Unit instead of Main_Unit?
if No (Actions (Aux)) then
Set_Actions (Aux, L);
begin
S := Current_Scope;
- while S /= Standard_Standard loop
- if Chars (S) = Name_uInit_Proc then
+ while Present (S)
+ and then S /= Standard_Standard
+ loop
+ if Is_Init_Proc (S) then
return True;
else
S := Scope (S);
return False;
end Inside_Init_Proc;
+ ----------------------------
+ -- Is_All_Null_Statements --
+ ----------------------------
+
+ function Is_All_Null_Statements (L : List_Id) return Boolean is
+ Stm : Node_Id;
+
+ begin
+ Stm := First (L);
+ while Present (Stm) loop
+ if Nkind (Stm) /= N_Null_Statement then
+ return False;
+ end if;
+
+ Next (Stm);
+ end loop;
+
+ return True;
+ end Is_All_Null_Statements;
+
+ -----------------------------------------
+ -- Is_Predefined_Dispatching_Operation --
+ -----------------------------------------
+
+ function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
+ .. Name_Len));
+ if Chars (E) = Name_uSize
+ or else Chars (E) = Name_uAlignment
+ or else TSS_Name = TSS_Stream_Read
+ or else TSS_Name = TSS_Stream_Write
+ or else TSS_Name = TSS_Stream_Input
+ or else TSS_Name = TSS_Stream_Output
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
+ or else Chars (E) = Name_uAssign
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else (Ada_Version >= Ada_05
+ and then (Chars (E) = Name_uDisp_Asynchronous_Select
+ or else Chars (E) = Name_uDisp_Conditional_Select
+ or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
+ or else Chars (E) = Name_uDisp_Get_Task_Id
+ or else Chars (E) = Name_uDisp_Timed_Select))
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Dispatching_Operation;
+
+ ----------------------------------
+ -- Is_Possibly_Unaligned_Object --
+ ----------------------------------
+
+ function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean is
+ T : constant Entity_Id := Etype (N);
+
+ begin
+ -- If renamed object, apply test to underlying object
+
+ if Is_Entity_Name (N)
+ and then Is_Object (Entity (N))
+ and then Present (Renamed_Object (Entity (N)))
+ then
+ return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N)));
+ end if;
+
+ -- Tagged and controlled types and aliased types are always aligned,
+ -- as are concurrent types.
+
+ if Is_Aliased (T)
+ or else Has_Controlled_Component (T)
+ or else Is_Concurrent_Type (T)
+ or else Is_Tagged_Type (T)
+ or else Is_Controlled (T)
+ then
+ return False;
+ end if;
+
+ -- If this is an element of a packed array, may be unaligned
+
+ if Is_Ref_To_Bit_Packed_Array (N) then
+ return True;
+ end if;
+
+ -- Case of component reference
+
+ if Nkind (N) = N_Selected_Component then
+ declare
+ P : constant Node_Id := Prefix (N);
+ C : constant Entity_Id := Entity (Selector_Name (N));
+ M : Nat;
+ S : Nat;
+
+ begin
+ -- If component reference is for an array with non-static bounds,
+ -- then it is always aligned: we can only process unaligned
+ -- arrays with static bounds (more accurately bounds known at
+ -- compile time).
+
+ if Is_Array_Type (T)
+ and then not Compile_Time_Known_Bounds (T)
+ then
+ return False;
+ end if;
+
+ -- If component is aliased, it is definitely properly aligned
+
+ if Is_Aliased (C) then
+ return False;
+ end if;
+
+ -- If component is for a type implemented as a scalar, and the
+ -- record is packed, and the component is other than the first
+ -- component of the record, then the component may be unaligned.
+
+ if Is_Packed (Etype (P))
+ and then Represented_As_Scalar (Etype (C))
+ and then First_Entity (Scope (C)) /= C
+ then
+ return True;
+ end if;
+
+ -- Compute maximum possible alignment for T
+
+ -- If alignment is known, then that settles things
+
+ if Known_Alignment (T) then
+ M := UI_To_Int (Alignment (T));
+
+ -- If alignment is not known, tentatively set max alignment
+
+ else
+ M := Ttypes.Maximum_Alignment;
+
+ -- We can reduce this if the Esize is known since the default
+ -- alignment will never be more than the smallest power of 2
+ -- that does not exceed this Esize value.
+
+ if Known_Esize (T) then
+ S := UI_To_Int (Esize (T));
+
+ while (M / 2) >= S loop
+ M := M / 2;
+ end loop;
+ end if;
+ end if;
+
+ -- 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
+
+ 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.
+
+ if Present (Component_Clause (C)) then
+
+ -- Otherwise we can do a test to make sure that the actual
+ -- start position in the record, and the length, are both
+ -- consistent with the required alignment. If not, we know
+ -- that we are unaligned.
+
+ declare
+ Align_In_Bits : constant Nat := M * System_Storage_Unit;
+ begin
+ if Component_Bit_Offset (C) mod Align_In_Bits /= 0
+ or else Esize (C) mod Align_In_Bits /= 0
+ then
+ return True;
+ end if;
+ end;
+ end if;
+
+ -- Otherwise, for a component reference, test prefix
+
+ return Is_Possibly_Unaligned_Object (P);
+ end;
+
+ -- If not a component reference, must be aligned
+
+ else
+ return False;
+ end if;
+ end Is_Possibly_Unaligned_Object;
+
+ ---------------------------------
+ -- Is_Possibly_Unaligned_Slice --
+ ---------------------------------
+
+ function Is_Possibly_Unaligned_Slice (N : Node_Id) return Boolean is
+ begin
+ -- Go to renamed object
+
+ if Is_Entity_Name (N)
+ and then Is_Object (Entity (N))
+ and then Present (Renamed_Object (Entity (N)))
+ then
+ return Is_Possibly_Unaligned_Slice (Renamed_Object (Entity (N)));
+ end if;
+
+ -- The reference must be a slice
+
+ if Nkind (N) /= N_Slice then
+ return False;
+ end if;
+
+ -- Always assume the worst for a nested record component with a
+ -- component clause, which gigi/gcc does not appear to handle well.
+ -- It is not clear why this special test is needed at all ???
+
+ if Nkind (Prefix (N)) = N_Selected_Component
+ and then Nkind (Prefix (Prefix (N))) = N_Selected_Component
+ and then
+ Present (Component_Clause (Entity (Selector_Name (Prefix (N)))))
+ then
+ return True;
+ end if;
+
+ -- We only need to worry if the target has strict alignment
+
+ if not Target_Strict_Alignment then
+ return False;
+ end if;
+
+ -- If it is a slice, then look at the array type being sliced
+
+ declare
+ Sarr : constant Node_Id := Prefix (N);
+ -- Prefix of the slice, i.e. the array being sliced
+
+ Styp : constant Entity_Id := Etype (Prefix (N));
+ -- Type of the array being sliced
+
+ Pref : Node_Id;
+ Ptyp : Entity_Id;
+
+ begin
+ -- The problems arise if the array object that is being sliced
+ -- is a component of a record or array, and we cannot guarantee
+ -- the alignment of the array within its containing object.
+
+ -- To investigate this, we look at successive prefixes to see
+ -- if we have a worrisome indexed or selected component.
+
+ Pref := Sarr;
+ loop
+ -- Case of array is part of an indexed component reference
+
+ if Nkind (Pref) = N_Indexed_Component then
+ Ptyp := Etype (Prefix (Pref));
+
+ -- The only problematic case is when the array is packed,
+ -- in which case we really know nothing about the alignment
+ -- of individual components.
+
+ if Is_Bit_Packed_Array (Ptyp) then
+ return True;
+ end if;
+
+ -- Case of array is part of a selected component reference
+
+ elsif Nkind (Pref) = N_Selected_Component then
+ Ptyp := Etype (Prefix (Pref));
+
+ -- We are definitely in trouble if the record in question
+ -- has an alignment, and either we know this alignment is
+ -- inconsistent with the alignment of the slice, or we
+ -- don't know what the alignment of the slice should be.
+
+ if Known_Alignment (Ptyp)
+ and then (Unknown_Alignment (Styp)
+ or else Alignment (Styp) > Alignment (Ptyp))
+ then
+ return True;
+ end if;
+
+ -- We are in potential trouble if the record type is packed.
+ -- We could special case when we know that the array is the
+ -- first component, but that's not such a simple case ???
+
+ if Is_Packed (Ptyp) then
+ return True;
+ end if;
+
+ -- We are in trouble if there is a component clause, and
+ -- either we do not know the alignment of the slice, or
+ -- the alignment of the slice is inconsistent with the
+ -- bit position specified by the component clause.
+
+ declare
+ Field : constant Entity_Id := Entity (Selector_Name (Pref));
+ begin
+ if Present (Component_Clause (Field))
+ and then
+ (Unknown_Alignment (Styp)
+ or else
+ (Component_Bit_Offset (Field) mod
+ (System_Storage_Unit * Alignment (Styp))) /= 0)
+ then
+ return True;
+ end if;
+ end;
+
+ -- For cases other than selected or indexed components we
+ -- know we are OK, since no issues arise over alignment.
+
+ else
+ return False;
+ end if;
+
+ -- We processed an indexed component or selected component
+ -- reference that looked safe, so keep checking prefixes.
+
+ Pref := Prefix (Pref);
+ end loop;
+ end;
+ end Is_Possibly_Unaligned_Slice;
+
--------------------------------
-- Is_Ref_To_Bit_Packed_Array --
--------------------------------
- function Is_Ref_To_Bit_Packed_Array (P : Node_Id) return Boolean is
+ function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean is
Result : Boolean;
Expr : Node_Id;
begin
- if Nkind (P) = N_Indexed_Component
+ if Is_Entity_Name (N)
+ and then Is_Object (Entity (N))
+ and then Present (Renamed_Object (Entity (N)))
+ then
+ return Is_Ref_To_Bit_Packed_Array (Renamed_Object (Entity (N)));
+ end if;
+
+ if Nkind (N) = N_Indexed_Component
or else
- Nkind (P) = N_Selected_Component
+ Nkind (N) = N_Selected_Component
then
- if Is_Bit_Packed_Array (Etype (Prefix (P))) then
+ if Is_Bit_Packed_Array (Etype (Prefix (N))) then
Result := True;
else
- Result := Is_Ref_To_Bit_Packed_Array (Prefix (P));
+ Result := Is_Ref_To_Bit_Packed_Array (Prefix (N));
end if;
- if Result and then Nkind (P) = N_Indexed_Component then
- Expr := First (Expressions (P));
-
+ if Result and then Nkind (N) = N_Indexed_Component then
+ Expr := First (Expressions (N));
while Present (Expr) loop
Force_Evaluation (Expr);
Next (Expr);
end Is_Ref_To_Bit_Packed_Array;
--------------------------------
- -- Is_Ref_To_Bit_Packed_Slce --
+ -- Is_Ref_To_Bit_Packed_Slice --
--------------------------------
- function Is_Ref_To_Bit_Packed_Slice (P : Node_Id) return Boolean is
+ function Is_Ref_To_Bit_Packed_Slice (N : Node_Id) return Boolean is
begin
- if Nkind (P) = N_Slice
- and then Is_Bit_Packed_Array (Etype (Prefix (P)))
+ if Nkind (N) = N_Type_Conversion then
+ return Is_Ref_To_Bit_Packed_Slice (Expression (N));
+
+ elsif Is_Entity_Name (N)
+ and then Is_Object (Entity (N))
+ and then Present (Renamed_Object (Entity (N)))
+ then
+ return Is_Ref_To_Bit_Packed_Slice (Renamed_Object (Entity (N)));
+
+ elsif Nkind (N) = N_Slice
+ and then Is_Bit_Packed_Array (Etype (Prefix (N)))
then
return True;
- elsif Nkind (P) = N_Indexed_Component
+ elsif Nkind (N) = N_Indexed_Component
or else
- Nkind (P) = N_Selected_Component
+ Nkind (N) = N_Selected_Component
then
- return Is_Ref_To_Bit_Packed_Slice (Prefix (P));
+ return Is_Ref_To_Bit_Packed_Slice (Prefix (N));
else
return False;
and then not Is_Tagged_Type (Full_View (T))
and then Is_Derived_Type (Full_View (T))
and then Etype (Full_View (T)) /= T);
-
end Is_Untagged_Derivation;
--------------------
-- Kill_Dead_Code --
--------------------
- procedure Kill_Dead_Code (N : Node_Id) is
+ procedure Kill_Dead_Code (N : Node_Id; Warn : Boolean := False) is
begin
if Present (N) then
- Remove_Handler_Entries (N);
Remove_Warning_Messages (N);
- -- Recurse into block statements to process declarations/statements
+ if Warn then
+ Error_Msg_F
+ ("?this code can never be executed and has been deleted", N);
+ end if;
+
+ -- Recurse into block statements and bodies to process declarations
+ -- and statements
+
+ if Nkind (N) = N_Block_Statement
+ or else Nkind (N) = N_Subprogram_Body
+ or else Nkind (N) = N_Package_Body
+ then
+ Kill_Dead_Code
+ (Declarations (N), False);
+ Kill_Dead_Code
+ (Statements (Handled_Statement_Sequence (N)));
+
+ if Nkind (N) = N_Subprogram_Body then
+ Set_Is_Eliminated (Defining_Entity (N));
+ end if;
+
+ elsif Nkind (N) = N_Package_Declaration then
+ Kill_Dead_Code (Visible_Declarations (Specification (N)));
+ Kill_Dead_Code (Private_Declarations (Specification (N)));
+
+ declare
+ E : Entity_Id := First_Entity (Defining_Entity (N));
+ begin
+ while Present (E) loop
+ if Ekind (E) = E_Operator then
+ Set_Is_Eliminated (E);
+ end if;
- if Nkind (N) = N_Block_Statement then
- Kill_Dead_Code (Declarations (N));
- Kill_Dead_Code (Statements (Handled_Statement_Sequence (N)));
+ Next_Entity (E);
+ end loop;
+ end;
-- Recurse into composite statement to kill individual statements,
-- in particular instantiations.
elsif Nkind (N) = N_Case_Statement then
declare
- Alt : Node_Id := First (Alternatives (N));
-
+ Alt : Node_Id;
begin
+ Alt := First (Alternatives (N));
while Present (Alt) loop
Kill_Dead_Code (Statements (Alt));
Next (Alt);
end loop;
end;
- -- Deal with dead instances caused by deleting instantiations
+ elsif Nkind (N) = N_Case_Statement_Alternative then
+ Kill_Dead_Code (Statements (N));
+
+ -- Deal with dead instances caused by deleting instantiations
+
+ elsif Nkind (N) in N_Generic_Instantiation then
+ Remove_Dead_Instance (N);
+ end if;
+
+ Delete_Tree (N);
+ end if;
+ end Kill_Dead_Code;
+
+ -- Case where argument is a list of nodes to be killed
+
+ procedure Kill_Dead_Code (L : List_Id; Warn : Boolean := False) is
+ N : Node_Id;
+ W : Boolean;
+ begin
+ W := Warn;
+ if Is_Non_Empty_List (L) then
+ loop
+ N := Remove_Head (L);
+ exit when No (N);
+ Kill_Dead_Code (N, W);
+ W := False;
+ end loop;
+ end if;
+ end Kill_Dead_Code;
+
+ ------------------------
+ -- Known_Non_Negative --
+ ------------------------
+
+ function Known_Non_Negative (Opnd : Node_Id) return Boolean is
+ begin
+ if Is_OK_Static_Expression (Opnd)
+ and then Expr_Value (Opnd) >= 0
+ then
+ return True;
+
+ else
+ declare
+ Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
+
+ begin
+ return
+ Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
+ end;
+ end if;
+ end Known_Non_Negative;
+
+ --------------------
+ -- Known_Non_Null --
+ --------------------
+
+ function Known_Non_Null (N : Node_Id) return Boolean is
+ begin
+ -- Checks for case where N is an entity reference
+
+ if Is_Entity_Name (N) and then Present (Entity (N)) then
+ declare
+ E : constant Entity_Id := Entity (N);
+ Op : Node_Kind;
+ Val : Node_Id;
+
+ begin
+ -- First check if we are in decisive conditional
+
+ Get_Current_Value_Condition (N, Op, Val);
+
+ if Nkind (Val) = N_Null then
+ if Op = N_Op_Eq then
+ return False;
+ elsif Op = N_Op_Ne then
+ return True;
+ end if;
+ end if;
+
+ -- If OK to do replacement, test Is_Known_Non_Null flag
+
+ if OK_To_Do_Constant_Replacement (E) then
+ return Is_Known_Non_Null (E);
+
+ -- Otherwise if not safe to do replacement, then say so
+
+ else
+ return False;
+ end if;
+ end;
+
+ -- True if access attribute
- elsif Nkind (N) in N_Generic_Instantiation then
- Remove_Dead_Instance (N);
- end if;
+ elsif Nkind (N) = N_Attribute_Reference
+ and then (Attribute_Name (N) = Name_Access
+ or else
+ Attribute_Name (N) = Name_Unchecked_Access
+ or else
+ Attribute_Name (N) = Name_Unrestricted_Access)
+ then
+ return True;
- Delete_Tree (N);
- end if;
- end Kill_Dead_Code;
+ -- True if allocator
- -- Case where argument is a list of nodes to be killed
+ elsif Nkind (N) = N_Allocator then
+ return True;
- procedure Kill_Dead_Code (L : List_Id) is
- N : Node_Id;
+ -- For a conversion, true if expression is known non-null
- begin
- if Is_Non_Empty_List (L) then
- loop
- N := Remove_Head (L);
- exit when No (N);
- Kill_Dead_Code (N);
- end loop;
+ elsif Nkind (N) = N_Type_Conversion then
+ return Known_Non_Null (Expression (N));
+
+ -- Above are all cases where the value could be determined to be
+ -- non-null. In all other cases, we don't know, so return False.
+
+ else
+ return False;
end if;
- end Kill_Dead_Code;
+ end Known_Non_Null;
- ------------------------
- -- Known_Non_Negative --
- ------------------------
+ ----------------
+ -- Known_Null --
+ ----------------
- function Known_Non_Negative (Opnd : Node_Id) return Boolean is
+ function Known_Null (N : Node_Id) return Boolean is
begin
- if Is_OK_Static_Expression (Opnd)
- and then Expr_Value (Opnd) >= 0
- then
- return True;
+ -- Checks for case where N is an entity reference
- else
+ if Is_Entity_Name (N) and then Present (Entity (N)) then
declare
- Lo : constant Node_Id := Type_Low_Bound (Etype (Opnd));
+ E : constant Entity_Id := Entity (N);
+ Op : Node_Kind;
+ Val : Node_Id;
begin
- return
- Is_OK_Static_Expression (Lo) and then Expr_Value (Lo) >= 0;
+ -- First check if we are in decisive conditional
+
+ Get_Current_Value_Condition (N, Op, Val);
+
+ if Nkind (Val) = N_Null then
+ if Op = N_Op_Eq then
+ return True;
+ elsif Op = N_Op_Ne then
+ return False;
+ end if;
+ end if;
+
+ -- If OK to do replacement, test Is_Known_Null flag
+
+ if OK_To_Do_Constant_Replacement (E) then
+ return Is_Known_Null (E);
+
+ -- Otherwise if not safe to do replacement, then say so
+
+ else
+ return False;
+ end if;
end;
+
+ -- True if explicit reference to null
+
+ elsif Nkind (N) = N_Null then
+ return True;
+
+ -- For a conversion, true if expression is known null
+
+ elsif Nkind (N) = N_Type_Conversion then
+ return Known_Null (Expression (N));
+
+ -- Above are all cases where the value could be determined to be null.
+ -- In all other cases, we don't know, so return False.
+
+ else
+ return False;
end if;
- end Known_Non_Negative;
+ end Known_Null;
-----------------------------
-- Make_CW_Equivalent_Type --
-- type Equiv_T is record
-- _parent : T (List of discriminant constaints taken from Exp);
- -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'size) / Storage_Unit);
+ -- Ext__50 : Storage_Array (1 .. (Exp'size - Typ'object_size)/8);
-- end Equiv_T;
+ --
+ -- ??? Note that this type does not guarantee same alignment as all
+ -- derived types
function Make_CW_Equivalent_Type
- (T : Entity_Id;
- E : Node_Id)
- return Entity_Id
+ (T : Entity_Id;
+ E : Node_Id) return Entity_Id
is
Loc : constant Source_Ptr := Sloc (E);
Root_Typ : constant Entity_Id := Root_Type (T);
+ List_Def : constant List_Id := Empty_List;
+ Comp_List : constant List_Id := New_List;
Equiv_Type : Entity_Id;
Range_Type : Entity_Id;
Str_Type : Entity_Id;
- List_Def : List_Id := Empty_List;
Constr_Root : Entity_Id;
Sizexpr : Node_Id;
Make_Subtype_From_Expr (E, Root_Typ)));
end if;
- -- subtype rg__xx is Storage_Offset range
- -- (Expr'size - typ'size) / Storage_Unit
+ -- Generate the range subtype declaration
Range_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
- Sizexpr :=
- Make_Op_Subtract (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => OK_Convert_To (T, Duplicate_Subexpr (E)),
- Attribute_Name => Name_Size),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Constr_Root, Loc),
- Attribute_Name => Name_Size));
+ if not Is_Interface (Root_Typ) then
+ -- subtype rg__xx is
+ -- Storage_Offset range 1 .. (Expr'size - typ'size) / Storage_Unit
+
+ Sizexpr :=
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+ Attribute_Name => Name_Size),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Constr_Root, Loc),
+ Attribute_Name => Name_Object_Size));
+ else
+ -- subtype rg__xx is
+ -- Storage_Offset range 1 .. Expr'size / Storage_Unit
+
+ Sizexpr :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ OK_Convert_To (T, Duplicate_Subexpr_No_Checks (E)),
+ Attribute_Name => Name_Size);
+ end if;
Set_Paren_Count (Sizexpr, 1);
New_List (New_Reference_To (Range_Type, Loc))))));
-- type Equiv_T is record
- -- _parent : Tnn;
+ -- [ _parent : Tnn; ]
-- E : Str_Type;
-- end Equiv_T;
Equiv_Type := Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
- -- Avoid the generation of an init procedure
+ -- 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.
- Set_Is_Frozen (Equiv_Type);
+ if not Frontend_Layout_On_Target then
+ Set_Is_Frozen (Equiv_Type);
+ end if;
Set_Ekind (Equiv_Type, E_Record_Type);
Set_Parent_Subtype (Equiv_Type, Constr_Root);
+ if not Is_Interface (Root_Typ) then
+ Append_To (Comp_List,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uParent),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Constr_Root, Loc))));
+ end if;
+
+ Append_To (Comp_List,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('C')),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication => New_Reference_To (Str_Type, Loc))));
+
Append_To (List_Def,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Equiv_Type,
-
Type_Definition =>
Make_Record_Definition (Loc,
- Component_List => Make_Component_List (Loc,
- Component_Items => New_List (
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uParent),
- Subtype_Indication => New_Reference_To (Constr_Root, Loc)),
-
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('C')),
- Subtype_Indication => New_Reference_To (Str_Type, Loc))),
- Variant_Part => Empty))));
-
- Insert_Actions (E, List_Def);
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => Comp_List,
+ Variant_Part => Empty))));
+
+ -- Suppress all checks during the analysis of the expanded code
+ -- to avoid the generation of spurious warnings under ZFP run-time.
+
+ Insert_Actions (E, List_Def, Suppress => All_Checks);
return Equiv_Type;
end Make_CW_Equivalent_Type;
function Make_Literal_Range
(Loc : Source_Ptr;
- Literal_Typ : Entity_Id;
- Index_Typ : Entity_Id)
- return Node_Id
+ Literal_Typ : Entity_Id) return Node_Id
is
+ Lo : constant Node_Id :=
+ New_Copy_Tree (String_Literal_Low_Bound (Literal_Typ));
+
begin
+ Set_Analyzed (Lo, False);
+
return
Make_Range (Loc,
- Low_Bound =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Typ, Loc),
- Attribute_Name => Name_First),
+ Low_Bound => Lo,
High_Bound =>
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Index_Typ, Loc),
- Attribute_Name => Name_First),
- Right_Opnd => Make_Integer_Literal (Loc,
- String_Literal_Length (Literal_Typ))),
+ Left_Opnd => New_Copy_Tree (Lo),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ String_Literal_Length (Literal_Typ))),
Right_Opnd => Make_Integer_Literal (Loc, 1)));
end Make_Literal_Range;
function Make_Subtype_From_Expr
(E : Node_Id;
- Unc_Typ : Entity_Id)
- return Node_Id
+ Unc_Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (E);
- List_Constr : List_Id := New_List;
+ List_Constr : constant List_Id := New_List;
D : Entity_Id;
Full_Subtyp : Entity_Id;
if Is_Private_Type (Unc_Typ)
and then Has_Unknown_Discriminants (Unc_Typ)
then
- -- Prepare the subtype completion
+ -- Prepare the subtype completion, Go to base type to
+ -- find underlying type, because the type may be a generic
+ -- actual or an explicit subtype.
- Utyp := Underlying_Type (Unc_Typ);
+ Utyp := Underlying_Type (Base_Type (Unc_Typ));
Full_Subtyp := Make_Defining_Identifier (Loc,
New_Internal_Name ('C'));
- Full_Exp := Unchecked_Convert_To (Utyp, Duplicate_Subexpr (E));
+ Full_Exp :=
+ Unchecked_Convert_To
+ (Utyp, Duplicate_Subexpr_No_Checks (E));
Set_Parent (Full_Exp, Parent (E));
Priv_Subtyp :=
-- Define the dummy private subtype
Set_Ekind (Priv_Subtyp, Subtype_Kind (Ekind (Unc_Typ)));
- Set_Etype (Priv_Subtyp, Unc_Typ);
+ Set_Etype (Priv_Subtyp, Base_Type (Unc_Typ));
Set_Scope (Priv_Subtyp, Full_Subtyp);
Set_Is_Constrained (Priv_Subtyp);
Set_Is_Tagged_Type (Priv_Subtyp, Is_Tagged_Type (Unc_Typ));
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (E),
+ Prefix => Duplicate_Subexpr_No_Checks (E),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J))),
+
High_Bound =>
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (E),
+ Prefix => Duplicate_Subexpr_No_Checks (E),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))));
EQ_Typ : Entity_Id := Empty;
begin
- -- A class-wide equivalent type is not needed when Java_VM
- -- because the JVM back end handles the class-wide object
- -- intialization itself (and doesn't need or want the
+ -- A class-wide equivalent type is not needed when VM_Target
+ -- because the VM back-ends handle the class-wide object
+ -- initialization itself (and doesn't need or want the
-- additional intermediate type to handle the assignment).
- if Expander_Active and then not Java_VM then
+ if Expander_Active and then VM_Target = No_VM then
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;
+ -- Indefinite record type with discriminants
+
else
D := First_Discriminant (Unc_Typ);
- while (Present (D)) loop
-
+ while Present (D) loop
Append_To (List_Constr,
Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (E),
+ Prefix => Duplicate_Subexpr_No_Checks (E),
Selector_Name => New_Reference_To (D, Loc)));
Next_Discriminant (D);
-- At the current time, the only types that we return False for (i.e.
-- where we decide we know they cannot generate large temps) are ones
- -- where we know the size is 128 bits or less at compile time, and we
+ -- where we know the size is 256 bits or less at compile time, and we
-- are still not doing a thorough job on arrays and records ???
function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is
begin
- if not Stack_Checking_Enabled then
- return False;
-
- elsif not Size_Known_At_Compile_Time (Typ) then
+ if not Size_Known_At_Compile_Time (Typ) then
return False;
elsif Esize (Typ) /= 0 and then Esize (Typ) <= 256 then
end if;
end May_Generate_Large_Temp;
- ---------------------
- -- Must_Be_Aligned --
- ---------------------
+ ----------------------------
+ -- New_Class_Wide_Subtype --
+ ----------------------------
- function Must_Be_Aligned (Obj : Node_Id) return Boolean is
- Typ : constant Entity_Id := Etype (Obj);
+ function New_Class_Wide_Subtype
+ (CW_Typ : Entity_Id;
+ N : Node_Id) return Entity_Id
+ is
+ Res : constant Entity_Id := Create_Itype (E_Void, N);
+ Res_Name : constant Name_Id := Chars (Res);
+ Res_Scope : constant Entity_Id := Scope (Res);
begin
- -- If object is strictly aligned, we can quit now
+ Copy_Node (CW_Typ, Res);
+ Set_Comes_From_Source (Res, False);
+ Set_Sloc (Res, Sloc (N));
+ Set_Is_Itype (Res);
+ Set_Associated_Node_For_Itype (Res, N);
+ Set_Is_Public (Res, False); -- By default, may be changed below.
+ Set_Public_Status (Res);
+ Set_Chars (Res, Res_Name);
+ Set_Scope (Res, Res_Scope);
+ Set_Ekind (Res, E_Class_Wide_Subtype);
+ Set_Next_Entity (Res, Empty);
+ Set_Etype (Res, Base_Type (CW_Typ));
- if Strict_Alignment (Typ) then
- return True;
+ -- 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 ???).
- -- Case of subscripted array reference
+ if Frontend_Layout_On_Target then
+ Set_Is_Frozen (Res, False);
+ end if;
- elsif Nkind (Obj) = N_Indexed_Component then
+ Set_Freeze_Node (Res, Empty);
+ return (Res);
+ end New_Class_Wide_Subtype;
- -- If we have a pointer to an array, then this is definitely
- -- aligned, because pointers always point to aligned versions.
+ --------------------------------
+ -- Non_Limited_Designated_Type --
+ ---------------------------------
- if Is_Access_Type (Etype (Prefix (Obj))) then
- return True;
+ function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id is
+ Desig : constant Entity_Id := Designated_Type (T);
+ begin
+ if Ekind (Desig) = E_Incomplete_Type
+ and then Present (Non_Limited_View (Desig))
+ then
+ return Non_Limited_View (Desig);
+ else
+ return Desig;
+ end if;
+ end Non_Limited_Designated_Type;
- -- Otherwise, go look at the prefix
+ -----------------------------------
+ -- OK_To_Do_Constant_Replacement --
+ -----------------------------------
- else
- return Must_Be_Aligned (Prefix (Obj));
- end if;
+ function OK_To_Do_Constant_Replacement (E : Entity_Id) return Boolean is
+ ES : constant Entity_Id := Scope (E);
+ CS : Entity_Id;
- -- Case of record field
+ begin
+ -- Do not replace statically allocated objects, because they may be
+ -- modified outside the current scope.
- elsif Nkind (Obj) = N_Selected_Component then
+ if Is_Statically_Allocated (E) then
+ return False;
- -- What is significant here is whether the record type is packed
+ -- Do not replace aliased or volatile objects, since we don't know what
+ -- else might change the value.
- if Is_Record_Type (Etype (Prefix (Obj)))
- and then Is_Packed (Etype (Prefix (Obj)))
- then
- return False;
+ elsif Is_Aliased (E) or else Treat_As_Volatile (E) then
+ return False;
- -- Or the component has a component clause which might cause
- -- the component to become unaligned (we can't tell if the
- -- backend is doing alignment computations).
+ -- Debug flag -gnatdM disconnects this optimization
- elsif Present (Component_Clause (Entity (Selector_Name (Obj)))) then
- return False;
+ elsif Debug_Flag_MM then
+ return False;
- -- In all other cases, go look at prefix
+ -- Otherwise check scopes
- else
- return Must_Be_Aligned (Prefix (Obj));
- end if;
+ else
+ CS := Current_Scope;
- -- If not selected or indexed component, must be aligned
+ loop
+ -- If we are in right scope, replacement is safe
- else
- return True;
- end if;
- end Must_Be_Aligned;
+ if CS = ES then
+ return True;
- ----------------------------
- -- New_Class_Wide_Subtype --
- ----------------------------
+ -- Packages do not affect the determination of safety
- function New_Class_Wide_Subtype
- (CW_Typ : Entity_Id;
- N : Node_Id)
- return Entity_Id
- is
- Res : Entity_Id := Create_Itype (E_Void, N);
- Res_Name : constant Name_Id := Chars (Res);
- Res_Scope : Entity_Id := Scope (Res);
+ elsif Ekind (CS) = E_Package then
+ exit when CS = Standard_Standard;
+ CS := Scope (CS);
+
+ -- Blocks do not affect the determination of safety
+
+ elsif Ekind (CS) = E_Block then
+ CS := Scope (CS);
+
+ -- Loops do not affect the determination of safety. Note that we
+ -- kill all current values on entry to a loop, so we are just
+ -- talking about processing within a loop here.
+
+ elsif Ekind (CS) = E_Loop then
+ CS := Scope (CS);
+
+ -- Otherwise, the reference is dubious, and we cannot be sure that
+ -- it is safe to do the replacement.
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return False;
+ end if;
+ end OK_To_Do_Constant_Replacement;
+
+ ------------------------------------
+ -- Possible_Bit_Aligned_Component --
+ ------------------------------------
+ function Possible_Bit_Aligned_Component (N : Node_Id) return Boolean is
begin
- Copy_Node (CW_Typ, Res);
- Set_Sloc (Res, Sloc (N));
- Set_Is_Itype (Res);
- Set_Associated_Node_For_Itype (Res, N);
- Set_Is_Public (Res, False); -- By default, may be changed below.
- Set_Public_Status (Res);
- Set_Chars (Res, Res_Name);
- Set_Scope (Res, Res_Scope);
- Set_Ekind (Res, E_Class_Wide_Subtype);
- Set_Next_Entity (Res, Empty);
- Set_Etype (Res, Base_Type (CW_Typ));
- Set_Freeze_Node (Res, Empty);
- return (Res);
- end New_Class_Wide_Subtype;
+ case Nkind (N) is
+
+ -- Case of indexed component
+
+ when N_Indexed_Component =>
+ declare
+ P : constant Node_Id := Prefix (N);
+ Ptyp : constant Entity_Id := Etype (P);
+
+ begin
+ -- If we know the component size and it is less than 64, then
+ -- we are definitely OK. The back end always does assignment
+ -- of misaligned small objects correctly.
+
+ if Known_Static_Component_Size (Ptyp)
+ and then Component_Size (Ptyp) <= 64
+ then
+ return False;
+
+ -- Otherwise, we need to test the prefix, to see if we are
+ -- indexing from a possibly unaligned component.
+
+ else
+ return Possible_Bit_Aligned_Component (P);
+ end if;
+ end;
+
+ -- Case of selected component
+
+ when N_Selected_Component =>
+ declare
+ P : constant Node_Id := Prefix (N);
+ Comp : constant Entity_Id := Entity (Selector_Name (N));
+
+ begin
+ -- If there is no component clause, then we are in the clear
+ -- since the back end will never misalign a large component
+ -- unless it is forced to do so. In the clear means we need
+ -- only the recursive test on the prefix.
+
+ if Component_May_Be_Bit_Aligned (Comp) then
+ return True;
+ else
+ return Possible_Bit_Aligned_Component (P);
+ end if;
+ end;
+
+ -- If we have neither a record nor array component, it means that we
+ -- have fallen off the top testing prefixes recursively, and we now
+ -- have a stand alone object, where we don't have a problem.
+
+ when others =>
+ return False;
+
+ end case;
+ end Possible_Bit_Aligned_Component;
-------------------------
-- Remove_Side_Effects --
Name_Req : Boolean := False;
Variable_Ref : Boolean := False)
is
- Loc : constant Source_Ptr := Sloc (Exp);
- Exp_Type : constant Entity_Id := Etype (Exp);
- Svg_Suppress : constant Suppress_Record := Scope_Suppress;
+ Loc : constant Source_Ptr := Sloc (Exp);
+ Exp_Type : constant Entity_Id := Etype (Exp);
+ Svg_Suppress : constant Suppress_Array := Scope_Suppress;
Def_Id : Entity_Id;
Ref_Type : Entity_Id;
Res : Node_Id;
E : Node_Id;
function Side_Effect_Free (N : Node_Id) return Boolean;
- -- Determines if the tree N represents an expession that is known
- -- not to have side effects, and for which no processing is required.
+ -- Determines if the tree N represents an expression that is known not
+ -- to have side effects, and for which no processing is required.
function Side_Effect_Free (L : List_Id) return Boolean;
-- Determines if all elements of the list L are side effect free
- function Mutable_Dereference (N : Node_Id) return Boolean;
- -- If a selected component involves an implicit dereference and
- -- the type of the prefix is not an_access_to_constant, the node
- -- must be evaluated because it may be affected by a subsequent
- -- assignment.
+ function Safe_Prefixed_Reference (N : Node_Id) return Boolean;
+ -- The argument N is a construct where the Prefix is dereferenced if it
+ -- is an access type and the result is a variable. The call returns True
+ -- if the construct is side effect free (not considering side effects in
+ -- other than the prefix which are to be tested by the caller).
+
+ function Within_In_Parameter (N : Node_Id) return Boolean;
+ -- Determines if N is a subcomponent of a composite in-parameter. If so,
+ -- N is not side-effect free when the actual is global and modifiable
+ -- indirectly from within a subprogram, because it may be passed by
+ -- reference. The front-end must be conservative here and assume that
+ -- this may happen with any array or record type. On the other hand, we
+ -- cannot create temporaries for all expressions for which this
+ -- condition is true, for various reasons that might require clearing up
+ -- ??? For example, descriminant references that appear out of place, or
+ -- spurious type errors with class-wide expressions. As a result, we
+ -- limit the transformation to loop bounds, which is so far the only
+ -- case that requires it.
+
+ -----------------------------
+ -- Safe_Prefixed_Reference --
+ -----------------------------
+
+ function Safe_Prefixed_Reference (N : Node_Id) return Boolean is
+ begin
+ -- If prefix is not side effect free, definitely not safe
- -------------------------
- -- Mutable_Dereference --
- -------------------------
+ if not Side_Effect_Free (Prefix (N)) then
+ return False;
- function Mutable_Dereference (N : Node_Id) return Boolean is
- begin
- return Nkind (N) = N_Selected_Component
- and then Is_Access_Type (Etype (Prefix (N)))
+ -- If the prefix is of an access type that is not access-to-constant,
+ -- then this construct is a variable reference, which means it is to
+ -- be considered to have side effects if Variable_Ref is set True
+ -- Exception is an access to an entity that is a constant or an
+ -- in-parameter which does not come from source, and is the result
+ -- of a previous removal of side-effects.
+
+ elsif Is_Access_Type (Etype (Prefix (N)))
and then not Is_Access_Constant (Etype (Prefix (N)))
- and then Variable_Ref;
- end Mutable_Dereference;
+ and then Variable_Ref
+ then
+ if not Is_Entity_Name (Prefix (N)) then
+ return False;
+ else
+ return Ekind (Entity (Prefix (N))) = E_Constant
+ or else Ekind (Entity (Prefix (N))) = E_In_Parameter;
+ end if;
+
+ -- 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:
+ -- If a loop bound is a subcomponent of a global variable, a
+ -- modification of that variable within the loop may incorrectly
+ -- affect the execution of the loop.
+
+ elsif not
+ (Nkind (Parent (Parent (N))) /= N_Loop_Parameter_Specification
+ or else not Within_In_Parameter (Prefix (N)))
+ then
+ return False;
+
+ -- All other cases are side effect free
+
+ else
+ return True;
+ end if;
+ end Safe_Prefixed_Reference;
----------------------
-- Side_Effect_Free --
----------------------
function Side_Effect_Free (N : Node_Id) return Boolean is
- K : constant Node_Kind := Nkind (N);
-
begin
-- Note on checks that could raise Constraint_Error. Strictly, if
-- we take advantage of 11.6, these checks do not count as side
-- code insertions at a point where we do not have a clear model
-- for performing the insertions. See 4908-002/comment for details.
- -- An attribute reference is side effect free if its expressions
- -- are side effect free and its prefix is (could be a dereference
- -- or an indexed retrieval for example).
-
- if K = N_Attribute_Reference then
- return Side_Effect_Free (Expressions (N))
- and then (Is_Entity_Name (Prefix (N))
- or else Side_Effect_Free (Prefix (N)));
+ -- Special handling for entity names
- -- An entity is side effect free unless it is a function call, or
- -- a reference to a volatile variable and Name_Req is False. If
- -- Name_Req is True then we can't help returning a name which
- -- effectively allows multiple references in any case.
+ if Is_Entity_Name (N) then
- elsif Is_Entity_Name (N)
- and then Ekind (Entity (N)) /= E_Function
- and then (not Is_Volatile (Entity (N)) or else Name_Req)
- then
-- If the entity is a constant, it is definitely side effect
-- free. Note that the test of Is_Variable (N) below might
-- be expected to catch this case, but it does not, because
-- already rewritten a variable node with a constant as
-- a result of an earlier Force_Evaluation call.
- if Ekind (Entity (N)) = E_Constant then
+ if Ekind (Entity (N)) = E_Constant
+ or else Ekind (Entity (N)) = E_In_Parameter
+ then
return True;
- -- If the Variable_Ref flag is set, any variable reference is
- -- is considered a side-effect
+ -- Functions are not side effect free
- elsif Variable_Ref then
- return not Is_Variable (N);
+ elsif Ekind (Entity (N)) = E_Function then
+ return False;
+
+ -- Variables are considered to be a side effect if Variable_Ref
+ -- is set or if we have a volatile variable and Name_Req is off.
+ -- If Name_Req is True then we can't help returning a name which
+ -- effectively allows multiple references in any case.
+
+ elsif Is_Variable (N) then
+ return not Variable_Ref
+ and then (not Treat_As_Volatile (Entity (N))
+ or else Name_Req);
+
+ -- Any other entity (e.g. a subtype name) is definitely side
+ -- effect free.
else
return True;
elsif Compile_Time_Known_Value (N) then
return True;
- -- Literals are always side-effect free
+ -- A variable renaming is not side-effet free, because the
+ -- renaming will function like a macro in the front-end in
+ -- some cases, and an assignment can modify the the component
+ -- designated by N, so we need to create a temporary for it.
- elsif (K = N_Integer_Literal
- or else K = N_Real_Literal
- or else K = N_Character_Literal
- or else K = N_String_Literal
- or else K = N_Null)
- and then not Raises_Constraint_Error (N)
+ elsif Is_Entity_Name (Original_Node (N))
+ and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
+ and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
- return True;
+ return False;
+ end if;
+
+ -- For other than entity names and compile time known values,
+ -- check the node kind for special processing.
+
+ case Nkind (N) is
+
+ -- An attribute reference is side effect free if its expressions
+ -- are side effect free and its prefix is side effect free or
+ -- is an entity reference.
+
+ -- Is this right? what about x'first where x is a variable???
+
+ when N_Attribute_Reference =>
+ return Side_Effect_Free (Expressions (N))
+ and then Attribute_Name (N) /= Name_Input
+ and then (Is_Entity_Name (Prefix (N))
+ or else Side_Effect_Free (Prefix (N)));
+
+ -- A binary operator is side effect free if and both operands
+ -- are side effect free. For this purpose binary operators
+ -- include membership tests and short circuit forms
+
+ when N_Binary_Op |
+ N_Membership_Test |
+ N_And_Then |
+ N_Or_Else =>
+ return Side_Effect_Free (Left_Opnd (N))
+ and then Side_Effect_Free (Right_Opnd (N));
+
+ -- An explicit dereference is side effect free only if it is
+ -- a side effect free prefixed reference.
+
+ when N_Explicit_Dereference =>
+ return Safe_Prefixed_Reference (N);
- -- A type conversion or qualification is side effect free if the
- -- expression to be converted is side effect free.
+ -- A call to _rep_to_pos is side effect free, since we generate
+ -- this pure function call ourselves. Moreover it is critically
+ -- important to make this exception, since otherwise we can
+ -- have discriminants in array components which don't look
+ -- side effect free in the case of an array whose index type
+ -- is an enumeration type with an enumeration rep clause.
- elsif K = N_Type_Conversion or else K = N_Qualified_Expression then
- return Side_Effect_Free (Expression (N));
+ -- All other function calls are not side effect free
- -- An unchecked type conversion is never side effect free since we
- -- need to check whether it is safe.
- -- effect free if its argument is side effect free.
+ when N_Function_Call =>
+ return Nkind (Name (N)) = N_Identifier
+ and then Is_TSS (Name (N), TSS_Rep_To_Pos)
+ and then
+ Side_Effect_Free (First (Parameter_Associations (N)));
+
+ -- An indexed component is side effect free if it is a side
+ -- effect free prefixed reference and all the indexing
+ -- expressions are side effect free.
+
+ when N_Indexed_Component =>
+ return Side_Effect_Free (Expressions (N))
+ and then Safe_Prefixed_Reference (N);
+
+ -- A type qualification is side effect free if the expression
+ -- is side effect free.
- elsif K = N_Unchecked_Type_Conversion then
- if Safe_Unchecked_Type_Conversion (N) then
+ when N_Qualified_Expression =>
+ return Side_Effect_Free (Expression (N));
+
+ -- A selected component is side effect free only if it is a
+ -- side effect free prefixed reference.
+
+ when N_Selected_Component =>
+ return Safe_Prefixed_Reference (N);
+
+ -- A range is side effect free if the bounds are side effect free
+
+ when N_Range =>
+ return Side_Effect_Free (Low_Bound (N))
+ and then Side_Effect_Free (High_Bound (N));
+
+ -- A slice is side effect free if it is a side effect free
+ -- prefixed reference and the bounds are side effect free.
+
+ when N_Slice =>
+ return Side_Effect_Free (Discrete_Range (N))
+ and then Safe_Prefixed_Reference (N);
+
+ -- A type conversion is side effect free if the expression
+ -- to be converted is side effect free.
+
+ when N_Type_Conversion =>
return Side_Effect_Free (Expression (N));
- else
- return False;
- end if;
- -- A unary operator is side effect free if the operand
- -- is side effect free.
+ -- A unary operator is side effect free if the operand
+ -- is side effect free.
- elsif K in N_Unary_Op then
- return Side_Effect_Free (Right_Opnd (N));
+ when N_Unary_Op =>
+ return Side_Effect_Free (Right_Opnd (N));
- -- A binary operator is side effect free if and both operands
- -- are side effect free.
+ -- An unchecked type conversion is side effect free only if it
+ -- is safe and its argument is side effect free.
- elsif K in N_Binary_Op then
- return Side_Effect_Free (Left_Opnd (N))
- and then Side_Effect_Free (Right_Opnd (N));
+ when N_Unchecked_Type_Conversion =>
+ return Safe_Unchecked_Type_Conversion (N)
+ and then Side_Effect_Free (Expression (N));
- -- An explicit dereference or selected component is side effect
- -- free if its prefix is side effect free.
+ -- An unchecked expression is side effect free if its expression
+ -- is side effect free.
- elsif K = N_Explicit_Dereference
- or else K = N_Selected_Component
- then
- return Side_Effect_Free (Prefix (N))
- and then not Mutable_Dereference (Prefix (N));
-
- -- An indexed component can be copied if the prefix is copyable
- -- and all the indexing expressions are copyable and there is
- -- no access check and no range checks.
-
- elsif K = N_Indexed_Component then
- return Side_Effect_Free (Prefix (N))
- and then Side_Effect_Free (Expressions (N));
-
- elsif K = N_Unchecked_Expression then
- return Side_Effect_Free (Expression (N));
-
- -- A call to _rep_to_pos is side effect free, since we generate
- -- this pure function call ourselves. Moreover it is critically
- -- important to make this exception, since otherwise we can
- -- have discriminants in array components which don't look
- -- side effect free in the case of an array whose index type
- -- is an enumeration type with an enumeration rep clause.
-
- elsif K = N_Function_Call
- and then Nkind (Name (N)) = N_Identifier
- and then Chars (Name (N)) = Name_uRep_To_Pos
- then
- return True;
+ when N_Unchecked_Expression =>
+ return Side_Effect_Free (Expression (N));
- -- We consider that anything else has side effects. This is a bit
- -- crude, but we are pretty close for most common cases, and we
- -- are certainly correct (i.e. we never return True when the
- -- answer should be False).
+ -- A literal is side effect free
- else
- return False;
- end if;
+ when N_Character_Literal |
+ N_Integer_Literal |
+ N_Real_Literal |
+ N_String_Literal =>
+ return True;
+
+ -- We consider that anything else has side effects. This is a bit
+ -- crude, but we are pretty close for most common cases, and we
+ -- are certainly correct (i.e. we never return True when the
+ -- answer should be False).
+
+ when others =>
+ return False;
+ end case;
end Side_Effect_Free;
+ -- A list is side effect free if all elements of the list are
+ -- side effect free.
+
function Side_Effect_Free (L : List_Id) return Boolean is
N : Node_Id;
else
N := First (L);
-
while Present (N) loop
if not Side_Effect_Free (N) then
return False;
end if;
end Side_Effect_Free;
+ -------------------------
+ -- Within_In_Parameter --
+ -------------------------
+
+ function Within_In_Parameter (N : Node_Id) return Boolean is
+ begin
+ if not Comes_From_Source (N) then
+ return False;
+
+ elsif Is_Entity_Name (N) then
+ return
+ Ekind (Entity (N)) = E_In_Parameter;
+
+ elsif Nkind (N) = N_Indexed_Component
+ or else Nkind (N) = N_Selected_Component
+ then
+ return Within_In_Parameter (Prefix (N));
+ else
+
+ return False;
+ end if;
+ end Within_In_Parameter;
+
-- Start of processing for Remove_Side_Effects
begin
return;
end if;
- -- All the must not have any checks
+ -- All this must not have any checks
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. And if we have a
+ -- volatile variable and Nam_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 (not Name_Req
+ and then Is_Entity_Name (Exp)
+ and then Treat_As_Volatile (Entity (Exp))))
+ then
+
+ Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Set_Etype (Def_Id, Exp_Type);
+ Res := New_Reference_To (Def_Id, Loc);
+
+ E :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Reference_To (Exp_Type, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Exp));
+
+ Set_Assignment_OK (E);
+ Insert_Action (Exp, E);
+
-- If the expression has the form v.all then we can just capture
-- the pointer, and then do an explicit dereference on the result.
- if Nkind (Exp) = N_Explicit_Dereference then
+ elsif Nkind (Exp) = N_Explicit_Dereference then
Def_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Res :=
Constant_Present => True,
Expression => Relocate_Node (Prefix (Exp))));
+ -- Similar processing for an unchecked conversion of an expression
+ -- of the form v.all, where we want the same kind of treatment.
+
+ elsif Nkind (Exp) = N_Unchecked_Type_Conversion
+ and then Nkind (Expression (Exp)) = N_Explicit_Dereference
+ then
+ Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
+ Scope_Suppress := Svg_Suppress;
+ return;
+
-- If this is a type conversion, leave the type conversion and remove
-- the side effects in the expression. This is important in several
-- circumstances: for change of representations, and also when this
-- is a view conversion to a smaller object, where gigi can end up
- -- its own temporary of the wrong size.
- -- ??? this transformation is inhibited for elementary types that are
- -- not involved in a change of representation because it causes
- -- regressions that are not fully understood yet.
-
- elsif Nkind (Exp) = N_Type_Conversion
- and then (not Is_Elementary_Type (Underlying_Type (Exp_Type))
- or else Nkind (Parent (Exp)) = N_Assignment_Statement)
- then
- Remove_Side_Effects (Expression (Exp), Variable_Ref);
+ -- creating its own temporary of the wrong size.
+
+ elsif Nkind (Exp) = N_Type_Conversion then
+ Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
Scope_Suppress := Svg_Suppress;
return;
+ -- If this is an unchecked conversion that Gigi can't handle, make
+ -- a copy or a use a renaming to capture the value.
+
+ elsif Nkind (Exp) = N_Unchecked_Type_Conversion
+ and then not Safe_Unchecked_Type_Conversion (Exp)
+ then
+ if CW_Or_Controlled_Type (Exp_Type) then
+
+ -- Use a renaming to capture the expression, rather than create
+ -- a controlled temporary.
+
+ Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Res := New_Reference_To (Def_Id, Loc);
+
+ Insert_Action (Exp,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Subtype_Mark => New_Reference_To (Exp_Type, Loc),
+ Name => Relocate_Node (Exp)));
+
+ else
+ Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Set_Etype (Def_Id, Exp_Type);
+ Res := New_Reference_To (Def_Id, Loc);
+
+ E :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Reference_To (Exp_Type, Loc),
+ Constant_Present => not Is_Variable (Exp),
+ Expression => Relocate_Node (Exp));
+
+ Set_Assignment_OK (E);
+ Insert_Action (Exp, E);
+ end if;
+
-- For expressions that denote objects, we can use a renaming scheme.
-- We skip using this if we have a volatile variable and we do not
-- have Nam_Req set true (see comments above for Side_Effect_Free).
- -- We also skip this scheme for class-wide expressions in order to
- -- avoid recursive expension (see Expand_N_Object_Renaming_Declaration)
- -- If the object is a function call, we need to create a temporary and
- -- not a renaming.
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
- and then not Variable_Ref
and then (Name_Req
or else not Is_Entity_Name (Exp)
- or else not Is_Volatile (Entity (Exp)))
- and then not Is_Class_Wide_Type (Exp_Type)
+ or else not Treat_As_Volatile (Entity (Exp)))
then
Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
if Nkind (Exp) = N_Selected_Component
and then Nkind (Prefix (Exp)) = N_Function_Call
- and then Is_Array_Type (Etype (Exp))
+ and then Is_Array_Type (Exp_Type)
then
-- Avoid generating a variable-sized temporary, by generating
-- the renaming declaration just for the function call. The
Subtype_Mark =>
New_Reference_To (Base_Type (Etype (Prefix (Exp))), Loc),
Name => Relocate_Node (Prefix (Exp))));
+
else
Res := New_Reference_To (Def_Id, Loc);
Defining_Identifier => Def_Id,
Subtype_Mark => New_Reference_To (Exp_Type, Loc),
Name => Relocate_Node (Exp)));
- end if;
-
- -- If it is a scalar type, just make a copy.
-
- elsif Is_Elementary_Type (Exp_Type) then
- Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- Set_Etype (Def_Id, Exp_Type);
- Res := New_Reference_To (Def_Id, Loc);
-
- E :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Object_Definition => New_Reference_To (Exp_Type, Loc),
- Constant_Present => True,
- Expression => Relocate_Node (Exp));
-
- Set_Assignment_OK (E);
- Insert_Action (Exp, E);
-
- -- If this is an unchecked conversion that Gigi can't handle, make
- -- a copy or a use a renaming to capture the value.
- elsif (Nkind (Exp) = N_Unchecked_Type_Conversion
- and then not Safe_Unchecked_Type_Conversion (Exp))
- then
- if Controlled_Type (Etype (Exp)) then
- -- Use a renaming to capture the expression, rather than create
- -- a controlled temporary.
-
- Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- Res := New_Reference_To (Def_Id, Loc);
-
- Insert_Action (Exp,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Subtype_Mark => New_Reference_To (Exp_Type, Loc),
- Name => Relocate_Node (Exp)));
+ end if;
+ -- If this is a packed reference, or a selected component with a
+ -- non-standard representation, a reference to the temporary will
+ -- be replaced by a copy of the original expression (see
+ -- exp_ch2.Expand_Renaming). Otherwise the temporary must be
+ -- elaborated by gigi, and is of course not to be replaced in-line
+ -- by the expression it renames, which would defeat the purpose of
+ -- removing the side-effect.
+
+ if (Nkind (Exp) = N_Selected_Component
+ or else Nkind (Exp) = N_Indexed_Component)
+ and then Has_Non_Standard_Rep (Etype (Prefix (Exp)))
+ then
+ null;
else
- Def_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- Set_Etype (Def_Id, Exp_Type);
- Res := New_Reference_To (Def_Id, Loc);
-
- E :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Object_Definition => New_Reference_To (Exp_Type, Loc),
- Constant_Present => True,
- Expression => Relocate_Node (Exp));
-
- Set_Assignment_OK (E);
- Insert_Action (Exp, E);
+ Set_Is_Renaming_Of_Object (Def_Id, False);
end if;
-- Otherwise we generate a reference to the value
New_Exp := Make_Reference (Loc, E);
end if;
- if Nkind (E) = N_Aggregate and then Expansion_Delayed (E) then
- Set_Expansion_Delayed (E, False);
+ if Is_Delayed_Aggregate (E) then
+
+ -- The expansion of nested aggregates is delayed until the
+ -- enclosing aggregate is expanded. As aggregates are often
+ -- qualified, the predicate applies to qualified expressions
+ -- as well, indicating that the enclosing aggregate has not
+ -- been expanded yet. At this point the aggregate is part of
+ -- a stand-alone declaration, and must be fully expanded.
+
+ if Nkind (E) = N_Qualified_Expression then
+ Set_Expansion_Delayed (Expression (E), False);
+ Set_Analyzed (Expression (E), False);
+ else
+ Set_Expansion_Delayed (E, False);
+ end if;
+
Set_Analyzed (E, False);
end if;
Scope_Suppress := Svg_Suppress;
end Remove_Side_Effects;
+ ---------------------------
+ -- Represented_As_Scalar --
+ ---------------------------
+
+ function Represented_As_Scalar (T : Entity_Id) return Boolean is
+ UT : constant Entity_Id := Underlying_Type (T);
+ begin
+ return Is_Scalar_Type (UT)
+ or else (Is_Bit_Packed_Array (UT)
+ and then Is_Scalar_Type (Packed_Array_Type (UT)));
+ end Represented_As_Scalar;
+
------------------------------------
-- Safe_Unchecked_Type_Conversion --
------------------------------------
if Implementation_Base_Type (Otyp) = Implementation_Base_Type (Ityp) then
return True;
+ -- Same if this is an upwards conversion of an untagged type, and there
+ -- are no constraints involved (could be more general???)
+
+ elsif Etype (Ityp) = Otyp
+ and then not Is_Tagged_Type (Ityp)
+ and then not Has_Discriminants (Ityp)
+ and then No (First_Rep_Item (Base_Type (Ityp)))
+ then
+ return True;
+
-- If the size of output type is known at compile time, there is
-- never a problem. Note that unconstrained records are considered
-- to be of known size, but we can't consider them that way here,
-- in stack checking mode.
elsif Size_Known_At_Compile_Time (Otyp)
- and then not May_Generate_Large_Temp (Otyp)
+ and then
+ (not Stack_Checking_Enabled
+ or else not May_Generate_Large_Temp (Otyp))
and then not (Is_Record_Type (Otyp) and then not Is_Constrained (Otyp))
then
return True;
then
return True;
- -- Otherwise, Gigi cannot handle this and we must make a temporary.
+ -- Otherwise, Gigi cannot handle this and we must make a temporary
else
return False;
end if;
-
end Safe_Unchecked_Type_Conversion;
+ ---------------------------------
+ -- Set_Current_Value_Condition --
+ ---------------------------------
+
+ -- Note: the implementation of this procedure is very closely tied to the
+ -- implementation of Get_Current_Value_Condition. Here we set required
+ -- Current_Value fields, and in Get_Current_Value_Condition, we interpret
+ -- them, so they must have a consistent view.
+
+ procedure Set_Current_Value_Condition (Cnode : Node_Id) is
+
+ procedure Set_Entity_Current_Value (N : Node_Id);
+ -- If N is an entity reference, where the entity is of an appropriate
+ -- kind, then set the current value of this entity to Cnode, unless
+ -- there is already a definite value set there.
+
+ procedure Set_Expression_Current_Value (N : Node_Id);
+ -- If N is of an appropriate form, sets an appropriate entry in current
+ -- value fields of relevant entities. Multiple entities can be affected
+ -- in the case of an AND or AND THEN.
+
+ ------------------------------
+ -- Set_Entity_Current_Value --
+ ------------------------------
+
+ procedure Set_Entity_Current_Value (N : Node_Id) is
+ begin
+ if Is_Entity_Name (N) then
+ declare
+ Ent : constant Entity_Id := Entity (N);
+
+ begin
+ -- Don't capture if not safe to do so
+
+ if not Safe_To_Capture_Value (N, Ent, Cond => True) then
+ return;
+ end if;
+
+ -- Here we have a case where the Current_Value field may
+ -- need to be set. We set it if it is not already set to a
+ -- compile time expression value.
+
+ -- Note that this represents a decision that one condition
+ -- blots out another previous one. That's certainly right
+ -- if they occur at the same level. If the second one is
+ -- nested, then the decision is neither right nor wrong (it
+ -- would be equally OK to leave the outer one in place, or
+ -- take the new inner one. Really we should record both, but
+ -- our data structures are not that elaborate.
+
+ if Nkind (Current_Value (Ent)) not in N_Subexpr then
+ Set_Current_Value (Ent, Cnode);
+ end if;
+ end;
+ end if;
+ end Set_Entity_Current_Value;
+
+ ----------------------------------
+ -- Set_Expression_Current_Value --
+ ----------------------------------
+
+ procedure Set_Expression_Current_Value (N : Node_Id) is
+ Cond : Node_Id;
+
+ begin
+ Cond := N;
+
+ -- Loop to deal with (ignore for now) any NOT operators present. The
+ -- presence of NOT operators will be handled properly when we call
+ -- Get_Current_Value_Condition.
+
+ while Nkind (Cond) = N_Op_Not loop
+ Cond := Right_Opnd (Cond);
+ end loop;
+
+ -- For an AND or AND THEN, recursively process operands
+
+ if Nkind (Cond) = N_Op_And or else Nkind (Cond) = N_And_Then then
+ Set_Expression_Current_Value (Left_Opnd (Cond));
+ Set_Expression_Current_Value (Right_Opnd (Cond));
+ return;
+ end if;
+
+ -- Check possible relational operator
+
+ if Nkind (Cond) in N_Op_Compare then
+ if Compile_Time_Known_Value (Right_Opnd (Cond)) then
+ Set_Entity_Current_Value (Left_Opnd (Cond));
+ elsif Compile_Time_Known_Value (Left_Opnd (Cond)) then
+ Set_Entity_Current_Value (Right_Opnd (Cond));
+ end if;
+
+ -- Check possible boolean variable reference
+
+ else
+ Set_Entity_Current_Value (Cond);
+ end if;
+ end Set_Expression_Current_Value;
+
+ -- Start of processing for Set_Current_Value_Condition
+
+ begin
+ Set_Expression_Current_Value (Condition (Cnode));
+ end Set_Current_Value_Condition;
+
--------------------------
-- Set_Elaboration_Flag --
--------------------------
procedure Set_Elaboration_Flag (N : Node_Id; Spec_Id : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Ent : constant Entity_Id := Elaboration_Entity (Spec_Id);
Asn : Node_Id;
begin
- if Present (Elaboration_Entity (Spec_Id)) then
+ if Present (Ent) then
-- Nothing to do if at the compilation unit level, because in this
-- case the flag is set by the binder generated elaboration routine.
Check_Restriction (No_Elaboration_Code, N);
Asn :=
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Elaboration_Entity (Spec_Id), Loc),
+ Name => New_Occurrence_Of (Ent, Loc),
Expression => New_Occurrence_Of (Standard_True, Loc));
if Nkind (Parent (N)) = N_Subunit then
end if;
Analyze (Asn);
+
+ -- Kill current value indication. This is necessary because
+ -- the tests of this flag are inserted out of sequence and must
+ -- not pick up bogus indications of the wrong constant value.
+
+ Set_Current_Value (Ent, Empty);
end if;
end if;
end Set_Elaboration_Flag;
----------------------------
+ -- Set_Renamed_Subprogram --
+ ----------------------------
+
+ procedure Set_Renamed_Subprogram (N : Node_Id; E : Entity_Id) is
+ begin
+ -- If input node is an identifier, we can just reset it
+
+ if Nkind (N) = N_Identifier then
+ Set_Chars (N, Chars (E));
+ Set_Entity (N, E);
+
+ -- Otherwise we have to do a rewrite, preserving Comes_From_Source
+
+ else
+ declare
+ CS : constant Boolean := Comes_From_Source (N);
+ begin
+ Rewrite (N, Make_Identifier (Sloc (N), Chars => Chars (E)));
+ Set_Entity (N, E);
+ Set_Comes_From_Source (N, CS);
+ Set_Analyzed (N, True);
+ end;
+ end if;
+ end Set_Renamed_Subprogram;
+
+ --------------------------
+ -- Target_Has_Fixed_Ops --
+ --------------------------
+
+ Integer_Sized_Small : Ureal;
+ -- Set to 2.0 ** -(Integer'Size - 1) the first time that this
+ -- function is called (we don't want to compute it more than once!)
+
+ Long_Integer_Sized_Small : Ureal;
+ -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this
+ -- functoin is called (we don't want to compute it more than once)
+
+ First_Time_For_THFO : Boolean := True;
+ -- Set to False after first call (if Fractional_Fixed_Ops_On_Target)
+
+ function Target_Has_Fixed_Ops
+ (Left_Typ : Entity_Id;
+ Right_Typ : Entity_Id;
+ Result_Typ : Entity_Id) return Boolean
+ is
+ function Is_Fractional_Type (Typ : Entity_Id) return Boolean;
+ -- Return True if the given type is a fixed-point type with a small
+ -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have
+ -- an absolute value less than 1.0. This is currently limited
+ -- to fixed-point types that map to Integer or Long_Integer.
+
+ ------------------------
+ -- Is_Fractional_Type --
+ ------------------------
+
+ function Is_Fractional_Type (Typ : Entity_Id) return Boolean is
+ begin
+ if Esize (Typ) = Standard_Integer_Size then
+ return Small_Value (Typ) = Integer_Sized_Small;
+
+ elsif Esize (Typ) = Standard_Long_Integer_Size then
+ return Small_Value (Typ) = Long_Integer_Sized_Small;
+
+ else
+ return False;
+ end if;
+ end Is_Fractional_Type;
+
+ -- Start of processing for Target_Has_Fixed_Ops
+
+ begin
+ -- Return False if Fractional_Fixed_Ops_On_Target is false
+
+ if not Fractional_Fixed_Ops_On_Target then
+ return False;
+ end if;
+
+ -- Here the target has Fractional_Fixed_Ops, if first time, compute
+ -- standard constants used by Is_Fractional_Type.
+
+ if First_Time_For_THFO then
+ First_Time_For_THFO := False;
+
+ Integer_Sized_Small :=
+ UR_From_Components
+ (Num => Uint_1,
+ Den => UI_From_Int (Standard_Integer_Size - 1),
+ Rbase => 2);
+
+ Long_Integer_Sized_Small :=
+ UR_From_Components
+ (Num => Uint_1,
+ Den => UI_From_Int (Standard_Long_Integer_Size - 1),
+ Rbase => 2);
+ end if;
+
+ -- Return True if target supports fixed-by-fixed multiply/divide
+ -- for fractional fixed-point types (see Is_Fractional_Type) and
+ -- the operand and result types are equivalent fractional types.
+
+ return Is_Fractional_Type (Base_Type (Left_Typ))
+ and then Is_Fractional_Type (Base_Type (Right_Typ))
+ and then Is_Fractional_Type (Base_Type (Result_Typ))
+ and then Esize (Left_Typ) = Esize (Right_Typ)
+ and then Esize (Left_Typ) = Esize (Result_Typ);
+ end Target_Has_Fixed_Ops;
+
+ ------------------------------------------
+ -- Type_May_Have_Bit_Aligned_Components --
+ ------------------------------------------
+
+ function Type_May_Have_Bit_Aligned_Components
+ (Typ : Entity_Id) return Boolean
+ is
+ begin
+ -- Array type, check component type
+
+ if Is_Array_Type (Typ) then
+ return
+ Type_May_Have_Bit_Aligned_Components (Component_Type (Typ));
+
+ -- Record type, check components
+
+ elsif Is_Record_Type (Typ) then
+ declare
+ E : Entity_Id;
+
+ begin
+ E := First_Component_Or_Discriminant (Typ);
+ while Present (E) loop
+ if Component_May_Be_Bit_Aligned (E)
+ or else Type_May_Have_Bit_Aligned_Components (Etype (E))
+ then
+ return True;
+ end if;
+
+ Next_Component_Or_Discriminant (E);
+ end loop;
+
+ return False;
+ end;
+
+ -- Type other than array or record is always OK
+
+ else
+ return False;
+ end if;
+ end Type_May_Have_Bit_Aligned_Components;
+
+ ----------------------------
-- Wrap_Cleanup_Procedure --
----------------------------
OSDN Git Service
