-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
------------------------------------------------------------------------------
with Atree; use Atree;
+with Casing; use Casing;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-with Uintp; use Uintp;
with Urealp; use Urealp;
with Validsw; use Validsw;
Id_Ref : Node_Id;
A_Type : Entity_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.
- -- The flag Dyn indicates whether this is called for the initialization
- -- procedure of an array of tasks, or for the name of a dynamically
- -- created task that is assigned to an indexed component.
+ -- 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. The flag
+ -- Dyn indicates whether this is called for the initialization procedure of
+ -- an array of tasks, or for the name of a dynamically created task that is
+ -- assigned to an indexed component.
function Build_Task_Image_Function
(Loc : Source_Ptr;
Decls : List_Id;
Stats : List_Id;
Res : Entity_Id) return Node_Id;
- -- Common processing for Task_Array_Image and Task_Record_Image.
- -- Build function body that computes image.
+ -- Common processing for Task_Array_Image and Task_Record_Image. Build
+ -- function body that computes image.
procedure Build_Task_Image_Prefix
(Loc : Source_Ptr;
Sum : Node_Id;
Decls : List_Id;
Stats : List_Id);
- -- Common processing for Task_Array_Image and Task_Record_Image.
- -- Create local variables and assign prefix of name to result string.
+ -- Common processing for Task_Array_Image and Task_Record_Image. Create
+ -- local variables and assign prefix of name to result string.
function Build_Task_Record_Image
(Loc : Source_Ptr;
Id_Ref : 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
- -- procedure of record with task components, or for a dynamically
- -- created task that is assigned to a selected component.
+ -- 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 procedure of
+ -- record with task components, or for a dynamically created task that is
+ -- assigned to a selected component.
function Make_CW_Equivalent_Type
(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:
+ -- 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);
-- end record;
--
- -- This record is compatible with any object of the class of T thanks
- -- to the first field and has the same size as E thanks to the second.
+ -- This record is compatible with any object of the class of T thanks to
+ -- the first field and has the same size as E thanks to the second.
function Make_Literal_Range
(Loc : Source_Ptr;
N : Node_Id) return Entity_Id;
-- Create an implicit subtype of CW_Typ attached to node N
+ function Requires_Cleanup_Actions
+ (L : List_Id;
+ For_Package : Boolean;
+ Nested_Constructs : Boolean) return Boolean;
+ -- Given a list L, determine whether it contains one of the following:
+ --
+ -- 1) controlled objects
+ -- 2) library-level tagged types
+ --
+ -- Flag For_Package should be set when the list comes from a package spec
+ -- or body. Flag Nested_Constructs should be set when any nested packages
+ -- declared in L must be processed.
+
----------------------
-- Adjust_Condition --
----------------------
Ti : Entity_Id;
begin
- -- For now, we simply ignore a call where the argument has no
- -- type (probably case of unanalyzed condition), or has a type
- -- that is not Boolean. This is because this is a pretty marginal
- -- piece of functionality, and violations of these rules are
- -- likely to be truly marginal (how much code uses Fortran Logical
- -- as the barrier to a protected entry?) and we do not want to
- -- blow up existing programs. We can change this to an assertion
- -- after 3.12a is released ???
+ -- Defend against a call where the argument has no type, or has a
+ -- type that is not Boolean. This can occur because of prior errors.
if No (T) or else not Is_Boolean_Type (T) then
return;
-- ityp!(N) /= False'Enum_Rep
- -- where ityp is an integer type with large enough size to hold
- -- any value of type T.
+ -- where ityp is an integer type with large enough size to hold any
+ -- value of type T.
if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then
if Esize (T) <= Esize (Standard_Integer) then
then
return;
- -- Otherwise we perform a conversion from the current type,
- -- which must be Standard.Boolean, to the desired type.
+ -- Otherwise we perform a conversion from the current type, which
+ -- must be Standard.Boolean, to the desired type.
else
Set_Analyzed (N);
end if;
end Append_Freeze_Actions;
+ ------------------------------------
+ -- Build_Allocate_Deallocate_Proc --
+ ------------------------------------
+
+ procedure Build_Allocate_Deallocate_Proc
+ (N : Node_Id;
+ Is_Allocate : Boolean)
+ is
+ Expr : constant Node_Id := Expression (N);
+ Ptr_Typ : constant Entity_Id := Etype (Expr);
+ Desig_Typ : constant Entity_Id :=
+ Available_View (Designated_Type (Ptr_Typ));
+
+ function Find_Object (E : Node_Id) return Node_Id;
+ -- Given an arbitrary expression of an allocator, try to find an object
+ -- reference in it, otherwise return the original expression.
+
+ function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp denotes a custom allocate or
+ -- deallocate.
+
+ -----------------
+ -- Find_Object --
+ -----------------
+
+ function Find_Object (E : Node_Id) return Node_Id is
+ Expr : Node_Id;
+
+ begin
+ pragma Assert (Is_Allocate);
+
+ Expr := E;
+ loop
+ if Nkind_In (Expr, N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
+ then
+ Expr := Expression (Expr);
+
+ elsif Nkind (Expr) = N_Explicit_Dereference then
+ Expr := Prefix (Expr);
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return Expr;
+ end Find_Object;
+
+ ---------------------------------
+ -- Is_Allocate_Deallocate_Proc --
+ ---------------------------------
+
+ function Is_Allocate_Deallocate_Proc (Subp : Entity_Id) return Boolean is
+ begin
+ -- Look for a subprogram body with only one statement which is a
+ -- call to one of the Allocate / Deallocate routines in package
+ -- Ada.Finalization.Heap_Management.
+
+ if Ekind (Subp) = E_Procedure
+ and then Nkind (Parent (Parent (Subp))) = N_Subprogram_Body
+ then
+ declare
+ HSS : constant Node_Id :=
+ Handled_Statement_Sequence (Parent (Parent (Subp)));
+ Proc : Entity_Id;
+
+ begin
+ if Present (Statements (HSS))
+ and then Nkind (First (Statements (HSS))) =
+ N_Procedure_Call_Statement
+ then
+ Proc := Entity (Name (First (Statements (HSS))));
+
+ return
+ Is_RTE (Proc, RE_Allocate)
+ or else Is_RTE (Proc, RE_Deallocate);
+ end if;
+ end;
+ end if;
+
+ return False;
+ end Is_Allocate_Deallocate_Proc;
+
+ -- Start of processing for Build_Allocate_Deallocate_Proc
+
+ begin
+ -- The allocation / deallocation of a non-controlled object does not
+ -- need the machinery created by this routine.
+
+ if not Needs_Finalization (Desig_Typ) then
+ return;
+
+ -- The allocator or free statement has already been expanded and already
+ -- has a custom Allocate / Deallocate routine.
+
+ elsif Nkind (Expr) = N_Allocator
+ and then Present (Procedure_To_Call (Expr))
+ and then Is_Allocate_Deallocate_Proc (Procedure_To_Call (Expr))
+ then
+ return;
+ end if;
+
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ Addr_Id : constant Entity_Id := Make_Temporary (Loc, 'A');
+ Alig_Id : constant Entity_Id := Make_Temporary (Loc, 'L');
+ Proc_Id : constant Entity_Id := Make_Temporary (Loc, 'P');
+ Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
+
+ Actuals : List_Id;
+ Collect_Act : Node_Id;
+ Collect_Id : Entity_Id;
+ Collect_Typ : Entity_Id;
+ Proc_To_Call : Entity_Id;
+
+ begin
+ -- When dealing with an access subtype, use the collection of the
+ -- base type.
+
+ if Ekind (Ptr_Typ) = E_Access_Subtype then
+ Collect_Typ := Base_Type (Ptr_Typ);
+ else
+ Collect_Typ := Ptr_Typ;
+ end if;
+
+ Collect_Id := Associated_Collection (Collect_Typ);
+ Collect_Act := New_Reference_To (Collect_Id, Loc);
+
+ -- Handle the case where the collection is actually a pointer to a
+ -- collection. This case arises in build-in-place functions.
+
+ if Is_Access_Type (Etype (Collect_Id)) then
+ Collect_Act :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => Collect_Act);
+ end if;
+
+ -- Create the actuals for the call to Allocate / Deallocate
+
+ Actuals := New_List (
+ Collect_Act,
+ New_Reference_To (Addr_Id, Loc),
+ New_Reference_To (Size_Id, Loc),
+ New_Reference_To (Alig_Id, Loc));
+
+ -- Generate a run-time check to determine whether a class-wide object
+ -- is truly controlled.
+
+ if Is_Class_Wide_Type (Desig_Typ)
+ or else Is_Generic_Actual_Type (Desig_Typ)
+ then
+ declare
+ Flag_Id : constant Entity_Id := Make_Temporary (Loc, 'F');
+ Flag_Expr : Node_Id;
+ Param : Node_Id;
+ Temp : Node_Id;
+
+ begin
+ if Is_Allocate then
+ Temp := Find_Object (Expression (Expr));
+ else
+ Temp := Expr;
+ end if;
+
+ -- Processing for generic actuals
+
+ if Is_Generic_Actual_Type (Desig_Typ) then
+ Flag_Expr :=
+ New_Reference_To (Boolean_Literals
+ (Needs_Finalization (Base_Type (Desig_Typ))), Loc);
+
+ -- Processing for subtype indications
+
+ elsif Nkind (Temp) in N_Has_Entity
+ and then Is_Type (Entity (Temp))
+ then
+ Flag_Expr :=
+ New_Reference_To (Boolean_Literals
+ (Needs_Finalization (Entity (Temp))), Loc);
+
+ -- Generate a runtime check to test the controlled state of an
+ -- object for the purposes of allocation / deallocation.
+
+ else
+ -- The following case arises when allocating through an
+ -- interface class-wide type, generate:
+ --
+ -- Temp.all
+
+ if Is_RTE (Etype (Temp), RE_Tag_Ptr) then
+ Param :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Relocate_Node (Temp));
+
+ -- Generate:
+ -- Temp'Tag
+
+ else
+ Param :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Relocate_Node (Temp),
+ Attribute_Name => Name_Tag);
+ end if;
+
+ -- Generate:
+ -- Needs_Finalization (Param)
+
+ Flag_Expr :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Needs_Finalization), Loc),
+ Parameter_Associations => New_List (Param));
+ end if;
+
+ -- Create the temporary which represents the finalization state
+ -- of the expression. Generate:
+ --
+ -- F : constant Boolean := <Flag_Expr>;
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression => Flag_Expr));
+
+ -- The flag acts as the fifth actual
+
+ Append_To (Actuals, New_Reference_To (Flag_Id, Loc));
+ end;
+ end if;
+
+ -- Select the proper routine to call
+
+ if Is_Allocate then
+ Proc_To_Call := RTE (RE_Allocate);
+ else
+ Proc_To_Call := RTE (RE_Deallocate);
+ end if;
+
+ -- Create a custom Allocate / Deallocate routine which has identical
+ -- profile to that of System.Storage_Pools.
+
+ Insert_Action (N,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+
+ -- procedure Pnn
+
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => New_List (
+
+ -- P : Root_Storage_Pool
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Temporary (Loc, 'P'),
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Root_Storage_Pool), Loc)),
+
+ -- A : [out] Address
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Addr_Id,
+ Out_Present => Is_Allocate,
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Address), Loc)),
+
+ -- S : Storage_Count
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Size_Id,
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Storage_Count), Loc)),
+
+ -- L : Storage_Count
+
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Alig_Id,
+ Parameter_Type =>
+ New_Reference_To (RTE (RE_Storage_Count), Loc)))),
+
+ Declarations => No_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+
+ -- Allocate / Deallocate
+ -- (<Ptr_Typ collection>, A, S, L[, F]);
+
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (Proc_To_Call, Loc),
+ Parameter_Associations => Actuals)))));
+
+ -- The newly generated Allocate / Deallocate becomes the default
+ -- procedure to call when the back end processes the allocation /
+ -- deallocation.
+
+ if Is_Allocate then
+ Set_Procedure_To_Call (Expr, Proc_Id);
+ else
+ Set_Procedure_To_Call (N, Proc_Id);
+ end if;
+ end;
+ end Build_Allocate_Deallocate_Proc;
+
------------------------
-- Build_Runtime_Call --
------------------------
-- local to the init proc for the array type, and is called for each one
-- of the components. The constructed image has the form of an indexed
-- component, whose prefix is the outer variable of the array type.
- -- The n-dimensional array type has known indices Index, Index2...
+ -- The n-dimensional array type has known indexes Index, Index2...
+
-- Id_Ref is an indexed component form created by the enclosing init proc.
- -- Its successive indices are Val1, Val2, ... which are the loop variables
+ -- Its successive indexes are Val1, Val2, ... which are the loop variables
-- in the loops that call the individual task init proc on each component.
-- The generated function has the following structure:
-- return Res;
-- end F;
--
- -- Needless to say, multidimensional arrays of tasks are rare enough
- -- that the bulkiness of this code is not really a concern.
+ -- Needless to say, multidimensional arrays of tasks are rare enough that
+ -- the bulkiness of this code is not really a concern.
function Build_Task_Array_Image
(Loc : Source_Ptr;
-- String to hold result
Val : Node_Id;
- -- Value of successive indices
+ -- Value of successive indexes
Sum : Node_Id;
-- Expression to compute total size of string
Stats : constant List_Id := New_List;
begin
- -- For a dynamic task, the name comes from the target variable.
- -- For a static one it is a formal of the enclosing init proc.
+ -- For a dynamic task, the name comes from the target variable. For a
+ -- static one it is a formal of the enclosing init proc.
if Dyn then
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
or else Nkind (Id_Ref) = N_Defining_Identifier
then
-- 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.
+ -- 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,
Defining_Unit_Name => Make_Temporary (Loc, 'F'),
Result_Definition => New_Occurrence_Of (Standard_String, Loc));
- -- Calls to 'Image use the secondary stack, which must be cleaned
- -- up after the task name is built.
+ -- 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,
Stats : constant List_Id := New_List;
begin
- -- For a dynamic task, the name comes from the target variable.
- -- For a static one it is a formal of the enclosing init proc.
+ -- For a dynamic task, the name comes from the target variable. For a
+ -- static one it is a formal of the enclosing init proc.
if Dyn then
Get_Name_String (Chars (Entity (Prefix (Id_Ref))));
IR : Node_Id;
begin
- -- An itype reference must only be created if this is a local
- -- itype, so that gigi can elaborate it on the proper objstack.
+ -- An itype reference must only be created if this is a local itype, so
+ -- that gigi can elaborate it on the proper objstack.
if Is_Itype (Typ)
and then Scope (Typ) = Current_Scope
-- This function is applicable for both static and dynamic allocation of
-- 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 evaluation. In the static allocation case, the general
-- scheme is:
begin
-- In general we cannot build the subtype if expansion is disabled,
-- because internal entities may not have been defined. However, to
- -- avoid some cascaded errors, we try to continue when the expression
- -- is an array (or string), because it is safe to compute the bounds.
- -- It is in fact required to do so even in a generic context, because
- -- there may be constants that depend on bounds of string literal.
+ -- avoid some cascaded errors, we try to continue when the expression is
+ -- an array (or string), because it is safe to compute the bounds. It is
+ -- in fact required to do so even in a generic context, because there
+ -- may be constants that depend on the bounds of a string literal, both
+ -- standard string types and more generally arrays of characters.
if not Expander_Active
and then (No (Etype (Exp))
- or else Base_Type (Etype (Exp)) /= Standard_String)
+ or else not Is_String_Type (Etype (Exp)))
then
return;
end if;
if Is_Itype (Exp_Typ) then
-- 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
+ -- 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
Defining_Identifier => T,
Subtype_Indication => New_Reference_To (Exp_Typ, Loc)));
- -- This type is marked as an itype even though it has an
- -- explicit declaration because otherwise it can be marked
- -- with Is_Generic_Actual_Type and generate spurious errors.
- -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers)
+ -- This type is marked as an itype even though it has an explicit
+ -- declaration since otherwise Is_Generic_Actual_Type can get
+ -- set, resulting in the generation of spurious errors. (See
+ -- sem_ch8.Analyze_Package_Renaming and sem_type.covers)
Set_Is_Itype (T);
Set_Associated_Node_For_Itype (T, Exp);
-- Renamings of class-wide interface types require no equivalent
-- constrained type declarations because we only need to reference
- -- the tag component associated with the interface.
+ -- the tag component associated with the interface. The same is
+ -- presumably true for class-wide types in general, so this test
+ -- is broadened to include all class-wide renamings, which also
+ -- avoids cases of unbounded recursion in Remove_Side_Effects.
+ -- (Is this really correct, or are there some cases of class-wide
+ -- renamings that require action in this procedure???)
elsif Present (N)
and then Nkind (N) = N_Object_Renaming_Declaration
- and then Is_Interface (Unc_Type)
+ and then Is_Class_Wide_Type (Unc_Type)
then
- pragma Assert (Is_Class_Wide_Type (Unc_Type));
null;
- -- In Ada95, nothing to be done if the type of the expression is
- -- limited, because in this case the expression cannot be copied,
- -- and its use can only be by reference.
+ -- In Ada95 nothing to be done if the type of the expression is limited,
+ -- because in this case the expression cannot be copied, and its use can
+ -- only be by reference.
-- In Ada2005, the context can be an object declaration whose expression
-- is a function that returns in place. If the nominal subtype has
-- If the type is class-wide, the expression is dynamically tagged and
-- we do not create an actual subtype either. Ditto for an interface.
+ -- For now this applies only if the type is immutably limited, and the
+ -- function being called is build-in-place. This will have to be revised
+ -- when build-in-place functions are generalized to other types.
- elsif Is_Limited_Type (Exp_Typ)
+ elsif Is_Immutably_Limited_Type (Exp_Typ)
and then
(Is_Class_Wide_Type (Exp_Typ)
or else Is_Interface (Exp_Typ)
while Present (Init_Call) and then Init_Call /= Rep_Clause loop
if Nkind (Init_Call) = N_Procedure_Call_Statement
- and then Is_Entity_Name (Name (Init_Call))
- and then Entity (Name (Init_Call)) = Init_Proc
+ and then Is_Entity_Name (Name (Init_Call))
+ and then Entity (Name (Init_Call)) = Init_Proc
then
return Init_Call;
end if;
+
Next (Init_Call);
end loop;
-- applying to Var).
if No (Init_Call) and then Present (Freeze_Node (Var)) then
- Init_Call := Find_Init_Call_In_List
- (First (Actions (Freeze_Node (Var))));
+ Init_Call :=
+ Find_Init_Call_In_List (First (Actions (Freeze_Node (Var))));
end if;
return Init_Call;
(not Is_Class_Wide_Type (Typ)
and then Ekind (Typ) /= E_Incomplete_Type);
- if Is_Ancestor (Iface, Typ) then
+ if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
return First_Elmt (Access_Disp_Table (Typ));
else
while Present (ADT)
and then Present (Related_Type (Node (ADT)))
and then Related_Type (Node (ADT)) /= Iface
- and then not Is_Ancestor (Iface, Related_Type (Node (ADT)))
+ and then not Is_Ancestor (Iface, Related_Type (Node (ADT)),
+ Use_Full_View => True)
loop
Next_Elmt (ADT);
end loop;
while Present (AI_Elmt) loop
AI := Node (AI_Elmt);
- if AI = Iface or else Is_Ancestor (Iface, AI) then
+ if AI = Iface
+ or else Is_Ancestor (Iface, AI, Use_Full_View => True)
+ then
Found := True;
return;
end if;
-- If the interface is an ancestor of the type, then it shared the
-- primary dispatch table.
- if Is_Ancestor (Iface, Typ) then
+ if Is_Ancestor (Iface, Typ, Use_Full_View => True) then
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
return First_Tag_Component (Typ);
(T : Entity_Id;
Name : TSS_Name_Type) return Entity_Id
is
- Prim : Elmt_Id;
- Typ : Entity_Id := T;
+ Inher_Op : Entity_Id := Empty;
+ Own_Op : Entity_Id := Empty;
+ Prim_Elmt : Elmt_Id;
+ Prim_Id : Entity_Id;
+ Typ : Entity_Id := T;
begin
if Is_Class_Wide_Type (Typ) then
Typ := Underlying_Type (Typ);
- Prim := First_Elmt (Primitive_Operations (Typ));
- while not Is_TSS (Node (Prim), Name) loop
- Next_Elmt (Prim);
+ -- This search is based on the assertion that the dispatching version
+ -- of the TSS routine always precedes the real primitive.
- -- Raise program error if no primitive found
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim_Id := Node (Prim_Elmt);
- if No (Prim) then
- raise Program_Error;
+ if Is_TSS (Prim_Id, Name) then
+ if Present (Alias (Prim_Id)) then
+ Inher_Op := Prim_Id;
+ else
+ Own_Op := Prim_Id;
+ end if;
end if;
+
+ Next_Elmt (Prim_Elmt);
end loop;
- return Node (Prim);
+ if Present (Own_Op) then
+ return Own_Op;
+ elsif Present (Inher_Op) then
+ return Inher_Op;
+ else
+ raise Program_Error;
+ end if;
end Find_Prim_Op;
----------------------------
raise Program_Error;
end Find_Protection_Object;
+ --------------------------
+ -- Find_Protection_Type --
+ --------------------------
+
+ function Find_Protection_Type (Conc_Typ : Entity_Id) return Entity_Id is
+ Comp : Entity_Id;
+ Typ : Entity_Id := Conc_Typ;
+
+ begin
+ if Is_Concurrent_Type (Typ) then
+ Typ := Corresponding_Record_Type (Typ);
+ end if;
+
+ Comp := First_Component (Typ);
+ while Present (Comp) loop
+ if Chars (Comp) = Name_uObject then
+ return Base_Type (Etype (Comp));
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- The corresponding record of a protected type should always have an
+ -- _object field.
+
+ raise Program_Error;
+ end Find_Protection_Type;
+
----------------------
-- Force_Evaluation --
----------------------
Remove_Side_Effects (Exp, Name_Req, Variable_Ref => True);
end Force_Evaluation;
+ ---------------------------------
+ -- Fully_Qualified_Name_String --
+ ---------------------------------
+
+ function Fully_Qualified_Name_String (E : Entity_Id) return String_Id is
+ procedure Internal_Full_Qualified_Name (E : Entity_Id);
+ -- Compute recursively the qualified name without NUL at the end, adding
+ -- it to the currently started string being generated
+
+ ----------------------------------
+ -- Internal_Full_Qualified_Name --
+ ----------------------------------
+
+ procedure Internal_Full_Qualified_Name (E : Entity_Id) is
+ Ent : Entity_Id;
+
+ begin
+ -- Deal properly with child units
+
+ if Nkind (E) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (E);
+ else
+ Ent := E;
+ end if;
+
+ -- Compute qualification recursively (only "Standard" has no scope)
+
+ if Present (Scope (Scope (Ent))) then
+ Internal_Full_Qualified_Name (Scope (Ent));
+ Store_String_Char (Get_Char_Code ('.'));
+ end if;
+
+ -- Every entity should have a name except some expanded blocks
+ -- don't bother about those.
+
+ if Chars (Ent) = No_Name then
+ return;
+ end if;
+
+ -- Generates the entity name in upper case
+
+ Get_Decoded_Name_String (Chars (Ent));
+ Set_All_Upper_Case;
+ Store_String_Chars (Name_Buffer (1 .. Name_Len));
+ return;
+ end Internal_Full_Qualified_Name;
+
+ -- Start of processing for Full_Qualified_Name
+
+ begin
+ Start_String;
+ Internal_Full_Qualified_Name (E);
+ Store_String_Char (Get_Char_Code (ASCII.NUL));
+ return End_String;
+ end Fully_Qualified_Name_String;
+
------------------------
-- Generate_Poll_Call --
------------------------
if Nkind (Cond) = N_And_Then
or else Nkind (Cond) = N_Op_And
then
- -- Don't ever try to invert a condition that is of the form
- -- of an AND or AND THEN (since we are not doing sufficiently
- -- general processing to allow this).
+ -- Don't ever try to invert a condition that is of the form of an
+ -- AND or AND THEN (since we are not doing sufficiently general
+ -- processing to allow this).
if Sens = False then
Op := N_Empty;
end;
-- ELSIF part. Condition is known true within the referenced
- -- ELSIF, known False in any subsequent ELSIF or ELSE part, and
- -- unknown before the ELSE part or after the IF statement.
+ -- ELSIF, known False in any subsequent ELSIF or ELSE part,
+ -- and unknown before the ELSE part or after the IF statement.
elsif Nkind (CV) = N_Elsif_Part then
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;
+ ---------------------
+ -- Get_Stream_Size --
+ ---------------------
+ function Get_Stream_Size (E : Entity_Id) return Uint is
begin
- -- Only consider record types
+ -- If we have a Stream_Size clause for this type use it
- if not Ekind_In (Typ, E_Record_Type, E_Record_Subtype) then
- return False;
+ if Has_Stream_Size_Clause (E) then
+ return Static_Integer (Expression (Stream_Size_Clause (E)));
+
+ -- Otherwise the Stream_Size if the size of the type
+
+ else
+ return Esize (E);
end if;
+ end Get_Stream_Size;
- if Has_Discriminants (Typ) then
- Discr := First_Discriminant (Typ);
- while Present (Discr) loop
- D_Typ := Etype (Discr);
+ ---------------------------
+ -- Has_Access_Constraint --
+ ---------------------------
- if Ekind (D_Typ) = E_Anonymous_Access_Type
- and then
- (Is_Controlled (Designated_Type (D_Typ))
- or else
- Is_Concurrent_Type (Designated_Type (D_Typ)))
- then
+ function Has_Access_Constraint (E : Entity_Id) return Boolean is
+ Disc : Entity_Id;
+ T : constant Entity_Id := Etype (E);
+
+ begin
+ if Has_Per_Object_Constraint (E)
+ and then Has_Discriminants (T)
+ then
+ Disc := First_Discriminant (T);
+ while Present (Disc) loop
+ if Is_Access_Type (Etype (Disc)) then
return True;
end if;
- Next_Discriminant (Discr);
+ Next_Discriminant (Disc);
end loop;
- end if;
- return False;
- end Has_Controlled_Coextensions;
+ return False;
+ else
+ return False;
+ end if;
+ end Has_Access_Constraint;
- ------------------------
- -- Has_Address_Clause --
- ------------------------
+ ----------------------------------
+ -- Has_Following_Address_Clause --
+ ----------------------------------
-- Should this function check the private part in a package ???
return Count;
end Homonym_Number;
+ -----------------------------------
+ -- In_Library_Level_Package_Body --
+ -----------------------------------
+
+ function In_Library_Level_Package_Body (Id : Entity_Id) return Boolean is
+ begin
+ -- First determine whether the entity appears at the library level, then
+ -- look at the containing unit.
+
+ if Is_Library_Level_Entity (Id) then
+ declare
+ Container : constant Node_Id := Cunit (Get_Source_Unit (Id));
+
+ begin
+ return Nkind (Unit (Container)) = N_Package_Body;
+ end;
+ end if;
+
+ return False;
+ end In_Library_Level_Package_Body;
+
------------------------------
-- In_Unconditional_Context --
------------------------------
Insert_Actions (Assoc_Node, New_List (Ins_Action), Suppress);
end Insert_Action;
+ -------------------------
+ -- Insert_Action_After --
+ -------------------------
+
+ procedure Insert_Action_After
+ (Assoc_Node : Node_Id;
+ Ins_Action : Node_Id)
+ is
+ begin
+ Insert_Actions_After (Assoc_Node, New_List (Ins_Action));
+ end Insert_Action_After;
+
--------------------
-- Insert_Actions --
--------------------
-- 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
- -- eventually be elaborated in the correct order.
+ -- exit from the scope. The reason for this is that we may also be
+ -- generating freeze actions at the same time, and they must eventually
+ -- be elaborated in the correct order.
if Is_Record_Type (Current_Scope)
and then not Is_Frozen (Current_Scope)
end if;
-- We now intend to climb up the tree to find the right point to
- -- insert the actions. We start at Assoc_Node, unless this node is
- -- a subexpression in which case we start with its parent. We do this
- -- for two reasons. First it speeds things up. Second, if Assoc_Node
- -- is itself one of the special nodes like N_And_Then, then we assume
- -- that an initial request to insert actions for such a node does not
- -- expect the actions to get deposited in the node for later handling
- -- when the node is expanded, since clearly the node is being dealt
- -- with by the caller. Note that in the subexpression case, N is
- -- always the child we came from.
-
- -- N_Raise_xxx_Error is an annoying special case, it is a statement
- -- if it has type Standard_Void_Type, and a subexpression otherwise.
+ -- insert the actions. We start at Assoc_Node, unless this node is a
+ -- subexpression in which case we start with its parent. We do this for
+ -- two reasons. First it speeds things up. Second, if Assoc_Node is
+ -- itself one of the special nodes like N_And_Then, then we assume that
+ -- an initial request to insert actions for such a node does not expect
+ -- the actions to get deposited in the node for later handling when the
+ -- node is expanded, since clearly the node is being dealt with by the
+ -- caller. Note that in the subexpression case, N is always the child we
+ -- came from.
+
+ -- N_Raise_xxx_Error is an annoying special case, it is a statement if
+ -- it has type Standard_Void_Type, and a subexpression otherwise.
-- otherwise. Procedure attribute references are also statements.
if Nkind (Assoc_Node) in N_Subexpr
P := Assoc_Node; -- ??? does not agree with above!
N := Parent (Assoc_Node);
- -- Non-subexpression case. Note that N is initially Empty in this
- -- case (N is only guaranteed Non-Empty in the subexpr case).
+ -- Non-subexpression case. Note that N is initially Empty in this case
+ -- (N is only guaranteed Non-Empty in the subexpr case).
else
P := Assoc_Node;
ElseX : constant Node_Id := Next (ThenX);
begin
- -- Actions belong to the then expression, temporarily
- -- place them as Then_Actions of the conditional expr.
- -- They will be moved to the proper place later when
- -- the conditional expression is expanded.
+ -- If the enclosing expression is already analyzed, as
+ -- is the case for nested elaboration checks, insert the
+ -- conditional further out.
+
+ if Analyzed (P) then
+ null;
- if N = ThenX then
+ -- Actions belong to the then expression, temporarily place
+ -- them as Then_Actions of the conditional expr. They will
+ -- be moved to the proper place later when the conditional
+ -- expression is expanded.
+
+ elsif N = ThenX then
if Present (Then_Actions (P)) then
Insert_List_After_And_Analyze
(Last (Then_Actions (P)), Ins_Actions);
end if;
end;
- -- Alternative of case expression, we place the action in
- -- the Actions field of the case expression alternative, this
- -- will be handled when the case expression is expanded.
+ -- Alternative of case expression, we place the action in the
+ -- Actions field of the case expression alternative, this will
+ -- be handled when the case expression is expanded.
when N_Case_Expression_Alternative =>
if Present (Actions (P)) then
(Last (Actions (P)), Ins_Actions);
else
Set_Actions (P, Ins_Actions);
- Analyze_List (Then_Actions (P));
+ Analyze_List (Actions (P));
end if;
return;
-- Case of appearing within an Expressions_With_Actions node. We
- -- prepend the actions to the list of actions already there.
+ -- prepend the actions to the list of actions already there, if
+ -- the node has not been analyzed yet. Otherwise find insertion
+ -- location further up the tree.
when N_Expression_With_Actions =>
- Prepend_List (Ins_Actions, Actions (P));
- return;
+ if not Analyzed (P) then
+ Prepend_List (Ins_Actions, Actions (P));
+ return;
+ end if;
-- Case of appearing in the condition of a while expression or
-- elsif. We insert the actions into the Condition_Actions field.
else
Set_Condition_Actions (P, Ins_Actions);
- -- Set the parent of the insert actions explicitly.
- -- This is not a syntactic field, but we need the
- -- parent field set, in particular so that freeze
- -- can understand that it is dealing with condition
- -- actions, and properly insert the freezing actions.
+ -- Set the parent of the insert actions explicitly. This
+ -- is not a syntactic field, but we need the parent field
+ -- set, in particular so that freeze can understand that
+ -- it is dealing with condition actions, and properly
+ -- insert the freezing actions.
Set_Parent (Ins_Actions, P);
Analyze_List (Condition_Actions (P));
N_Entry_Body |
N_Exception_Declaration |
N_Exception_Renaming_Declaration |
+ N_Expression_Function |
N_Formal_Abstract_Subprogram_Declaration |
N_Formal_Concrete_Subprogram_Declaration |
N_Formal_Object_Declaration |
N_Task_Body_Stub |
N_Task_Type_Declaration |
+ -- Use clauses can appear in lists of declarations
+
+ N_Use_Package_Clause |
+ N_Use_Type_Clause |
+
-- Freeze entity behaves like a declaration or statement
N_Freeze_Entity
elsif Nkind (Parent (P)) = N_Component_Association then
null;
- -- Do not insert if the parent of P is either an N_Variant
- -- node or an N_Record_Definition node, meaning in either
- -- case that P is a member of a component list, and that
- -- therefore the actions should be inserted outside the
- -- complete record declaration.
+ -- Do not insert if the parent of P is either an N_Variant node
+ -- or an N_Record_Definition node, meaning in either case that
+ -- P is a member of a component list, and that therefore the
+ -- actions should be inserted outside the complete record
+ -- declaration.
elsif Nkind (Parent (P)) = N_Variant
or else Nkind (Parent (P)) = N_Record_Definition
-- subsequent use in the back end: within a package spec the
-- loop is part of the elaboration procedure and is only
-- elaborated during the second pass.
- -- If the loop comes from source, or the entity is local to
- -- the loop itself it must remain within.
+
+ -- If the loop comes from source, or the entity is local to the
+ -- loop itself it must remain within.
elsif Nkind (Parent (P)) = N_Loop_Statement
and then not Comes_From_Source (Parent (P))
return;
end if;
- -- A special case, N_Raise_xxx_Error can act either as a
- -- statement or a subexpression. We tell the difference
- -- by looking at the Etype. It is set to Standard_Void_Type
- -- in the statement case.
+ -- A special case, N_Raise_xxx_Error can act either as a statement
+ -- or a subexpression. We tell the difference by looking at the
+ -- Etype. It is set to Standard_Void_Type in the statement case.
when
N_Raise_xxx_Error =>
Decl : Node_Id;
begin
- -- Check whether these actions were generated
- -- by a declaration that is part of the loop_
- -- actions for the component_association.
+ -- Check whether these actions were generated by a
+ -- declaration that is part of the loop_ actions
+ -- for the component_association.
Decl := Assoc_Node;
while Present (Decl) loop
null;
end if;
+ -- A contract node should not belong to the tree
+
+ when N_Contract =>
+ raise Program_Error;
+
-- For all other node types, keep climbing tree
when
N_Access_To_Object_Definition |
N_Aggregate |
N_Allocator |
+ N_Aspect_Specification |
N_Case_Expression |
N_Case_Statement_Alternative |
N_Character_Literal |
N_Index_Or_Discriminant_Constraint |
N_Indexed_Component |
N_Integer_Literal |
+ N_Iterator_Specification |
N_Itype_Reference |
N_Label |
N_Loop_Parameter_Specification |
N_Push_Program_Error_Label |
N_Push_Storage_Error_Label |
N_Qualified_Expression |
+ N_Quantified_Expression |
N_Range |
N_Range_Constraint |
N_Real_Literal |
N_Unconstrained_Array_Definition |
N_Unused_At_End |
N_Unused_At_Start |
- N_Use_Package_Clause |
- N_Use_Type_Clause |
N_Variant |
N_Variant_Part |
N_Validate_Unchecked_Conversion |
if Nkind (Parent (N)) = N_Subunit then
- -- This is the proper body corresponding to a stub. Insertion
- -- must be done at the point of the stub, which is in the decla-
- -- rative part of the parent unit.
+ -- This is the proper body corresponding to a stub. Insertion must
+ -- be done at the point of the stub, which is in the declarative
+ -- part of the parent unit.
P := Corresponding_Stub (Parent (N));
return True;
end Is_All_Null_Statements;
- ---------------------------------
- -- Is_Fully_Repped_Tagged_Type --
- ---------------------------------
+ ------------------------------
+ -- Is_Finalizable_Transient --
+ ------------------------------
- function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
- U : constant Entity_Id := Underlying_Type (T);
- Comp : Entity_Id;
+ function Is_Finalizable_Transient
+ (Decl : Node_Id;
+ Rel_Node : Node_Id) return Boolean
+ is
+ Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+ Desig : Entity_Id := Obj_Typ;
+ Has_Rens : Boolean := True;
+ Ren_Obj : Entity_Id;
+
+ function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
+ -- Determine whether transient object Trans_Id is initialized either
+ -- by a function call which returns an access type or simply renames
+ -- another pointer.
+
+ function Initialized_By_Aliased_BIP_Func_Call
+ (Trans_Id : Entity_Id) return Boolean;
+ -- Determine whether transient object Trans_Id is initialized by a
+ -- build-in-place function call where the BIPalloc parameter is of
+ -- value 1 and BIPaccess is not null. This case creates an aliasing
+ -- between the returned value and the value denoted by BIPaccess.
+
+ function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
+ -- Determine whether transient object Trans_Id is allocated on the heap
+
+ function Is_Renamed
+ (Trans_Id : Entity_Id;
+ First_Stmt : Node_Id) return Boolean;
+ -- Determine whether transient object Trans_Id has been renamed in the
+ -- statement list starting from First_Stmt.
+
+ ---------------------------
+ -- Initialized_By_Access --
+ ---------------------------
+
+ function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean is
+ Expr : constant Node_Id := Expression (Parent (Trans_Id));
+
+ begin
+ return
+ Present (Expr)
+ and then Nkind (Expr) /= N_Reference
+ and then Is_Access_Type (Etype (Expr));
+ end Initialized_By_Access;
+
+ ------------------------------------------
+ -- Initialized_By_Aliased_BIP_Func_Call --
+ ------------------------------------------
+
+ function Initialized_By_Aliased_BIP_Func_Call
+ (Trans_Id : Entity_Id) return Boolean
+ is
+ Call : Node_Id := Expression (Parent (Trans_Id));
+
+ begin
+ -- Build-in-place calls usually appear in 'reference format
+
+ if Nkind (Call) = N_Reference then
+ Call := Prefix (Call);
+ end if;
+
+ if Is_Build_In_Place_Function_Call (Call) then
+ declare
+ Access_Nam : Name_Id := No_Name;
+ Access_OK : Boolean := False;
+ Actual : Node_Id;
+ Alloc_Nam : Name_Id := No_Name;
+ Alloc_OK : Boolean := False;
+ Formal : Node_Id;
+ Func_Id : Entity_Id;
+ Param : Node_Id;
+
+ begin
+ -- Examine all parameter associations of the function call
+
+ Param := First (Parameter_Associations (Call));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association
+ and then Nkind (Selector_Name (Param)) = N_Identifier
+ then
+ Actual := Explicit_Actual_Parameter (Param);
+ Formal := Selector_Name (Param);
+
+ -- Construct the names of formals BIPaccess and BIPalloc
+ -- using the function name retrieved from an arbitrary
+ -- formal.
+
+ if Access_Nam = No_Name
+ and then Alloc_Nam = No_Name
+ and then Present (Entity (Formal))
+ then
+ Func_Id := Scope (Entity (Formal));
+
+ Access_Nam :=
+ New_External_Name (Chars (Func_Id),
+ BIP_Formal_Suffix (BIP_Object_Access));
+
+ Alloc_Nam :=
+ New_External_Name (Chars (Func_Id),
+ BIP_Formal_Suffix (BIP_Alloc_Form));
+ end if;
+
+ -- A match for BIPaccess => Temp has been found
+
+ if Chars (Formal) = Access_Nam
+ and then Nkind (Actual) /= N_Null
+ then
+ Access_OK := True;
+ end if;
+
+ -- A match for BIPalloc => 1 has been found
+
+ if Chars (Formal) = Alloc_Nam
+ and then Nkind (Actual) = N_Integer_Literal
+ and then Intval (Actual) = Uint_1
+ then
+ Alloc_OK := True;
+ end if;
+ end if;
+
+ Next (Param);
+ end loop;
+
+ return Access_OK and then Alloc_OK;
+ end;
+ end if;
+
+ return False;
+ end Initialized_By_Aliased_BIP_Func_Call;
+
+ ------------------
+ -- Is_Allocated --
+ ------------------
+
+ function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
+ Expr : constant Node_Id := Expression (Parent (Trans_Id));
+
+ begin
+ return
+ Is_Access_Type (Etype (Trans_Id))
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Allocator;
+ end Is_Allocated;
+
+ ----------------
+ -- Is_Renamed --
+ ----------------
+
+ function Is_Renamed
+ (Trans_Id : Entity_Id;
+ First_Stmt : Node_Id) return Boolean
+ is
+ Stmt : Node_Id;
+
+ function Extract_Renamed_Object
+ (Ren_Decl : Node_Id) return Entity_Id;
+ -- Given an object renaming declaration, retrieve the entity of the
+ -- renamed name. Return Empty if the renamed name is anything other
+ -- than a variable or a constant.
+
+ ----------------------------
+ -- Extract_Renamed_Object --
+ ----------------------------
+
+ function Extract_Renamed_Object
+ (Ren_Decl : Node_Id) return Entity_Id
+ is
+ Change : Boolean;
+ Ren_Obj : Node_Id;
+
+ begin
+ Change := True;
+ Ren_Obj := Renamed_Object (Defining_Identifier (Ren_Decl));
+
+ while Change loop
+ Change := False;
+
+ if Nkind_In (Ren_Obj, N_Explicit_Dereference,
+ N_Indexed_Component,
+ N_Selected_Component)
+ then
+ Ren_Obj := Prefix (Ren_Obj);
+ Change := True;
+
+ elsif Nkind_In (Ren_Obj, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ then
+ Ren_Obj := Expression (Ren_Obj);
+ Change := True;
+ end if;
+ end loop;
+
+ if Nkind (Ren_Obj) in N_Has_Entity then
+ return Entity (Ren_Obj);
+ end if;
+
+ return Empty;
+ end Extract_Renamed_Object;
+
+ -- Start of processing for Is_Renamed
+
+ begin
+ -- If a previous invocation of this routine has determined that a
+ -- list has no renamings, then no point in repeating the same scan.
+
+ if not Has_Rens then
+ return False;
+ end if;
+
+ -- Assume that the statement list does not have a renaming. This is a
+ -- minor optimization.
+
+ Has_Rens := False;
+
+ Stmt := First_Stmt;
+ while Present (Stmt) loop
+ if Nkind (Stmt) = N_Object_Renaming_Declaration then
+ Has_Rens := True;
+ Ren_Obj := Extract_Renamed_Object (Stmt);
+
+ if Present (Ren_Obj)
+ and then Ren_Obj = Trans_Id
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Stmt);
+ end loop;
- begin
- if No (U) or else not Is_Tagged_Type (U) then
- return False;
- elsif Has_Discriminants (U) then
- return False;
- elsif not Has_Specified_Layout (U) then
+ return False;
+ end Is_Renamed;
+
+ -- Start of processing for Is_Finalizable_Transient
+
+ begin
+ -- Handle access types
+
+ if Is_Access_Type (Desig) then
+ Desig := Available_View (Designated_Type (Desig));
+ end if;
+
+ return
+ Ekind_In (Obj_Id, E_Constant, E_Variable)
+ and then Needs_Finalization (Desig)
+ and then Requires_Transient_Scope (Desig)
+ and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+
+ -- Do not consider transient objects allocated on the heap since they
+ -- are attached to a finalization collection.
+
+ and then not Is_Allocated (Obj_Id)
+
+ -- If the transient object is a pointer, check that it is not
+ -- initialized by a function which returns a pointer or acts as a
+ -- renaming of another pointer.
+
+ and then
+ (not Is_Access_Type (Obj_Typ)
+ or else not Initialized_By_Access (Obj_Id))
+
+ -- Do not consider transient objects which act as indirect aliases of
+ -- build-in-place function results.
+
+ and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
+
+ -- Do not consider renamed transient objects because the act of
+ -- renaming extends the object's lifetime.
+
+ and then not Is_Renamed (Obj_Id, Decl)
+
+ -- Do not consider conversions of tags to class-wide types
+
+ and then not Is_Tag_To_CW_Conversion (Obj_Id);
+ end Is_Finalizable_Transient;
+
+ ---------------------------------
+ -- Is_Fully_Repped_Tagged_Type --
+ ---------------------------------
+
+ function Is_Fully_Repped_Tagged_Type (T : Entity_Id) return Boolean is
+ U : constant Entity_Id := Underlying_Type (T);
+ Comp : Entity_Id;
+
+ begin
+ if No (U) or else not Is_Tagged_Type (U) then
+ return False;
+ elsif Has_Discriminants (U) then
+ return False;
+ elsif not Has_Specified_Layout (U) then
return False;
end if;
end Is_Library_Level_Tagged_Type;
----------------------------------
+ -- Is_Null_Access_BIP_Func_Call --
+ ----------------------------------
+
+ function Is_Null_Access_BIP_Func_Call (Expr : Node_Id) return Boolean is
+ Call : Node_Id := Expr;
+
+ begin
+ -- Build-in-place calls usually appear in 'reference format
+
+ if Nkind (Call) = N_Reference then
+ Call := Prefix (Call);
+ end if;
+
+ if Nkind_In (Call, N_Qualified_Expression,
+ N_Unchecked_Type_Conversion)
+ then
+ Call := Expression (Call);
+ end if;
+
+ if Is_Build_In_Place_Function_Call (Call) then
+ declare
+ Access_Nam : Name_Id := No_Name;
+ Actual : Node_Id;
+ Param : Node_Id;
+ Formal : Node_Id;
+
+ begin
+ -- Examine all parameter associations of the function call
+
+ Param := First (Parameter_Associations (Call));
+ while Present (Param) loop
+ if Nkind (Param) = N_Parameter_Association
+ and then Nkind (Selector_Name (Param)) = N_Identifier
+ then
+ Formal := Selector_Name (Param);
+ Actual := Explicit_Actual_Parameter (Param);
+
+ -- Construct the name of formal BIPaccess. It is much easier
+ -- to extract the name of the function using an arbitrary
+ -- formal's scope rather than the Name field of Call.
+
+ if Access_Nam = No_Name
+ and then Present (Entity (Formal))
+ then
+ Access_Nam :=
+ New_External_Name
+ (Chars (Scope (Entity (Formal))),
+ BIP_Formal_Suffix (BIP_Object_Access));
+ end if;
+
+ -- A match for BIPaccess => null has been found
+
+ if Chars (Formal) = Access_Nam
+ and then Nkind (Actual) = N_Null
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Param);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Is_Null_Access_BIP_Func_Call;
+
+ --------------------------
+ -- Is_Non_BIP_Func_Call --
+ --------------------------
+
+ function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean is
+ begin
+ -- The expected call is of the format
+ --
+ -- Func_Call'reference
+
+ return
+ Nkind (Expr) = N_Reference
+ and then Nkind (Prefix (Expr)) = N_Function_Call
+ and then not Is_Build_In_Place_Function_Call (Prefix (Expr));
+ end Is_Non_BIP_Func_Call;
+
+ ----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------
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.
+ -- Tagged and controlled types and aliased types are always aligned, as
+ -- are concurrent types.
if Is_Aliased (T)
or else Has_Controlled_Component (T)
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).
+ -- 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)
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.
+ -- 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;
-- 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.
+ -- 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)
end if;
end;
- -- For cases other than selected or indexed components we
- -- know we are OK, since no issues arise over alignment.
+ -- For cases other than selected or indexed components we know we
+ -- are OK, since no issues arise over alignment.
else
return False;
end;
end Is_Possibly_Unaligned_Slice;
+ -------------------------------
+ -- Is_Related_To_Func_Return --
+ -------------------------------
+
+ function Is_Related_To_Func_Return (Id : Entity_Id) return Boolean is
+ Expr : constant Node_Id := Related_Expression (Id);
+ begin
+ return
+ Present (Expr)
+ and then Nkind (Expr) = N_Explicit_Dereference
+ and then Nkind (Parent (Expr)) = N_Simple_Return_Statement;
+ end Is_Related_To_Func_Return;
+
--------------------------------
-- Is_Ref_To_Bit_Packed_Array --
--------------------------------
end if;
end Is_Renamed_Object;
+ -----------------------------
+ -- Is_Tag_To_CW_Conversion --
+ -----------------------------
+
+ function Is_Tag_To_CW_Conversion (Obj_Id : Entity_Id) return Boolean is
+ Expr : constant Node_Id := Expression (Parent (Obj_Id));
+
+ begin
+ return
+ Is_Class_Wide_Type (Etype (Obj_Id))
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Unchecked_Type_Conversion
+ and then Etype (Expression (Expr)) = RTE (RE_Tag);
+ end Is_Tag_To_CW_Conversion;
+
----------------------------
-- Is_Untagged_Derivation --
----------------------------
end if;
end Is_Volatile_Reference;
+ --------------------------
+ -- Is_VM_By_Copy_Actual --
+ --------------------------
+
+ function Is_VM_By_Copy_Actual (N : Node_Id) return Boolean is
+ begin
+ return VM_Target /= No_VM
+ and then (Nkind (N) = N_Slice
+ or else
+ (Nkind (N) = N_Identifier
+ and then Present (Renamed_Object (Entity (N)))
+ and then Nkind (Renamed_Object (Entity (N)))
+ = N_Slice));
+ end Is_VM_By_Copy_Actual;
+
--------------------
-- Kill_Dead_Code --
--------------------
Kill_Dead_Code (Private_Declarations (Specification (N)));
-- ??? After this point, Delete_Tree has been called on all
- -- declarations in Specification (N), so references to
- -- entities therein look suspicious.
+ -- declarations in Specification (N), so references to entities
+ -- therein look suspicious.
declare
E : Entity_Id := First_Entity (Defining_Entity (N));
end loop;
end;
- -- Recurse into composite statement to kill individual statements,
- -- in particular instantiations.
+ -- Recurse into composite statement to kill individual statements in
+ -- particular instantiations.
elsif Nkind (N) = N_If_Statement then
Kill_Dead_Code (Then_Statements (N));
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.
+ -- 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;
+ -------------------------
+ -- Make_Invariant_Call --
+ -------------------------
+
+ function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Typ : constant Entity_Id := Etype (Expr);
+
+ begin
+ pragma Assert
+ (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
+
+ if Check_Enabled (Name_Invariant)
+ or else
+ Check_Enabled (Name_Assertion)
+ then
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+
+ else
+ return
+ Make_Null_Statement (Loc);
+ end if;
+ end Make_Invariant_Call;
+
------------------------
-- Make_Literal_Range --
------------------------
Make_Integer_Literal (Loc, 0));
end Make_Non_Empty_Check;
+ -------------------------
+ -- Make_Predicate_Call --
+ -------------------------
+
+ function Make_Predicate_Call
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ pragma Assert (Present (Predicate_Function (Typ)));
+
+ return
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Predicate_Function (Typ), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Expr)));
+ end Make_Predicate_Call;
+
+ --------------------------
+ -- Make_Predicate_Check --
+ --------------------------
+
+ function Make_Predicate_Check
+ (Typ : Entity_Id;
+ Expr : Node_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Expr);
+
+ begin
+ return
+ Make_Pragma (Loc,
+ Pragma_Identifier => Make_Identifier (Loc, Name_Check),
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Predicate)),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Predicate_Call (Typ, Expr))));
+ end Make_Predicate_Check;
+
----------------------------
-- Make_Subtype_From_Expr --
----------------------------
if Is_Tagged_Type (Priv_Subtyp) then
Set_Class_Wide_Type
(Base_Type (Priv_Subtyp), Class_Wide_Type (Unc_Typ));
- Set_Primitive_Operations (Priv_Subtyp,
- Primitive_Operations (Unc_Typ));
+ Set_Direct_Primitive_Operations (Priv_Subtyp,
+ Direct_Primitive_Operations (Unc_Typ));
end if;
Set_Full_View (Priv_Subtyp, Full_Subtyp);
if Expander_Active and then Tagged_Type_Expansion then
- -- If this is the class_wide type of a completion that is
- -- a record subtype, set the type of the class_wide type
- -- to be the full base type, for use in the expanded code
- -- for the equivalent type. Should this be done earlier when
- -- the completion is analyzed ???
+ -- If this is the class_wide type of a completion that is a
+ -- record subtype, set the type of the class_wide type to be
+ -- the full base type, for use in the expanded code for the
+ -- equivalent type. Should this be done earlier when the
+ -- completion is analyzed ???
if Is_Private_Type (Etype (Unc_Typ))
and then
-- May_Generate_Large_Temp --
-----------------------------
- -- 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 256 bits or less at compile time, and we
- -- are still not doing a thorough job on arrays and records ???
+ -- 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 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
end if;
end May_Generate_Large_Temp;
+ ------------------------
+ -- Needs_Finalization --
+ ------------------------
+
+ function Needs_Finalization (T : Entity_Id) return Boolean is
+ function Has_Some_Controlled_Component (Rec : Entity_Id) return Boolean;
+ -- If type is not frozen yet, check explicitly among its components,
+ -- because the Has_Controlled_Component flag is not necessarily set.
+
+ -----------------------------------
+ -- Has_Some_Controlled_Component --
+ -----------------------------------
+
+ function Has_Some_Controlled_Component
+ (Rec : Entity_Id) return Boolean
+ is
+ Comp : Entity_Id;
+
+ begin
+ if Has_Controlled_Component (Rec) then
+ return True;
+
+ elsif not Is_Frozen (Rec) then
+ if Is_Record_Type (Rec) then
+ Comp := First_Entity (Rec);
+
+ while Present (Comp) loop
+ if not Is_Type (Comp)
+ and then Needs_Finalization (Etype (Comp))
+ then
+ return True;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+
+ return False;
+
+ elsif Is_Array_Type (Rec) then
+ return Needs_Finalization (Component_Type (Rec));
+
+ else
+ return Has_Controlled_Component (Rec);
+ end if;
+ else
+ return False;
+ end if;
+ end Has_Some_Controlled_Component;
+
+ -- Start of processing for Needs_Finalization
+
+ begin
+ -- Certain run-time configurations and targets do not provide support
+ -- for controlled types.
+
+ if Restriction_Active (No_Finalization) then
+ return False;
+
+ else
+ -- Class-wide types are treated as controlled because derivations
+ -- from the root type can introduce controlled components.
+
+ return
+ Is_Class_Wide_Type (T)
+ or else Is_Controlled (T)
+ or else Has_Controlled_Component (T)
+ or else Has_Some_Controlled_Component (T)
+ or else
+ (Is_Concurrent_Type (T)
+ and then Present (Corresponding_Record_Type (T))
+ and then Needs_Finalization (Corresponding_Record_Type (T)));
+ end if;
+ end Needs_Finalization;
+
+ ----------------------------
+ -- Needs_Constant_Address --
+ ----------------------------
+
+ function Needs_Constant_Address
+ (Decl : Node_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ begin
+
+ -- If we have no initialization of any kind, then we don't need to place
+ -- any restrictions on the address clause, because the object will be
+ -- elaborated after the address clause is evaluated. This happens if the
+ -- declaration has no initial expression, or the type has no implicit
+ -- initialization, or the object is imported.
+
+ -- The same holds for all initialized scalar types and all access types.
+ -- Packed bit arrays of size up to 64 are represented using a modular
+ -- type with an initialization (to zero) and can be processed like other
+ -- initialized scalar types.
+
+ -- If the type is controlled, code to attach the object to a
+ -- finalization chain is generated at the point of declaration, and
+ -- therefore the elaboration of the object cannot be delayed: the
+ -- address expression must be a constant.
+
+ if No (Expression (Decl))
+ and then not Needs_Finalization (Typ)
+ and then
+ (not Has_Non_Null_Base_Init_Proc (Typ)
+ or else Is_Imported (Defining_Identifier (Decl)))
+ then
+ return False;
+
+ elsif (Present (Expression (Decl)) and then Is_Scalar_Type (Typ))
+ or else Is_Access_Type (Typ)
+ or else
+ (Is_Bit_Packed_Array (Typ)
+ and then Is_Modular_Integer_Type (Packed_Array_Type (Typ)))
+ then
+ return False;
+
+ else
+
+ -- Otherwise, we require the address clause to be constant because
+ -- the call to the initialization procedure (or the attach code) has
+ -- to happen at the point of the declaration.
+
+ -- Actually the IP call has been moved to the freeze actions anyway,
+ -- so maybe we can relax this restriction???
+
+ return True;
+ end if;
+ end Needs_Constant_Address;
+
----------------------------
-- New_Class_Wide_Subtype --
----------------------------
end case;
end Possible_Bit_Aligned_Component;
+ -----------------------------------------------
+ -- Process_Statements_For_Controlled_Objects --
+ -----------------------------------------------
+
+ procedure Process_Statements_For_Controlled_Objects (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ function Are_Wrapped (L : List_Id) return Boolean;
+ -- Determine whether list L contains only one statement which is a block
+
+ function Wrap_Statements_In_Block (L : List_Id) return Node_Id;
+ -- Given a list of statements L, wrap it in a block statement and return
+ -- the generated node.
+
+ -----------------
+ -- Are_Wrapped --
+ -----------------
+
+ function Are_Wrapped (L : List_Id) return Boolean is
+ Stmt : constant Node_Id := First (L);
+ begin
+ return
+ Present (Stmt)
+ and then No (Next (Stmt))
+ and then Nkind (Stmt) = N_Block_Statement;
+ end Are_Wrapped;
+
+ ------------------------------
+ -- Wrap_Statements_In_Block --
+ ------------------------------
+
+ function Wrap_Statements_In_Block (L : List_Id) return Node_Id is
+ begin
+ return
+ Make_Block_Statement (Loc,
+ Declarations => No_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => L));
+ end Wrap_Statements_In_Block;
+
+ -- Local variables
+
+ Block : Node_Id;
+
+ -- Start of processing for Process_Statements_For_Controlled_Objects
+
+ begin
+ -- Whenever a non-handled statement list is wrapped in a block, the
+ -- block must be explicitly analyzed to redecorate all entities in the
+ -- list and ensure that a finalizer is properly built.
+
+ case Nkind (N) is
+ when N_Elsif_Part |
+ N_If_Statement |
+ N_Conditional_Entry_Call |
+ N_Selective_Accept =>
+
+ -- Check the "then statements" for elsif parts and if statements
+
+ if Nkind_In (N, N_Elsif_Part, N_If_Statement)
+ and then not Is_Empty_List (Then_Statements (N))
+ and then not Are_Wrapped (Then_Statements (N))
+ and then Requires_Cleanup_Actions
+ (Then_Statements (N), False, False)
+ then
+ Block := Wrap_Statements_In_Block (Then_Statements (N));
+ Set_Then_Statements (N, New_List (Block));
+
+ Analyze (Block);
+ end if;
+
+ -- Check the "else statements" for conditional entry calls, if
+ -- statements and selective accepts.
+
+ if Nkind_In (N, N_Conditional_Entry_Call,
+ N_If_Statement,
+ N_Selective_Accept)
+ and then not Is_Empty_List (Else_Statements (N))
+ and then not Are_Wrapped (Else_Statements (N))
+ and then Requires_Cleanup_Actions
+ (Else_Statements (N), False, False)
+ then
+ Block := Wrap_Statements_In_Block (Else_Statements (N));
+ Set_Else_Statements (N, New_List (Block));
+
+ Analyze (Block);
+ end if;
+
+ when N_Abortable_Part |
+ N_Accept_Alternative |
+ N_Case_Statement_Alternative |
+ N_Delay_Alternative |
+ N_Entry_Call_Alternative |
+ N_Exception_Handler |
+ N_Loop_Statement |
+ N_Triggering_Alternative =>
+
+ if not Is_Empty_List (Statements (N))
+ and then not Are_Wrapped (Statements (N))
+ and then Requires_Cleanup_Actions (Statements (N), False, False)
+ then
+ Block := Wrap_Statements_In_Block (Statements (N));
+ Set_Statements (N, New_List (Block));
+
+ Analyze (Block);
+ end if;
+
+ when others =>
+ null;
+ end case;
+ end Process_Statements_For_Controlled_Objects;
+
-------------------------
-- Remove_Side_Effects --
-------------------------
-- 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.
+ -- be considered to have side effects if Variable_Ref is set True.
elsif Is_Access_Type (Etype (Prefix (N)))
and then not Is_Access_Constant (Etype (Prefix (N)))
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;
+ -- Exception is a prefix that is the result of a previous removal
+ -- of side-effects.
+
+ return Is_Entity_Name (Prefix (N))
+ and then not Comes_From_Source (Prefix (N))
+ and then Ekind (Entity (Prefix (N))) = E_Constant
+ and then Is_Internal_Name (Chars (Entity (Prefix (N))));
+
+ -- If the prefix is an explicit dereference then this construct is a
+ -- variable reference, which means it is to be considered to have
+ -- side effects if Variable_Ref is True.
+
+ -- We do NOT exclude dereferences of access-to-constant types because
+ -- we handle them as constant view of variables.
+
+ -- Exception is an access to an entity that is a constant or an
+ -- in-parameter.
+
+ elsif Nkind (Prefix (N)) = N_Explicit_Dereference
+ and then Variable_Ref
+ then
+ declare
+ DDT : constant Entity_Id :=
+ Designated_Type (Etype (Prefix (Prefix (N))));
+ begin
+ return Ekind_In (DDT, E_Constant, E_In_Parameter);
+ end;
-- The following test is the simplest way of solving a complex
-- problem uncovered by BB08-010: Side effect on loop bound that
-- is a subcomponent of a global variable:
+
-- 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.
function Side_Effect_Free (N : Node_Id) return Boolean is
begin
- -- Note on checks that could raise Constraint_Error. Strictly, if
- -- we take advantage of 11.6, these checks do not count as side
- -- effects. However, we would just as soon consider that they are
- -- side effects, since the backend CSE does not work very well on
- -- expressions which can raise Constraint_Error. On the other
- -- hand, if we do not consider them to be side effect free, then
- -- we get some awkward expansions in -gnato mode, resulting in
- -- code insertions at a point where we do not have a clear model
- -- for performing the insertions.
+ -- Note on checks that could raise Constraint_Error. Strictly, if we
+ -- take advantage of 11.6, these checks do not count as side effects.
+ -- However, we would prefer to consider that they are side effects,
+ -- since the backend CSE does not work very well on expressions which
+ -- can raise Constraint_Error. On the other hand if we don't consider
+ -- them to be side effect free, then we get some awkward expansions
+ -- in -gnato mode, resulting in code insertions at a point where we
+ -- do not have a clear model for performing the insertions.
-- Special handling for entity names
if Is_Entity_Name (N) 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
- -- this test goes to the original tree, and we may have
- -- already rewritten a variable node with a constant as
- -- a result of an earlier Force_Evaluation call.
-
- if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then
- return True;
-
- -- Functions are not side effect free
-
- 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 reference 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
+ if Is_Variable (N, Use_Original_Node => False) then
return not Variable_Ref
and then (not Is_Volatile_Reference (N) or else Name_Req);
elsif Compile_Time_Known_Value (N) then
return True;
- -- A variable renaming is not side-effect free, because the
- -- renaming will function like a macro in the front-end in
- -- some cases, and an assignment can modify the component
- -- designated by N, so we need to create a temporary for it.
+ -- A variable renaming is not side-effect free, because the renaming
+ -- will function like a macro in the front-end in some cases, and an
+ -- assignment can modify the component designated by N, so we need to
+ -- create a temporary for it.
+
+ -- The guard testing for Entity being present is needed at least in
+ -- the case of rewritten predicate expressions, and may well also be
+ -- appropriate elsewhere. Obviously we can't go testing the entity
+ -- field if it does not exist, so it's reasonable to say that this is
+ -- not the renaming case if it does not exist.
elsif Is_Entity_Name (Original_Node (N))
+ and then Present (Entity (Original_Node (N)))
and then Is_Renaming_Of_Object (Entity (Original_Node (N)))
and then Ekind (Entity (Original_Node (N))) /= E_Constant
then
return False;
+
+ -- Remove_Side_Effects generates an object renaming declaration to
+ -- capture the expression of a class-wide expression. In VM targets
+ -- the frontend performs no expansion for dispatching calls to
+ -- class- wide types since they are handled by the VM. Hence, we must
+ -- locate here if this node corresponds to a previous invocation of
+ -- Remove_Side_Effects to avoid a never ending loop in the frontend.
+
+ elsif VM_Target /= No_VM
+ and then not Comes_From_Source (N)
+ and then Nkind (Parent (N)) = N_Object_Renaming_Declaration
+ and then Is_Class_Wide_Type (Etype (N))
+ then
+ return True;
end if;
-- For other than entity names and compile time known values,
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
+ -- 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_Short_Circuit =>
return Side_Effect_Free (Left_Opnd (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.
+ -- 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.
-- All other function calls are not side effect free
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. If it designates a
- -- component with a rep. clause it must be treated has having
- -- a potential side effect, because it may be modified through
- -- a renaming, and a subsequent use of the renaming as a macro
- -- will yield the wrong value. This complex interaction between
- -- renaming and removing side effects is a reminder that the
- -- latter has become a headache to maintain, and that it should
- -- be removed in favor of the gcc mechanism to capture values ???
+ -- A selected component is side effect free only if it is a side
+ -- effect free prefixed reference. If it designates a component
+ -- with a rep. clause it must be treated has having a potential
+ -- side effect, because it may be modified through a renaming, and
+ -- a subsequent use of the renaming as a macro will yield the
+ -- wrong value. This complex interaction between renaming and
+ -- removing side effects is a reminder that the latter has become
+ -- a headache to maintain, and that it should be removed in favor
+ -- of the gcc mechanism to capture values ???
when N_Selected_Component =>
if Nkind (Parent (N)) = N_Explicit_Dereference
end case;
end Side_Effect_Free;
- -- A list is side effect free if all elements of the list are
- -- 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;
-- Start of processing for Remove_Side_Effects
begin
- -- If we are side effect free already or expansion is disabled,
- -- there is nothing to do.
+ -- Handle cases in which there is nothing to do
+
+ if not Expander_Active then
+ return;
- if Side_Effect_Free (Exp) or else not Expander_Active then
+ -- Cannot generate temporaries if the invocation to remove side effects
+ -- was issued too early and the type of the expression is not resolved
+ -- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
+ -- Remove_Side_Effects).
+
+ elsif No (Exp_Type)
+ or else Ekind (Exp_Type) = E_Access_Attribute_Type
+ then
+ return;
+
+ -- No action needed for side-effect free expressions
+
+ elsif Side_Effect_Free (Exp) then
return;
end if;
Set_Etype (Def_Id, Exp_Type);
Res := New_Reference_To (Def_Id, Loc);
+ -- If the expression is a packed reference, it must be reanalyzed and
+ -- expanded, depending on context. This is the case for actuals where
+ -- a constraint check may capture the actual before expansion of the
+ -- call is complete.
+
+ if Nkind (Exp) = N_Indexed_Component
+ and then Is_Packed (Etype (Prefix (Exp)))
+ then
+ Set_Analyzed (Exp, False);
+ Set_Analyzed (Prefix (Exp), False);
+ end if;
+
E :=
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
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 the expression has the form v.all then we can just capture the
+ -- pointer, and then do an explicit dereference on the result.
elsif Nkind (Exp) = N_Explicit_Dereference then
Def_Id := Make_Temporary (Loc, 'R', Exp);
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.
+ -- 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
-- 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 creating
+ -- circumstances: for change of representations, and also when this is a
+ -- view conversion to a smaller object, where gigi can end up creating
-- its own temporary of the wrong size.
elsif Nkind (Exp) = N_Type_Conversion then
end if;
-- For expressions that denote objects, we can use a renaming scheme.
- -- We skip using this if we have a volatile reference and we do not
- -- have Name_Req set true (see comments above for Side_Effect_Free).
+ -- This is needed for correctness in the case of a volatile object of a
+ -- non-volatile type because the Make_Reference call of the "default"
+ -- approach would generate an illegal access value (an access value
+ -- cannot designate such an object - see Analyze_Reference). We skip
+ -- using this scheme if we have an object of a volatile type and we do
+ -- not have Name_Req set true (see comments above for Side_Effect_Free).
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
- and then (Name_Req or else not Is_Volatile_Reference (Exp))
+ and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
then
Def_Id := Make_Temporary (Loc, 'R', Exp);
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
+ -- 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
-- to accommodate functions returning limited objects by reference.
if Nkind (Exp) = N_Function_Call
- and then Is_Inherently_Limited_Type (Etype (Exp))
+ and then Is_Immutably_Limited_Type (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
- and then Ada_Version >= Ada_05
+ and then Ada_Version >= Ada_2005
then
declare
Obj : constant Entity_Id := Make_Temporary (Loc, 'F', Exp);
-- 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.
+ -- 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);
Make_Object_Declaration (Loc,
Defining_Identifier => Def_Id,
Object_Definition => New_Reference_To (Ref_Type, Loc),
+ Constant_Present => True,
Expression => New_Exp));
end if;
- -- Preserve the Assignment_OK flag in all copies, since at least
- -- one copy may be used in a context where this flag must be set
- -- (otherwise why would the flag be set in the first place).
+ -- Preserve the Assignment_OK flag in all copies, since at least one
+ -- copy may be used in a context where this flag must be set (otherwise
+ -- why would the flag be set in the first place).
Set_Assignment_OK (Res, Assignment_OK (Exp));
and then Is_Scalar_Type (Packed_Array_Type (UT)));
end Represented_As_Scalar;
+ ------------------------------
+ -- Requires_Cleanup_Actions --
+ ------------------------------
+
+ function Requires_Cleanup_Actions (N : Node_Id) return Boolean is
+ For_Pkg : constant Boolean :=
+ Nkind_In (N, N_Package_Body, N_Package_Specification);
+
+ begin
+ case Nkind (N) is
+ when N_Accept_Statement |
+ N_Block_Statement |
+ N_Entry_Body |
+ N_Package_Body |
+ N_Protected_Body |
+ N_Subprogram_Body |
+ N_Task_Body =>
+ return
+ Requires_Cleanup_Actions (Declarations (N), For_Pkg, True)
+ or else
+ (Present (Handled_Statement_Sequence (N))
+ and then
+ Requires_Cleanup_Actions (Statements
+ (Handled_Statement_Sequence (N)), For_Pkg, True));
+
+ when N_Package_Specification =>
+ return
+ Requires_Cleanup_Actions
+ (Visible_Declarations (N), For_Pkg, True)
+ or else
+ Requires_Cleanup_Actions
+ (Private_Declarations (N), For_Pkg, True);
+
+ when others =>
+ return False;
+ end case;
+ end Requires_Cleanup_Actions;
+
+ ------------------------------
+ -- Requires_Cleanup_Actions --
+ ------------------------------
+
+ function Requires_Cleanup_Actions
+ (L : List_Id;
+ For_Package : Boolean;
+ Nested_Constructs : Boolean) return Boolean
+ is
+ Decl : Node_Id;
+ Expr : Node_Id;
+ Obj_Id : Entity_Id;
+ Obj_Typ : Entity_Id;
+ Pack_Id : Entity_Id;
+ Typ : Entity_Id;
+
+ begin
+ if No (L)
+ or else Is_Empty_List (L)
+ then
+ return False;
+ end if;
+
+ Decl := First (L);
+ while Present (Decl) loop
+
+ -- Library-level tagged types
+
+ if Nkind (Decl) = N_Full_Type_Declaration then
+ Typ := Defining_Identifier (Decl);
+
+ if Is_Tagged_Type (Typ)
+ and then Is_Library_Level_Entity (Typ)
+ and then Convention (Typ) = Convention_Ada
+ and then Present (Access_Disp_Table (Typ))
+ and then RTE_Available (RE_Unregister_Tag)
+ and then not No_Run_Time_Mode
+ and then not Is_Abstract_Type (Typ)
+ then
+ return True;
+ end if;
+
+ -- Regular object declarations
+
+ elsif Nkind (Decl) = N_Object_Declaration then
+ Obj_Id := Defining_Identifier (Decl);
+ Obj_Typ := Base_Type (Etype (Obj_Id));
+ Expr := Expression (Decl);
+
+ -- Bypass any form of processing for objects which have their
+ -- finalization disabled. This applies only to objects at the
+ -- library level.
+
+ if For_Package
+ and then Finalize_Storage_Only (Obj_Typ)
+ then
+ null;
+
+ -- Transient variables are treated separately in order to minimize
+ -- the size of the generated code. See Exp_Ch7.Process_Transient_
+ -- Objects.
+
+ elsif Is_Processed_Transient (Obj_Id) then
+ null;
+
+ -- The object is of the form:
+ -- Obj : Typ [:= Expr];
+ --
+ -- Do not process the incomplete view of a deferred constant. Do
+ -- not consider tag-to-class-wide conversions.
+
+ elsif not Is_Imported (Obj_Id)
+ and then Needs_Finalization (Obj_Typ)
+ and then not (Ekind (Obj_Id) = E_Constant
+ and then not Has_Completion (Obj_Id))
+ and then not Is_Tag_To_CW_Conversion (Obj_Id)
+ then
+ return True;
+
+ -- The object is of the form:
+ -- Obj : Access_Typ := Non_BIP_Function_Call'reference;
+ --
+ -- Obj : Access_Typ :=
+ -- BIP_Function_Call
+ -- (..., BIPaccess => null, ...)'reference;
+
+ elsif Is_Access_Type (Obj_Typ)
+ and then Needs_Finalization
+ (Available_View (Designated_Type (Obj_Typ)))
+ and then Present (Expr)
+ and then
+ (Is_Null_Access_BIP_Func_Call (Expr)
+ or else
+ (Is_Non_BIP_Func_Call (Expr)
+ and then not Is_Related_To_Func_Return (Obj_Id)))
+ then
+ return True;
+
+ -- Processing for "hook" objects generated for controlled
+ -- transients declared inside an Expression_With_Actions.
+
+ elsif Is_Access_Type (Obj_Typ)
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ and then Nkind (Return_Flag_Or_Transient_Decl (Obj_Id)) =
+ N_Object_Declaration
+ and then Is_Finalizable_Transient
+ (Return_Flag_Or_Transient_Decl (Obj_Id), Decl)
+ then
+ return True;
+
+ -- Simple protected objects which use type System.Tasking.
+ -- Protected_Objects.Protection to manage their locks should be
+ -- treated as controlled since they require manual cleanup.
+
+ elsif Ekind (Obj_Id) = E_Variable
+ and then
+ (Is_Simple_Protected_Type (Obj_Typ)
+ or else Has_Simple_Protected_Object (Obj_Typ))
+ then
+ return True;
+ end if;
+
+ -- Specific cases of object renamings
+
+ elsif Nkind (Decl) = N_Object_Renaming_Declaration
+ and then Nkind (Name (Decl)) = N_Explicit_Dereference
+ and then Nkind (Prefix (Name (Decl))) = N_Identifier
+ then
+ Obj_Id := Defining_Identifier (Decl);
+ Obj_Typ := Base_Type (Etype (Obj_Id));
+
+ -- Bypass any form of processing for objects which have their
+ -- finalization disabled. This applies only to objects at the
+ -- library level.
+
+ if For_Package
+ and then Finalize_Storage_Only (Obj_Typ)
+ then
+ null;
+
+ -- Return object of a build-in-place function. This case is
+ -- recognized and marked by the expansion of an extended return
+ -- statement (see Expand_N_Extended_Return_Statement).
+
+ elsif Needs_Finalization (Obj_Typ)
+ and then Is_Return_Object (Obj_Id)
+ and then Present (Return_Flag_Or_Transient_Decl (Obj_Id))
+ then
+ return True;
+ end if;
+
+ -- Inspect the freeze node of an access-to-controlled type and
+ -- look for a delayed finalization collection. This case arises
+ -- when the freeze actions are inserted at a later time than the
+ -- expansion of the context. Since Build_Finalizer is never called
+ -- on a single construct twice, the collection will be ultimately
+ -- left out and never finalized. This is also needed for freeze
+ -- actions of designated types themselves, since in some cases the
+ -- finalization collection is associated with a designated type's
+ -- freeze node rather than that of the access type (see handling
+ -- for freeze actions in Build_Finalization_Collection).
+
+ elsif Nkind (Decl) = N_Freeze_Entity
+ and then Present (Actions (Decl))
+ then
+ Typ := Entity (Decl);
+
+ if ((Is_Access_Type (Typ)
+ and then not Is_Access_Subprogram_Type (Typ)
+ and then Needs_Finalization
+ (Available_View (Designated_Type (Typ))))
+ or else
+ (Is_Type (Typ)
+ and then Needs_Finalization (Typ)))
+ and then Requires_Cleanup_Actions
+ (Actions (Decl), For_Package, Nested_Constructs)
+ then
+ return True;
+ end if;
+
+ -- Nested package declarations
+
+ elsif Nested_Constructs
+ and then Nkind (Decl) = N_Package_Declaration
+ then
+ Pack_Id := Defining_Unit_Name (Specification (Decl));
+
+ if Nkind (Pack_Id) = N_Defining_Program_Unit_Name then
+ Pack_Id := Defining_Identifier (Pack_Id);
+ end if;
+
+ if Ekind (Pack_Id) /= E_Generic_Package
+ and then Requires_Cleanup_Actions (Specification (Decl))
+ then
+ return True;
+ end if;
+
+ -- Nested package bodies
+
+ elsif Nested_Constructs
+ and then Nkind (Decl) = N_Package_Body
+ then
+ Pack_Id := Corresponding_Spec (Decl);
+
+ if Ekind (Pack_Id) /= E_Generic_Package
+ and then Requires_Cleanup_Actions (Decl)
+ then
+ return True;
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return False;
+ end Requires_Cleanup_Actions;
+
------------------------------------
-- Safe_Unchecked_Type_Conversion --
------------------------------------
- -- Note: this function knows quite a bit about the exact requirements
- -- of Gigi with respect to unchecked type conversions, and its code
- -- must be coordinated with any changes in Gigi in this area.
+ -- Note: this function knows quite a bit about the exact requirements of
+ -- Gigi with respect to unchecked type conversions, and its code must be
+ -- coordinated with any changes in Gigi in this area.
-- The above requirements should be documented in Sinfo ???
then
return True;
- -- If the expression is the prefix of an N_Selected_Component
- -- we should also be OK because GCC knows to look inside the
- -- conversion except if the type is discriminated. We assume
- -- that we are OK anyway if the type is not set yet or if it is
- -- controlled since we can't afford to introduce a temporary in
- -- this case.
+ -- If the expression is the prefix of an N_Selected_Component we should
+ -- also be OK because GCC knows to look inside the conversion except if
+ -- the type is discriminated. We assume that we are OK anyway if the
+ -- type is not set yet or if it is controlled since we can't afford to
+ -- introduce a temporary in this case.
elsif Nkind (Pexp) = N_Selected_Component
and then Prefix (Pexp) = Exp
end if;
end if;
- -- Set the output type, this comes from Etype if it is set, otherwise
- -- we take it from the subtype mark, which we assume was already
- -- fully analyzed.
+ -- Set the output type, this comes from Etype if it is set, otherwise we
+ -- take it from the subtype mark, which we assume was already fully
+ -- analyzed.
if Present (Etype (Exp)) then
Otyp := Etype (Exp);
Oalign := No_Uint;
Ialign := No_Uint;
- -- Replace a concurrent type by its corresponding record type
- -- and each type by its underlying type and do the tests on those.
- -- The original type may be a private type whose completion is a
- -- concurrent type, so find the underlying type first.
+ -- Replace a concurrent type by its corresponding record type and each
+ -- type by its underlying type and do the tests on those. The original
+ -- type may be a private type whose completion is a concurrent type, so
+ -- find the underlying type first.
if Present (Underlying_Type (Otyp)) then
Otyp := Underlying_Type (Otyp);
then
return True;
- -- If the expression has an access type (object or subprogram) we
- -- assume that the conversion is safe, because the size of the target
- -- is safe, even if it is a record (which might be treated as having
- -- unknown size at this point).
+ -- If the expression has an access type (object or subprogram) we assume
+ -- that the conversion is safe, because the size of the target is safe,
+ -- even if it is a record (which might be treated as having unknown size
+ -- at this point).
elsif Is_Access_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,
- -- because we are talking about the actual size of the object.
+ -- 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, because we are
+ -- talking about the actual size of the object.
- -- We also make sure that in addition to the size being known, we do
- -- not have a case which might generate an embarrassingly large temp
- -- in stack checking mode.
+ -- We also make sure that in addition to the size being known, we do not
+ -- have a case which might generate an embarrassingly large temp in
+ -- stack checking mode.
elsif Size_Known_At_Compile_Time (Otyp)
and then
elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then
return True;
- -- If either type is a limited record type, we cannot do a copy, so
- -- say safe since there's nothing else we can do.
+ -- If either type is a limited record type, we cannot do a copy, so say
+ -- safe since there's nothing else we can do.
elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then
return True;
-- The only other cases known to be safe is if the input type's
-- alignment is known to be at least the maximum alignment for the
-- target or if both alignments are known and the output type's
- -- alignment is no stricter than the input's. We can use the alignment
- -- of the component type of an array if a type is an unpacked
- -- array type.
+ -- alignment is no stricter than the input's. We can use the component
+ -- type alignement for an array if a type is an unpacked array type.
if Present (Alignment_Clause (Otyp)) then
Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
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.
+ -- 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.
+ -- 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);
Asn :=
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ent, Loc),
- Expression => New_Occurrence_Of (Standard_True, Loc));
+ Expression => Make_Integer_Literal (Loc, Uint_1));
if Nkind (Parent (N)) = N_Subunit then
Insert_After (Corresponding_Stub (Parent (N)), Asn);
declare
CS : constant Boolean := Comes_From_Source (N);
begin
- Rewrite (N, Make_Identifier (Sloc (N), Chars => Chars (E)));
+ Rewrite (N, Make_Identifier (Sloc (N), Chars (E)));
Set_Entity (N, E);
Set_Comes_From_Source (N, CS);
Set_Analyzed (N, True);
-- False op False = False, and True op True = True. For the XOR case,
-- see Silly_Boolean_Array_Xor_Test.
- -- Believe it or not, this was reported as a bug. Note that nearly
- -- always, the test will evaluate statically to False, so the code will
- -- be statically removed, and no extra overhead caused.
+ -- Believe it or not, this was reported as a bug. Note that nearly always,
+ -- the test will evaluate statically to False, so the code will be
+ -- statically removed, and no extra overhead caused.
procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
--------------------------
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!)
+ -- 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
- -- function is called (we don't want to compute it more than once)
+ -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function
+ -- 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 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.
+ -- 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 --
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 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))
OSDN Git Service
