-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Atag; use Exp_Atag;
+with Exp_Ch2; use Exp_Ch2;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
- function Current_Unit_First_Declaration return Node_Id;
- -- Return the current unit's first declaration. If the declaration list is
- -- empty, the routine generates a null statement and returns it.
-
- function Current_Unit_Scope return Entity_Id;
- -- Return the scope of the current unit. If the current unit is a body,
- -- return the scope of the spec.
+ function Current_Anonymous_Master return Entity_Id;
+ -- Return the entity of the heterogeneous finalization master belonging to
+ -- the current unit (either function, package or procedure). This master
+ -- services all anonymous access-to-controlled types. If the current unit
+ -- does not have such master, create one.
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
procedure Expand_Short_Circuit_Operator (N : Node_Id);
-- Common expansion processing for short-circuit boolean operators
+ procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id);
+ -- Deal with comparison in MINIMIZED/ELIMINATED overflow mode. This is
+ -- where we allow comparison of "out of range" values.
+
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
-- Local recursive function used to expand equality for nested composite
-- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
-- to attach bodies of local functions that are created in the process.
- -- This is the responsibility of the caller to insert those bodies at the
+ -- It is the responsibility of the caller to insert those bodies at the
-- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
-- are the left and right sides for the comparison, and Typ is the type of
- -- the arrays to compare.
+ -- the objects to compare.
procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
-- Routine to expand concatenation of a sequence of two or more operands
-- concatenation. The operands can be of any appropriate type, and can
-- include both arrays and singleton elements.
+ procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id);
+ -- N is an N_In membership test mode, with the overflow check mode set to
+ -- MINIMIZED or ELIMINATED, and the type of the left operand is a signed
+ -- integer type. This is a case where top level processing is required to
+ -- handle overflow checks in subtrees.
+
procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
-- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
-- fixed. We do not have such a type at runtime, so the purpose of this
-- constrained type (the caller has ensured this by using
-- Convert_To_Actual_Subtype if necessary).
+ function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean;
+ -- For signed arithmetic operations when the current overflow mode is
+ -- MINIMIZED or ELIMINATED, we must call Apply_Arithmetic_Overflow_Checks
+ -- as the first thing we do. We then return. We count on the recursive
+ -- apparatus for overflow checks to call us back with an equivalent
+ -- operation that is in CHECKED mode, avoiding a recursive entry into this
+ -- routine, and that is when we will proceed with the expansion of the
+ -- operator (e.g. converting X+0 to X, or X**2 to X*X). We cannot do
+ -- these optimizations without first making this check, since there may be
+ -- operands further down the tree that are relying on the recursive calls
+ -- triggered by the top level nodes to properly process overflow checking
+ -- and remaining expansion on these nodes. Note that this call back may be
+ -- skipped if the operation is done in Bignum mode but that's fine, since
+ -- the Bignum call takes care of everything.
+
procedure Optimize_Length_Comparison (N : Node_Id);
-- Given an expression, if it is of the form X'Length op N (or the other
-- way round), where N is known at compile time to be 0 or 1, and X is a
return;
end Build_Boolean_Array_Proc_Call;
- ------------------------------------
- -- Current_Unit_First_Declaration --
- ------------------------------------
+ ------------------------------
+ -- Current_Anonymous_Master --
+ ------------------------------
- function Current_Unit_First_Declaration return Node_Id is
- Sem_U : Node_Id := Unit (Cunit (Current_Sem_Unit));
- Decl : Node_Id;
- Decls : List_Id;
+ function Current_Anonymous_Master return Entity_Id is
+ Decls : List_Id;
+ Loc : Source_Ptr;
+ Subp_Body : Node_Id;
+ Unit_Decl : Node_Id;
+ Unit_Id : Entity_Id;
begin
- if Nkind (Sem_U) = N_Package_Declaration then
- Sem_U := Specification (Sem_U);
- Decls := Visible_Declarations (Sem_U);
+ Unit_Id := Cunit_Entity (Current_Sem_Unit);
+
+ -- Find the entity of the current unit
+
+ if Ekind (Unit_Id) = E_Subprogram_Body then
+
+ -- When processing subprogram bodies, the proper scope is always that
+ -- of the spec.
+
+ Subp_Body := Unit_Id;
+ while Present (Subp_Body)
+ and then Nkind (Subp_Body) /= N_Subprogram_Body
+ loop
+ Subp_Body := Parent (Subp_Body);
+ end loop;
+
+ Unit_Id := Corresponding_Spec (Subp_Body);
+ end if;
+
+ Loc := Sloc (Unit_Id);
+ Unit_Decl := Unit (Cunit (Current_Sem_Unit));
+
+ -- Find the declarations list of the current unit
+
+ if Nkind (Unit_Decl) = N_Package_Declaration then
+ Unit_Decl := Specification (Unit_Decl);
+ Decls := Visible_Declarations (Unit_Decl);
if No (Decls) then
- Decl := Make_Null_Statement (Sloc (Sem_U));
- Decls := New_List (Decl);
- Set_Visible_Declarations (Sem_U, Decls);
+ Decls := New_List (Make_Null_Statement (Loc));
+ Set_Visible_Declarations (Unit_Decl, Decls);
elsif Is_Empty_List (Decls) then
- Decl := Make_Null_Statement (Sloc (Sem_U));
- Append_To (Decls, Decl);
-
- else
- Decl := First (Decls);
+ Append_To (Decls, Make_Null_Statement (Loc));
end if;
else
- Decls := Declarations (Sem_U);
+ Decls := Declarations (Unit_Decl);
if No (Decls) then
- Decl := Make_Null_Statement (Sloc (Sem_U));
- Decls := New_List (Decl);
- Set_Declarations (Sem_U, Decls);
+ Decls := New_List (Make_Null_Statement (Loc));
+ Set_Declarations (Unit_Decl, Decls);
elsif Is_Empty_List (Decls) then
- Decl := Make_Null_Statement (Sloc (Sem_U));
- Append_To (Decls, Decl);
-
- else
- Decl := First (Decls);
+ Append_To (Decls, Make_Null_Statement (Loc));
end if;
end if;
- return Decl;
- end Current_Unit_First_Declaration;
+ -- The current unit has an existing anonymous master, traverse its
+ -- declarations and locate the entity.
- ------------------------
- -- Current_Unit_Scope --
- ------------------------
+ if Has_Anonymous_Master (Unit_Id) then
+ declare
+ Decl : Node_Id;
+ Fin_Mas_Id : Entity_Id;
- function Current_Unit_Scope return Entity_Id is
- Scop_Id : Entity_Id := Cunit_Entity (Current_Sem_Unit);
- Subp_Bod : Node_Id;
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
- begin
- if Ekind (Scop_Id) = E_Subprogram_Body then
+ -- Look for the first variable in the declarations whole type
+ -- is Finalization_Master.
- -- When processing subprogram bodies, the proper scope is always
- -- that of the spec.
+ if Nkind (Decl) = N_Object_Declaration then
+ Fin_Mas_Id := Defining_Identifier (Decl);
- Subp_Bod := Scop_Id;
- while Present (Subp_Bod)
- and then Nkind (Subp_Bod) /= N_Subprogram_Body
- loop
- Subp_Bod := Parent (Subp_Bod);
- end loop;
+ if Ekind (Fin_Mas_Id) = E_Variable
+ and then Etype (Fin_Mas_Id) = RTE (RE_Finalization_Master)
+ then
+ return Fin_Mas_Id;
+ end if;
+ end if;
- Scop_Id := Corresponding_Spec (Subp_Bod);
- end if;
+ Next (Decl);
+ end loop;
+
+ -- The master was not found even though the unit was labeled as
+ -- having one.
+
+ raise Program_Error;
+ end;
+
+ -- Create a new anonymous master
+
+ else
+ declare
+ First_Decl : constant Node_Id := First (Decls);
+ Action : Node_Id;
+ Fin_Mas_Id : Entity_Id;
+
+ begin
+ -- Since the master and its associated initialization is inserted
+ -- at top level, use the scope of the unit when analyzing.
+
+ Push_Scope (Unit_Id);
+
+ -- Create the finalization master
+
+ Fin_Mas_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Unit_Id), "AM"));
+
+ -- Generate:
+ -- <Fin_Mas_Id> : Finalization_Master;
+
+ Action :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Fin_Mas_Id,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Finalization_Master), Loc));
+
+ Insert_Before_And_Analyze (First_Decl, Action);
+
+ -- Mark the unit to prevent the generation of multiple masters
+
+ Set_Has_Anonymous_Master (Unit_Id);
+
+ -- Do not set the base pool and mode of operation on .NET/JVM
+ -- since those targets do not support pools and all VM masters
+ -- are heterogeneous by default.
+
+ if VM_Target = No_VM then
+
+ -- Generate:
+ -- Set_Base_Pool
+ -- (<Fin_Mas_Id>, Global_Pool_Object'Unrestricted_Access);
+
+ Action :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Set_Base_Pool), Loc),
- return Scop_Id;
- end Current_Unit_Scope;
+ Parameter_Associations => New_List (
+ New_Reference_To (Fin_Mas_Id, Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Reference_To (RTE (RE_Global_Pool_Object), Loc),
+ Attribute_Name => Name_Unrestricted_Access)));
+
+ Insert_Before_And_Analyze (First_Decl, Action);
+
+ -- Generate:
+ -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
+
+ Action :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Set_Is_Heterogeneous), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (Fin_Mas_Id, Loc)));
+
+ Insert_Before_And_Analyze (First_Decl, Action);
+ end if;
+
+ -- Restore the original state of the scope stack
+
+ Pop_Scope;
+
+ return Fin_Mas_Id;
+ end;
+ end if;
+ end Current_Anonymous_Master;
--------------------------------
-- Displace_Allocator_Pointer --
-- 1) Get access to the allocated object
Rewrite (N,
- Make_Explicit_Dereference (Loc,
- Relocate_Node (N)));
+ Make_Explicit_Dereference (Loc, Relocate_Node (N)));
Set_Etype (N, Etyp);
Set_Analyzed (N);
-- Ada 2005 (AI-344): For an allocator with a class-wide designated
-- type, generate an accessibility check to verify that the level of the
-- type of the created object is not deeper than the level of the access
- -- type. If the type of the qualified expression is class- wide, then
+ -- type. If the type of the qualified expression is class-wide, then
-- always generate the check (except in the case where it is known to be
-- unnecessary, see comment below). Otherwise, only generate the check
-- if the level of the qualified expression type is statically deeper
(Ref : Node_Id;
Built_In_Place : Boolean := False)
is
- New_Node : Node_Id;
+ Pool_Id : constant Entity_Id := Associated_Storage_Pool (PtrT);
+ Cond : Node_Id;
+ Free_Stmt : Node_Id;
+ Obj_Ref : Node_Id;
+ Stmts : List_Id;
begin
if Ada_Version >= Ada_2005
and then Is_Class_Wide_Type (DesigT)
- and then not Scope_Suppress (Accessibility_Check)
+ and then not Scope_Suppress.Suppress (Accessibility_Check)
and then
(Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
or else
(Is_Class_Wide_Type (Etype (Exp))
and then Scope (PtrT) /= Current_Scope))
+ and then (Tagged_Type_Expansion or else VM_Target /= No_VM)
then
- -- If the allocator was built in place Ref is already a reference
+ -- If the allocator was built in place, Ref is already a reference
-- to the access object initialized to the result of the allocator
- -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
- -- it is the entity associated with the object containing the
- -- address of the allocated object.
+ -- (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). We call
+ -- Remove_Side_Effects for cases where the build-in-place call may
+ -- still be the prefix of the reference (to avoid generating
+ -- duplicate calls). Otherwise, it is the entity associated with
+ -- the object containing the address of the allocated object.
if Built_In_Place then
- New_Node := New_Copy (Ref);
+ Remove_Side_Effects (Ref);
+ Obj_Ref := New_Copy (Ref);
else
- New_Node := New_Reference_To (Ref, Loc);
+ Obj_Ref := New_Reference_To (Ref, Loc);
end if;
- New_Node :=
+ -- Step 1: Create the object clean up code
+
+ Stmts := New_List;
+
+ -- Create an explicit free statement to clean up the allocated
+ -- object in case the accessibility check fails. Generate:
+
+ -- Free (Obj_Ref);
+
+ Free_Stmt := Make_Free_Statement (Loc, New_Copy (Obj_Ref));
+ Set_Storage_Pool (Free_Stmt, Pool_Id);
+
+ Append_To (Stmts, Free_Stmt);
+
+ -- Finalize the object (if applicable), but wrap the call inside
+ -- a block to ensure that the object would still be deallocated in
+ -- case the finalization fails. Generate:
+
+ -- begin
+ -- [Deep_]Finalize (Obj_Ref.all);
+ -- exception
+ -- when others =>
+ -- Free (Obj_Ref);
+ -- raise;
+ -- end;
+
+ if Needs_Finalization (DesigT) then
+ Prepend_To (Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Copy (Obj_Ref)),
+ Typ => DesigT)),
+
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (
+ New_Copy_Tree (Free_Stmt),
+ Make_Raise_Statement (Loc)))))));
+ end if;
+
+ -- Signal the accessibility failure through a Program_Error
+
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc,
+ Condition => New_Reference_To (Standard_True, Loc),
+ Reason => PE_Accessibility_Check_Failed));
+
+ -- Step 2: Create the accessibility comparison
+
+ -- Generate:
+ -- Ref'Tag
+
+ Obj_Ref :=
Make_Attribute_Reference (Loc,
- Prefix => New_Node,
+ Prefix => Obj_Ref,
Attribute_Name => Name_Tag);
+ -- For tagged types, determine the accessibility level by looking
+ -- at the type specific data of the dispatch table. Generate:
+
+ -- Type_Specific_Data (Address (Ref'Tag)).Access_Level
+
if Tagged_Type_Expansion then
- New_Node := Build_Get_Access_Level (Loc, New_Node);
+ Cond := Build_Get_Access_Level (Loc, Obj_Ref);
- elsif VM_Target /= No_VM then
- New_Node :=
- Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (RE_Get_Access_Level), Loc),
- Parameter_Associations => New_List (New_Node));
+ -- Use a runtime call to determine the accessibility level when
+ -- compiling on virtual machine targets. Generate:
- -- Cannot generate the runtime check
+ -- Get_Access_Level (Ref'Tag)
else
- return;
+ Cond :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Get_Access_Level), Loc),
+ Parameter_Associations => New_List (Obj_Ref));
end if;
+ Cond :=
+ Make_Op_Gt (Loc,
+ Left_Opnd => Cond,
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Type_Access_Level (PtrT)));
+
+ -- Due to the complexity and side effects of the check, utilize an
+ -- if statement instead of the regular Program_Error circuitry.
+
Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => New_Node,
- Right_Opnd =>
- Make_Integer_Literal (Loc, Type_Access_Level (PtrT))),
- Reason => PE_Accessibility_Check_Failed));
+ Make_If_Statement (Loc,
+ Condition => Cond,
+ Then_Statements => Stmts));
end if;
end Apply_Accessibility_Check;
-- Start of processing for Expand_Allocator_Expression
begin
- if Is_Tagged_Type (T)
- or else Needs_Finalization (T)
- then
- if Is_CPP_Constructor_Call (Exp) then
-
- -- Generate:
- -- Pnnn : constant ptr_T := new (T);
- -- Init (Pnnn.all,...);
+ -- Handle call to C++ constructor
- -- Allocate the object without an expression
-
- Node := Relocate_Node (N);
- Set_Expression (Node, New_Reference_To (Etype (Exp), Loc));
-
- -- Avoid its expansion to avoid generating a call to the default
- -- C++ constructor.
-
- Set_Analyzed (Node);
-
- Temp := Make_Temporary (Loc, 'P', N);
+ if Is_CPP_Constructor_Call (Exp) then
+ Make_CPP_Constructor_Call_In_Allocator
+ (Allocator => N,
+ Function_Call => Exp);
+ return;
+ end if;
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Constant_Present => True,
- Object_Definition => New_Reference_To (PtrT, Loc),
- Expression => Node);
- Insert_Action (N, Temp_Decl);
+ -- In the case of an Ada 2012 allocator whose initial value comes from a
+ -- function call, pass "the accessibility level determined by the point
+ -- of call" (AI05-0234) to the function. Conceptually, this belongs in
+ -- Expand_Call but it couldn't be done there (because the Etype of the
+ -- allocator wasn't set then) so we generate the parameter here. See
+ -- the Boolean variable Defer in (a block within) Expand_Call.
- Apply_Accessibility_Check (Temp);
+ if Ada_Version >= Ada_2012 and then Nkind (Exp) = N_Function_Call then
+ declare
+ Subp : Entity_Id;
- -- Locate the enclosing list and insert the C++ constructor call
+ begin
+ if Nkind (Name (Exp)) = N_Explicit_Dereference then
+ Subp := Designated_Type (Etype (Prefix (Name (Exp))));
+ else
+ Subp := Entity (Name (Exp));
+ end if;
- declare
- P : Node_Id;
+ Subp := Ultimate_Alias (Subp);
- begin
- P := Parent (Node);
- while not Is_List_Member (P) loop
- P := Parent (P);
- end loop;
+ if Present (Extra_Accessibility_Of_Result (Subp)) then
+ Add_Extra_Actual_To_Call
+ (Subprogram_Call => Exp,
+ Extra_Formal => Extra_Accessibility_Of_Result (Subp),
+ Extra_Actual => Dynamic_Accessibility_Level (PtrT));
+ end if;
+ end;
+ end if;
- Insert_List_After_And_Analyze (P,
- Build_Initialization_Call (Loc,
- Id_Ref =>
- Make_Explicit_Dereference (Loc,
- Prefix => New_Reference_To (Temp, Loc)),
- Typ => Etype (Exp),
- Constructor_Ref => Exp));
- end;
+ -- Case of tagged type or type requiring finalization
- Rewrite (N, New_Reference_To (Temp, Loc));
- Analyze_And_Resolve (N, PtrT);
- return;
- end if;
+ if Is_Tagged_Type (T) or else Needs_Finalization (T) then
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Null_Exclusion_Present => False,
- Constant_Present => False,
+ Constant_Present =>
+ Is_Access_Constant (Etype (N)),
Subtype_Indication =>
New_Reference_To (Etype (Exp), Loc)));
-- Generate:
-- Set_Finalize_Address (<PtrT>FM, <T>FD'Unrestricted_Access);
- -- Since .NET/JVM compilers do not support address arithmetic,
- -- this call is skipped. The same is done for CodePeer because
- -- primitive Finalize_Address is never generated.
+ -- Do not generate this call in the following cases:
+
+ -- * .NET/JVM - these targets do not support address arithmetic
+ -- and unchecked conversion, key elements of Finalize_Address.
+
+ -- * Alfa mode - the call is useless and results in unwanted
+ -- expansion.
+
+ -- * CodePeer mode - TSS primitive Finalize_Address is not
+ -- created in this mode.
if VM_Target = No_VM
+ and then not Alfa_Mode
and then not CodePeer_Mode
and then Present (Finalization_Master (PtrT))
+ and then Present (Temp_Decl)
+ and then Nkind (Expression (Temp_Decl)) = N_Allocator
then
Insert_Action (N,
Make_Set_Finalize_Address_Call
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
+
else
+ Build_Allocate_Deallocate_Proc (N, True);
+
-- If we have:
-- type A is access T1;
-- X : A := new T2'(...);
end;
end Expand_Boolean_Operator;
+ ------------------------------------------------
+ -- Expand_Compare_Minimize_Eliminate_Overflow --
+ ------------------------------------------------
+
+ procedure Expand_Compare_Minimize_Eliminate_Overflow (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Result_Type : constant Entity_Id := Etype (N);
+ -- Capture result type (could be a derived boolean type)
+
+ Llo, Lhi : Uint;
+ Rlo, Rhi : Uint;
+
+ LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
+ -- Entity for Long_Long_Integer'Base
+
+ Check : constant Overflow_Mode_Type := Overflow_Check_Mode;
+ -- Current overflow checking mode
+
+ procedure Set_True;
+ procedure Set_False;
+ -- These procedures rewrite N with an occurrence of Standard_True or
+ -- Standard_False, and then makes a call to Warn_On_Known_Condition.
+
+ ---------------
+ -- Set_False --
+ ---------------
+
+ procedure Set_False is
+ begin
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ Warn_On_Known_Condition (N);
+ end Set_False;
+
+ --------------
+ -- Set_True --
+ --------------
+
+ procedure Set_True is
+ begin
+ Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
+ Warn_On_Known_Condition (N);
+ end Set_True;
+
+ -- Start of processing for Expand_Compare_Minimize_Eliminate_Overflow
+
+ begin
+ -- Nothing to do unless we have a comparison operator with operands
+ -- that are signed integer types, and we are operating in either
+ -- MINIMIZED or ELIMINATED overflow checking mode.
+
+ if Nkind (N) not in N_Op_Compare
+ or else Check not in Minimized_Or_Eliminated
+ or else not Is_Signed_Integer_Type (Etype (Left_Opnd (N)))
+ then
+ return;
+ end if;
+
+ -- OK, this is the case we are interested in. First step is to process
+ -- our operands using the Minimize_Eliminate circuitry which applies
+ -- this processing to the two operand subtrees.
+
+ Minimize_Eliminate_Overflows
+ (Left_Opnd (N), Llo, Lhi, Top_Level => False);
+ Minimize_Eliminate_Overflows
+ (Right_Opnd (N), Rlo, Rhi, Top_Level => False);
+
+ -- See if the range information decides the result of the comparison.
+ -- We can only do this if we in fact have full range information (which
+ -- won't be the case if either operand is bignum at this stage).
+
+ if Llo /= No_Uint and then Rlo /= No_Uint then
+ case N_Op_Compare (Nkind (N)) is
+ when N_Op_Eq =>
+ if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
+ Set_True;
+ elsif Llo > Rhi or else Lhi < Rlo then
+ Set_False;
+ end if;
+
+ when N_Op_Ge =>
+ if Llo >= Rhi then
+ Set_True;
+ elsif Lhi < Rlo then
+ Set_False;
+ end if;
+
+ when N_Op_Gt =>
+ if Llo > Rhi then
+ Set_True;
+ elsif Lhi <= Rlo then
+ Set_False;
+ end if;
+
+ when N_Op_Le =>
+ if Llo > Rhi then
+ Set_False;
+ elsif Lhi <= Rlo then
+ Set_True;
+ end if;
+
+ when N_Op_Lt =>
+ if Llo >= Rhi then
+ Set_False;
+ elsif Lhi < Rlo then
+ Set_True;
+ end if;
+
+ when N_Op_Ne =>
+ if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
+ Set_False;
+ elsif Llo > Rhi or else Lhi < Rlo then
+ Set_True;
+ end if;
+ end case;
+
+ -- All done if we did the rewrite
+
+ if Nkind (N) not in N_Op_Compare then
+ return;
+ end if;
+ end if;
+
+ -- Otherwise, time to do the comparison
+
+ declare
+ Ltype : constant Entity_Id := Etype (Left_Opnd (N));
+ Rtype : constant Entity_Id := Etype (Right_Opnd (N));
+
+ begin
+ -- If the two operands have the same signed integer type we are
+ -- all set, nothing more to do. This is the case where either
+ -- both operands were unchanged, or we rewrote both of them to
+ -- be Long_Long_Integer.
+
+ -- Note: Entity for the comparison may be wrong, but it's not worth
+ -- the effort to change it, since the back end does not use it.
+
+ if Is_Signed_Integer_Type (Ltype)
+ and then Base_Type (Ltype) = Base_Type (Rtype)
+ then
+ return;
+
+ -- Here if bignums are involved (can only happen in ELIMINATED mode)
+
+ elsif Is_RTE (Ltype, RE_Bignum) or else Is_RTE (Rtype, RE_Bignum) then
+ declare
+ Left : Node_Id := Left_Opnd (N);
+ Right : Node_Id := Right_Opnd (N);
+ -- Bignum references for left and right operands
+
+ begin
+ if not Is_RTE (Ltype, RE_Bignum) then
+ Left := Convert_To_Bignum (Left);
+ elsif not Is_RTE (Rtype, RE_Bignum) then
+ Right := Convert_To_Bignum (Right);
+ end if;
+
+ -- We rewrite our node with:
+
+ -- do
+ -- Bnn : Result_Type;
+ -- declare
+ -- M : Mark_Id := SS_Mark;
+ -- begin
+ -- Bnn := Big_xx (Left, Right); (xx = EQ, NT etc)
+ -- SS_Release (M);
+ -- end;
+ -- in
+ -- Bnn
+ -- end
+
+ declare
+ Blk : constant Node_Id := Make_Bignum_Block (Loc);
+ Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+ Ent : RE_Id;
+
+ begin
+ case N_Op_Compare (Nkind (N)) is
+ when N_Op_Eq => Ent := RE_Big_EQ;
+ when N_Op_Ge => Ent := RE_Big_GE;
+ when N_Op_Gt => Ent := RE_Big_GT;
+ when N_Op_Le => Ent := RE_Big_LE;
+ when N_Op_Lt => Ent := RE_Big_LT;
+ when N_Op_Ne => Ent := RE_Big_NE;
+ end case;
+
+ -- Insert assignment to Bnn into the bignum block
+
+ Insert_Before
+ (First (Statements (Handled_Statement_Sequence (Blk))),
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (Ent), Loc),
+ Parameter_Associations => New_List (Left, Right))));
+
+ -- Now do the rewrite with expression actions
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Bnn,
+ Object_Definition =>
+ New_Occurrence_Of (Result_Type, Loc)),
+ Blk),
+ Expression => New_Occurrence_Of (Bnn, Loc)));
+ Analyze_And_Resolve (N, Result_Type);
+ end;
+ end;
+
+ -- No bignums involved, but types are different, so we must have
+ -- rewritten one of the operands as a Long_Long_Integer but not
+ -- the other one.
+
+ -- If left operand is Long_Long_Integer, convert right operand
+ -- and we are done (with a comparison of two Long_Long_Integers).
+
+ elsif Ltype = LLIB then
+ Convert_To_And_Rewrite (LLIB, Right_Opnd (N));
+ Analyze_And_Resolve (Right_Opnd (N), LLIB, Suppress => All_Checks);
+ return;
+
+ -- If right operand is Long_Long_Integer, convert left operand
+ -- and we are done (with a comparison of two Long_Long_Integers).
+
+ -- This is the only remaining possibility
+
+ else pragma Assert (Rtype = LLIB);
+ Convert_To_And_Rewrite (LLIB, Left_Opnd (N));
+ Analyze_And_Resolve (Left_Opnd (N), LLIB, Suppress => All_Checks);
+ return;
+ end if;
+ end;
+ end Expand_Compare_Minimize_Eliminate_Overflow;
+
-------------------------------
-- Expand_Composite_Equality --
-------------------------------
end if;
end if;
- elsif Ada_Version >= Ada_2012 then
+ -- Equality composes in Ada 2012 for untagged record types. It also
+ -- composes for bounded strings, because they are part of the
+ -- predefined environment. We could make it compose for bounded
+ -- strings by making them tagged, or by making sure all subcomponents
+ -- are set to the same value, even when not used. Instead, we have
+ -- this special case in the compiler, because it's more efficient.
+
+ elsif Ada_Version >= Ada_2012 or else Is_Bounded_String (Typ) then
-- if no TSS has been created for the type, check whether there is
-- a primitive equality declared for it.
declare
- Ada_2012_Op : constant Node_Id := Find_Primitive_Eq;
+ Op : constant Node_Id := Find_Primitive_Eq;
begin
- if Present (Ada_2012_Op) then
- return Ada_2012_Op;
- else
-
- -- Use predefined equality if no user-defined primitive exists
+ -- Use user-defined primitive if it exists, otherwise use
+ -- predefined equality.
+ if Present (Op) then
+ return Op;
+ else
return Make_Op_Eq (Loc, Lhs, Rhs);
end if;
end;
-- This is either an integer literal node, or an identifier reference to
-- a constant entity initialized to the appropriate value.
+ Last_Opnd_Low_Bound : Node_Id;
+ -- A tree node representing the low bound of the last operand. This
+ -- need only be set if the result could be null. It is used for the
+ -- special case of setting the right low bound for a null result.
+ -- This is of type Ityp.
+
Last_Opnd_High_Bound : Node_Id;
-- A tree node representing the high bound of the last operand. This
-- need only be set if the result could be null. It is used for the
-- Result of the concatenation (of type Ityp)
Actions : constant List_Id := New_List;
- -- Collect actions to be inserted if Save_Space is False
-
- Save_Space : Boolean;
- pragma Warnings (Off, Save_Space);
- -- Set to True if we are saving generated code space by calling routines
- -- in packages System.Concat_n.
+ -- Collect actions to be inserted
Known_Non_Null_Operand_Seen : Boolean;
-- Set True during generation of the assignments of operands into
Result_May_Be_Null := False;
end if;
- -- Capture last operand high bound if result could be null
+ -- Capture last operand low and high bound if result could be null
if J = N and then Result_May_Be_Null then
+ Last_Opnd_Low_Bound :=
+ New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
+
Last_Opnd_High_Bound :=
- Make_Op_Add (Loc,
+ Make_Op_Subtract (Loc,
Left_Opnd =>
New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
Right_Opnd => Make_Integer_Literal (Loc, 1));
Result_May_Be_Null := False;
end if;
- -- Capture last operand bound if result could be null
+ -- Capture last operand bounds if result could be null
if J = N and then Result_May_Be_Null then
+ Last_Opnd_Low_Bound :=
+ Convert_To (Ityp,
+ Make_Integer_Literal (Loc, Expr_Value (Lo)));
+
Last_Opnd_High_Bound :=
Convert_To (Ityp,
Make_Integer_Literal (Loc, Expr_Value (Hi)));
Prefix =>
Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_First);
+ Set_Parent (Opnd_Low_Bound (NN), Opnd);
+
+ -- Capture last operand bounds if result could be null
if J = N and Result_May_Be_Null then
+ Last_Opnd_Low_Bound :=
+ Convert_To (Ityp,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr (Opnd, Name_Req => True),
+ Attribute_Name => Name_First));
+ Set_Parent (Last_Opnd_Low_Bound, Opnd);
+
Last_Opnd_High_Bound :=
Convert_To (Ityp,
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (Opnd, Name_Req => True),
Attribute_Name => Name_Last));
+ Set_Parent (Last_Opnd_High_Bound, Opnd);
end if;
-- Capture length of operand in entity
Low_Bound := Opnd_Low_Bound (1);
-- OK, we don't know the lower bound, we have to build a horrible
- -- expression actions node of the form
+ -- if expression node of the form
-- if Cond1'Length /= 0 then
-- Opnd1 low bound
else
return
- Make_Conditional_Expression (Loc,
+ Make_If_Expression (Loc,
Expressions => New_List (
Make_Op_Ne (Loc,
-- bounds if the last operand is super-flat).
if Result_May_Be_Null then
+ Low_Bound :=
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Copy (Aggr_Length (NN)),
+ Right_Opnd => Make_Artyp_Literal (0)),
+ Last_Opnd_Low_Bound,
+ Low_Bound));
+
High_Bound :=
- Make_Conditional_Expression (Loc,
+ Make_If_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => New_Copy (Aggr_Length (NN)),
Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
Apply_Compile_Time_Constraint_Error
(N => Cnode,
- Msg => "concatenation result upper bound out of range?",
+ Msg => "concatenation result upper bound out of range??",
Reason => CE_Range_Check_Failed);
- -- Set_Etype (Cnode, Atyp);
end Expand_Concatenate;
- ------------------------
- -- Expand_N_Allocator --
- ------------------------
+ ---------------------------------------------------
+ -- Expand_Membership_Minimize_Eliminate_Overflow --
+ ---------------------------------------------------
- procedure Expand_N_Allocator (N : Node_Id) is
- PtrT : constant Entity_Id := Etype (N);
- Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
- Etyp : constant Entity_Id := Etype (Expression (N));
- Loc : constant Source_Ptr := Sloc (N);
- Desig : Entity_Id;
- Nod : Node_Id;
- Pool : Entity_Id;
- Temp : Entity_Id;
+ procedure Expand_Membership_Minimize_Eliminate_Overflow (N : Node_Id) is
+ pragma Assert (Nkind (N) = N_In);
+ -- Despite the name, this routine applies only to N_In, not to
+ -- N_Not_In. The latter is always rewritten as not (X in Y).
- procedure Rewrite_Coextension (N : Node_Id);
- -- Static coextensions have the same lifetime as the entity they
- -- constrain. Such occurrences can be rewritten as aliased objects
- -- and their unrestricted access used instead of the coextension.
+ Result_Type : constant Entity_Id := Etype (N);
+ -- Capture result type, may be a derived boolean type
- function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
- -- Given a constrained array type E, returns a node representing the
- -- code to compute the size in storage elements for the given type.
- -- This is done without using the attribute (which malfunctions for
+ Loc : constant Source_Ptr := Sloc (N);
+ Lop : constant Node_Id := Left_Opnd (N);
+ Rop : constant Node_Id := Right_Opnd (N);
+
+ -- Note: there are many referencs to Etype (Lop) and Etype (Rop). It
+ -- is thus tempting to capture these values, but due to the rewrites
+ -- that occur as a result of overflow checking, these values change
+ -- as we go along, and it is safe just to always use Etype explicitly.
+
+ Restype : constant Entity_Id := Etype (N);
+ -- Save result type
+
+ Lo, Hi : Uint;
+ -- Bounds in Minimize calls, not used currently
+
+ LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
+ -- Entity for Long_Long_Integer'Base (Standard should export this???)
+
+ begin
+ Minimize_Eliminate_Overflows (Lop, Lo, Hi, Top_Level => False);
+
+ -- If right operand is a subtype name, and the subtype name has no
+ -- predicate, then we can just replace the right operand with an
+ -- explicit range T'First .. T'Last, and use the explicit range code.
+
+ if Nkind (Rop) /= N_Range
+ and then No (Predicate_Function (Etype (Rop)))
+ then
+ declare
+ Rtyp : constant Entity_Id := Etype (Rop);
+ begin
+ Rewrite (Rop,
+ Make_Range (Loc,
+ Low_Bound =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Reference_To (Rtyp, Loc)),
+ High_Bound =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix => New_Reference_To (Rtyp, Loc))));
+ Analyze_And_Resolve (Rop, Rtyp, Suppress => All_Checks);
+ end;
+ end if;
+
+ -- Here for the explicit range case. Note that the bounds of the range
+ -- have not been processed for minimized or eliminated checks.
+
+ if Nkind (Rop) = N_Range then
+ Minimize_Eliminate_Overflows
+ (Low_Bound (Rop), Lo, Hi, Top_Level => False);
+ Minimize_Eliminate_Overflows
+ (High_Bound (Rop), Lo, Hi, Top_Level => False);
+
+ -- We have A in B .. C, treated as A >= B and then A <= C
+
+ -- Bignum case
+
+ if Is_RTE (Etype (Lop), RE_Bignum)
+ or else Is_RTE (Etype (Low_Bound (Rop)), RE_Bignum)
+ or else Is_RTE (Etype (High_Bound (Rop)), RE_Bignum)
+ then
+ declare
+ Blk : constant Node_Id := Make_Bignum_Block (Loc);
+ Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+ L : constant Entity_Id :=
+ Make_Defining_Identifier (Loc, Name_uL);
+ Lopnd : constant Node_Id := Convert_To_Bignum (Lop);
+ Lbound : constant Node_Id :=
+ Convert_To_Bignum (Low_Bound (Rop));
+ Hbound : constant Node_Id :=
+ Convert_To_Bignum (High_Bound (Rop));
+
+ -- Now we rewrite the membership test node to look like
+
+ -- do
+ -- Bnn : Result_Type;
+ -- declare
+ -- M : Mark_Id := SS_Mark;
+ -- L : Bignum := Lopnd;
+ -- begin
+ -- Bnn := Big_GE (L, Lbound) and then Big_LE (L, Hbound)
+ -- SS_Release (M);
+ -- end;
+ -- in
+ -- Bnn
+ -- end
+
+ begin
+ -- Insert declaration of L into declarations of bignum block
+
+ Insert_After
+ (Last (Declarations (Blk)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => L,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Bignum), Loc),
+ Expression => Lopnd));
+
+ -- Insert assignment to Bnn into expressions of bignum block
+
+ Insert_Before
+ (First (Statements (Handled_Statement_Sequence (Blk))),
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression =>
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Big_GE), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (L, Loc),
+ Lbound)),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Big_LE), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (L, Loc),
+ Hbound)))));
+
+ -- Now rewrite the node
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Bnn,
+ Object_Definition =>
+ New_Occurrence_Of (Result_Type, Loc)),
+ Blk),
+ Expression => New_Occurrence_Of (Bnn, Loc)));
+ Analyze_And_Resolve (N, Result_Type);
+ return;
+ end;
+
+ -- Here if no bignums around
+
+ else
+ -- Case where types are all the same
+
+ if Base_Type (Etype (Lop)) = Base_Type (Etype (Low_Bound (Rop)))
+ and then
+ Base_Type (Etype (Lop)) = Base_Type (Etype (High_Bound (Rop)))
+ then
+ null;
+
+ -- If types are not all the same, it means that we have rewritten
+ -- at least one of them to be of type Long_Long_Integer, and we
+ -- will convert the other operands to Long_Long_Integer.
+
+ else
+ Convert_To_And_Rewrite (LLIB, Lop);
+ Set_Analyzed (Lop, False);
+ Analyze_And_Resolve (Lop, LLIB);
+
+ -- For the right operand, avoid unnecessary recursion into
+ -- this routine, we know that overflow is not possible.
+
+ Convert_To_And_Rewrite (LLIB, Low_Bound (Rop));
+ Convert_To_And_Rewrite (LLIB, High_Bound (Rop));
+ Set_Analyzed (Rop, False);
+ Analyze_And_Resolve (Rop, LLIB, Suppress => Overflow_Check);
+ end if;
+
+ -- Now the three operands are of the same signed integer type,
+ -- so we can use the normal expansion routine for membership,
+ -- setting the flag to prevent recursion into this procedure.
+
+ Set_No_Minimize_Eliminate (N);
+ Expand_N_In (N);
+ end if;
+
+ -- Right operand is a subtype name and the subtype has a predicate. We
+ -- have to make sure the predicate is checked, and for that we need to
+ -- use the standard N_In circuitry with appropriate types.
+
+ else
+ pragma Assert (Present (Predicate_Function (Etype (Rop))));
+
+ -- If types are "right", just call Expand_N_In preventing recursion
+
+ if Base_Type (Etype (Lop)) = Base_Type (Etype (Rop)) then
+ Set_No_Minimize_Eliminate (N);
+ Expand_N_In (N);
+
+ -- Bignum case
+
+ elsif Is_RTE (Etype (Lop), RE_Bignum) then
+
+ -- For X in T, we want to rewrite our node as
+
+ -- do
+ -- Bnn : Result_Type;
+
+ -- declare
+ -- M : Mark_Id := SS_Mark;
+ -- Lnn : Long_Long_Integer'Base
+ -- Nnn : Bignum;
+
+ -- begin
+ -- Nnn := X;
+
+ -- if not Bignum_In_LLI_Range (Nnn) then
+ -- Bnn := False;
+ -- else
+ -- Lnn := From_Bignum (Nnn);
+ -- Bnn :=
+ -- Lnn in LLIB (T'Base'First) .. LLIB (T'Base'Last)
+ -- and then T'Base (Lnn) in T;
+ -- end if;
+ --
+ -- SS_Release (M);
+ -- end
+ -- in
+ -- Bnn
+ -- end
+
+ -- A bit gruesome, but there doesn't seem to be a simpler way
+
+ declare
+ Blk : constant Node_Id := Make_Bignum_Block (Loc);
+ Bnn : constant Entity_Id := Make_Temporary (Loc, 'B', N);
+ Lnn : constant Entity_Id := Make_Temporary (Loc, 'L', N);
+ Nnn : constant Entity_Id := Make_Temporary (Loc, 'N', N);
+ T : constant Entity_Id := Etype (Rop);
+ TB : constant Entity_Id := Base_Type (T);
+ Nin : Node_Id;
+
+ begin
+ -- Mark the last membership operation to prevent recursion
+
+ Nin :=
+ Make_In (Loc,
+ Left_Opnd => Convert_To (TB, New_Occurrence_Of (Lnn, Loc)),
+ Right_Opnd => New_Occurrence_Of (T, Loc));
+ Set_No_Minimize_Eliminate (Nin);
+
+ -- Now decorate the block
+
+ Insert_After
+ (Last (Declarations (Blk)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Lnn,
+ Object_Definition => New_Occurrence_Of (LLIB, Loc)));
+
+ Insert_After
+ (Last (Declarations (Blk)),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Nnn,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Bignum), Loc)));
+
+ Insert_List_Before
+ (First (Statements (Handled_Statement_Sequence (Blk))),
+ New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Nnn, Loc),
+ Expression => Relocate_Node (Lop)),
+
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Bignum_In_LLI_Range), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Nnn, Loc)))),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression =>
+ New_Occurrence_Of (Standard_False, Loc))),
+
+ Else_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Lnn, Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Nnn, Loc)))),
+
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Bnn, Loc),
+ Expression =>
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_In (Loc,
+ Left_Opnd => New_Occurrence_Of (Lnn, Loc),
+ Right_Opnd =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Convert_To (LLIB,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix =>
+ New_Occurrence_Of (TB, Loc))),
+
+ High_Bound =>
+ Convert_To (LLIB,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix =>
+ New_Occurrence_Of (TB, Loc))))),
+
+ Right_Opnd => Nin))))));
+
+ -- Now we can do the rewrite
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Bnn,
+ Object_Definition =>
+ New_Occurrence_Of (Result_Type, Loc)),
+ Blk),
+ Expression => New_Occurrence_Of (Bnn, Loc)));
+ Analyze_And_Resolve (N, Result_Type);
+ return;
+ end;
+
+ -- Not bignum case, but types don't match (this means we rewrote the
+ -- left operand to be Long_Long_Integer).
+
+ else
+ pragma Assert (Base_Type (Etype (Lop)) = LLIB);
+
+ -- We rewrite the membership test as (where T is the type with
+ -- the predicate, i.e. the type of the right operand)
+
+ -- Lop in LLIB (T'Base'First) .. LLIB (T'Base'Last)
+ -- and then T'Base (Lop) in T
+
+ declare
+ T : constant Entity_Id := Etype (Rop);
+ TB : constant Entity_Id := Base_Type (T);
+ Nin : Node_Id;
+
+ begin
+ -- The last membership test is marked to prevent recursion
+
+ Nin :=
+ Make_In (Loc,
+ Left_Opnd => Convert_To (TB, Duplicate_Subexpr (Lop)),
+ Right_Opnd => New_Occurrence_Of (T, Loc));
+ Set_No_Minimize_Eliminate (Nin);
+
+ -- Now do the rewrite
+
+ Rewrite (N,
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_In (Loc,
+ Left_Opnd => Lop,
+ Right_Opnd =>
+ Make_Range (Loc,
+ Low_Bound =>
+ Convert_To (LLIB,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix => New_Occurrence_Of (TB, Loc))),
+ High_Bound =>
+ Convert_To (LLIB,
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix => New_Occurrence_Of (TB, Loc))))),
+ Right_Opnd => Nin));
+ Set_Analyzed (N, False);
+ Analyze_And_Resolve (N, Restype);
+ end;
+ end if;
+ end if;
+ end Expand_Membership_Minimize_Eliminate_Overflow;
+
+ ------------------------
+ -- Expand_N_Allocator --
+ ------------------------
+
+ procedure Expand_N_Allocator (N : Node_Id) is
+ PtrT : constant Entity_Id := Etype (N);
+ Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
+ Etyp : constant Entity_Id := Etype (Expression (N));
+ Loc : constant Source_Ptr := Sloc (N);
+ Desig : Entity_Id;
+ Nod : Node_Id;
+ Pool : Entity_Id;
+ Temp : Entity_Id;
+
+ procedure Rewrite_Coextension (N : Node_Id);
+ -- Static coextensions have the same lifetime as the entity they
+ -- constrain. Such occurrences can be rewritten as aliased objects
+ -- and their unrestricted access used instead of the coextension.
+
+ function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
+ -- Given a constrained array type E, returns a node representing the
+ -- code to compute the size in storage elements for the given type.
+ -- This is done without using the attribute (which malfunctions for
-- large sizes ???)
-------------------------
-------------------------
procedure Rewrite_Coextension (N : Node_Id) is
- Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
- Temp_Decl : Node_Id;
- Insert_Nod : Node_Id;
+ Temp_Id : constant Node_Id := Make_Temporary (Loc, 'C');
+ Temp_Decl : Node_Id;
begin
-- Generate:
Set_Expression (Temp_Decl, Expression (Expression (N)));
end if;
- -- Find the proper insertion node for the declaration
-
- Insert_Nod := Parent (N);
- while Present (Insert_Nod) loop
- exit when
- Nkind (Insert_Nod) in N_Statement_Other_Than_Procedure_Call
- or else Nkind (Insert_Nod) = N_Procedure_Call_Statement
- or else Nkind (Insert_Nod) in N_Declaration;
-
- Insert_Nod := Parent (Insert_Nod);
- end loop;
-
- Insert_Before (Insert_Nod, Temp_Decl);
- Analyze (Temp_Decl);
-
+ Insert_Action (N, Temp_Decl);
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Temp_Id, Loc),
-- Processing for anonymous access-to-controlled types. These access
-- types receive a special finalization master which appears in the
-- declarations of the enclosing semantic unit. This expansion is done
- -- now to ensure that any additional types generated by this routine
- -- or Expand_Allocator_Expression inherit the proper type attributes.
+ -- now to ensure that any additional types generated by this routine or
+ -- Expand_Allocator_Expression inherit the proper type attributes.
- if Ekind (PtrT) = E_Anonymous_Access_Type
+ if (Ekind (PtrT) = E_Anonymous_Access_Type
+ or else
+ (Is_Itype (PtrT) and then No (Finalization_Master (PtrT))))
and then Needs_Finalization (Dtyp)
then
-- Anonymous access-to-controlled types allocate on the global pool.
-- Do not set this attribute on .NET/JVM since those targets do not
-- support pools.
- if No (Associated_Storage_Pool (PtrT))
- and then VM_Target = No_VM
- then
- Set_Associated_Storage_Pool (PtrT,
- Get_Global_Pool_For_Access_Type (PtrT));
+ if No (Associated_Storage_Pool (PtrT)) and then VM_Target = No_VM then
+ Set_Associated_Storage_Pool
+ (PtrT, Get_Global_Pool_For_Access_Type (PtrT));
end if;
-- The finalization master must be inserted and analyzed as part of
- -- the current semantic unit.
+ -- the current semantic unit. This form of expansion is not carried
+ -- out in Alfa mode because it is useless. Note that the master is
+ -- updated when analysis changes current units.
- if No (Finalization_Master (PtrT)) then
- Build_Finalization_Master
- (Typ => PtrT,
- Ins_Node => Current_Unit_First_Declaration,
- Encl_Scope => Current_Unit_Scope);
+ if not Alfa_Mode then
+ Set_Finalization_Master (PtrT, Current_Anonymous_Master);
end if;
end if;
-- Set the storage pool and find the appropriate version of Allocate to
- -- call.
+ -- call. Do not overwrite the storage pool if it is already set, which
+ -- can happen for build-in-place function returns (see
+ -- Exp_Ch4.Expand_N_Extended_Return_Statement).
- Pool := Associated_Storage_Pool (Root_Type (PtrT));
- Set_Storage_Pool (N, Pool);
+ if No (Storage_Pool (N)) then
+ Pool := Associated_Storage_Pool (Root_Type (PtrT));
- if Present (Pool) then
- if Is_RTE (Pool, RE_SS_Pool) then
- if VM_Target = No_VM then
- Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
- end if;
+ if Present (Pool) then
+ Set_Storage_Pool (N, Pool);
- elsif Is_Class_Wide_Type (Etype (Pool)) then
- Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
+ if Is_RTE (Pool, RE_SS_Pool) then
+ if VM_Target = No_VM then
+ Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
+ end if;
- else
- Set_Procedure_To_Call (N,
- Find_Prim_Op (Etype (Pool), Name_Allocate));
+ -- In the case of an allocator for a simple storage pool, locate
+ -- and save a reference to the pool type's Allocate routine.
+
+ elsif Present (Get_Rep_Pragma
+ (Etype (Pool), Name_Simple_Storage_Pool_Type))
+ then
+ declare
+ Pool_Type : constant Entity_Id := Base_Type (Etype (Pool));
+ Alloc_Op : Entity_Id;
+ begin
+ Alloc_Op := Get_Name_Entity_Id (Name_Allocate);
+ while Present (Alloc_Op) loop
+ if Scope (Alloc_Op) = Scope (Pool_Type)
+ and then Present (First_Formal (Alloc_Op))
+ and then Etype (First_Formal (Alloc_Op)) = Pool_Type
+ then
+ Set_Procedure_To_Call (N, Alloc_Op);
+ exit;
+ else
+ Alloc_Op := Homonym (Alloc_Op);
+ end if;
+ end loop;
+ end;
+
+ elsif Is_Class_Wide_Type (Etype (Pool)) then
+ Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
+
+ else
+ Set_Procedure_To_Call (N,
+ Find_Prim_Op (Etype (Pool), Name_Allocate));
+ end if;
end if;
end if;
and then Present (Discriminant_Default_Value
(First_Discriminant (Typ)))
and then (Ada_Version < Ada_2005
- or else
- not Has_Constrained_Partial_View (Typ))
+ or else not
+ Effectively_Has_Constrained_Partial_View
+ (Typ => Typ,
+ Scop => Current_Scope))
then
Typ := Build_Default_Subtype (Typ, N);
Set_Expression (N, New_Reference_To (Typ, Loc));
end if;
end;
- -- We set the allocator as analyzed so that when we analyze the
- -- expression actions node, we do not get an unwanted recursive
+ -- We set the allocator as analyzed so that when we analyze
+ -- the if expression node, we do not get an unwanted recursive
-- expansion of the allocator expression.
Set_Analyzed (N, True);
-- Types derived from [Limited_]Controlled are the only
-- ones considered since they have fields Prev and Next.
- if VM_Target /= No_VM
- and then Is_Controlled (T)
- then
- Insert_Action (N,
- Make_Attach_Call
- (Obj_Ref => New_Copy_Tree (Init_Arg1),
- Ptr_Typ => PtrT));
+ if VM_Target /= No_VM then
+ if Is_Controlled (T) then
+ Insert_Action (N,
+ Make_Attach_Call
+ (Obj_Ref => New_Copy_Tree (Init_Arg1),
+ Ptr_Typ => PtrT));
+ end if;
-- Default case, generate:
-- Set_Finalize_Address
-- (<PtrT>FM, <T>FD'Unrestricted_Access);
- -- Do not generate the above for CodePeer compilations
- -- because primitive Finalize_Address is never built.
+ -- Do not generate this call in the following cases:
+ --
+ -- * Alfa mode - the call is useless and results in
+ -- unwanted expansion.
+ --
+ -- * CodePeer mode - TSS primitive Finalize_Address is
+ -- not created in this mode.
- elsif not CodePeer_Mode then
+ elsif not Alfa_Mode
+ and then not CodePeer_Mode
+ then
Insert_Action (N,
Make_Set_Finalize_Address_Call
(Loc => Loc,
Fexp : Node_Id;
begin
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
-- We expand
-- case X is when A => AX, when B => BX ...
-- wrong for unconstrained types (since the bounds may not be the
-- same in all branches). Furthermore it involves an extra copy
-- for large objects. So we take care of this by using the following
- -- modified expansion for non-scalar types:
+ -- modified expansion for non-elementary types:
-- do
-- type Pnn is access all typ;
-- Scalar case
- if Is_Scalar_Type (Typ) then
+ if Is_Elementary_Type (Typ) then
Ttyp := Typ;
else
Alt := First (Alternatives (N));
while Present (Alt) loop
declare
- Aexp : Node_Id := Expression (Alt);
- Aloc : constant Source_Ptr := Sloc (Aexp);
+ Aexp : Node_Id := Expression (Alt);
+ Aloc : constant Source_Ptr := Sloc (Aexp);
+ Stats : List_Id;
begin
- -- Propagate declarations inserted in the node by Insert_Actions
- -- (for example, temporaries generated to remove side effects).
-
- Append_List_To (Actions, Sinfo.Actions (Alt));
+ -- As described above, take Unrestricted_Access for case of non-
+ -- scalar types, to avoid big copies, and special cases.
- if not Is_Scalar_Type (Typ) then
+ if not Is_Elementary_Type (Typ) then
Aexp :=
Make_Attribute_Reference (Aloc,
Prefix => Relocate_Node (Aexp),
Attribute_Name => Name_Unrestricted_Access);
end if;
+ Stats := New_List (
+ Make_Assignment_Statement (Aloc,
+ Name => New_Occurrence_Of (Tnn, Loc),
+ Expression => Aexp));
+
+ -- Propagate declarations inserted in the node by Insert_Actions
+ -- (for example, temporaries generated to remove side effects).
+ -- These actions must remain attached to the alternative, given
+ -- that they are generated by the corresponding expression.
+
+ if Present (Sinfo.Actions (Alt)) then
+ Prepend_List (Sinfo.Actions (Alt), Stats);
+ end if;
+
Append_To
(Alternatives (Cstmt),
Make_Case_Statement_Alternative (Sloc (Alt),
Discrete_Choices => Discrete_Choices (Alt),
- Statements => New_List (
- Make_Assignment_Statement (Aloc,
- Name => New_Occurrence_Of (Tnn, Loc),
- Expression => Aexp))));
+ Statements => Stats));
end;
Next (Alt);
-- Construct and return final expression with actions
- if Is_Scalar_Type (Typ) then
+ if Is_Elementary_Type (Typ) then
Fexp := New_Occurrence_Of (Tnn, Loc);
else
Fexp :=
Analyze_And_Resolve (N, Typ);
end Expand_N_Case_Expression;
- -------------------------------------
- -- Expand_N_Conditional_Expression --
- -------------------------------------
+ -----------------------------------
+ -- Expand_N_Explicit_Dereference --
+ -----------------------------------
+
+ procedure Expand_N_Explicit_Dereference (N : Node_Id) is
+ begin
+ -- Insert explicit dereference call for the checked storage pool case
+
+ Insert_Dereference_Action (Prefix (N));
+
+ -- If the type is an Atomic type for which Atomic_Sync is enabled, then
+ -- we set the atomic sync flag.
+
+ if Is_Atomic (Etype (N))
+ and then not Atomic_Synchronization_Disabled (Etype (N))
+ then
+ Activate_Atomic_Synchronization (N);
+ end if;
+ end Expand_N_Explicit_Dereference;
+
+ --------------------------------------
+ -- Expand_N_Expression_With_Actions --
+ --------------------------------------
+
+ procedure Expand_N_Expression_With_Actions (N : Node_Id) is
+
+ procedure Process_Transient_Object (Decl : Node_Id);
+ -- Given the declaration of a controlled transient declared inside the
+ -- Actions list of an Expression_With_Actions, generate all necessary
+ -- types and hooks in order to properly finalize the transient. This
+ -- mechanism works in conjunction with Build_Finalizer.
+
+ ------------------------------
+ -- Process_Transient_Object --
+ ------------------------------
+
+ procedure Process_Transient_Object (Decl : Node_Id) is
+
+ function Find_Insertion_Node return Node_Id;
+ -- Complex conditions in if statements may be converted into nested
+ -- EWAs. In this case, any generated code must be inserted before the
+ -- if statement to ensure proper visibility of the hook objects. This
+ -- routine returns the top most short circuit operator or the parent
+ -- of the EWA if no nesting was detected.
+
+ -------------------------
+ -- Find_Insertion_Node --
+ -------------------------
+
+ function Find_Insertion_Node return Node_Id is
+ Par : Node_Id;
+
+ begin
+ -- Climb up the branches of a complex condition
+
+ Par := N;
+ while Nkind_In (Parent (Par), N_And_Then, N_Op_Not, N_Or_Else) loop
+ Par := Parent (Par);
+ end loop;
+
+ return Par;
+ end Find_Insertion_Node;
+
+ -- Local variables
+
+ Ins_Node : constant Node_Id := Find_Insertion_Node;
+ Loc : constant Source_Ptr := Sloc (Decl);
+ Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Obj_Typ : constant Entity_Id := Etype (Obj_Id);
+ Desig_Typ : Entity_Id;
+ Expr : Node_Id;
+ Ptr_Decl : Node_Id;
+ Ptr_Id : Entity_Id;
+ Temp_Decl : Node_Id;
+ Temp_Id : Node_Id;
+
+ -- Start of processing for Process_Transient_Object
+
+ begin
+ -- Step 1: Create the access type which provides a reference to the
+ -- transient object.
+
+ if Is_Access_Type (Obj_Typ) then
+ Desig_Typ := Directly_Designated_Type (Obj_Typ);
+ else
+ Desig_Typ := Obj_Typ;
+ end if;
+
+ -- Generate:
+ -- Ann : access [all] <Desig_Typ>;
+
+ Ptr_Id := Make_Temporary (Loc, 'A');
+
+ Ptr_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Id,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present =>
+ Ekind (Obj_Typ) = E_General_Access_Type,
+ Subtype_Indication => New_Reference_To (Desig_Typ, Loc)));
+
+ Insert_Action (Ins_Node, Ptr_Decl);
+ Analyze (Ptr_Decl);
+
+ -- Step 2: Create a temporary which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Temp : Ptr_Id := null;
+
+ Temp_Id := Make_Temporary (Loc, 'T');
- -- Deal with limited types and expression actions
+ Temp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition => New_Reference_To (Ptr_Id, Loc));
+
+ Insert_Action (Ins_Node, Temp_Decl);
+ Analyze (Temp_Decl);
+
+ -- Mark this temporary as created for the purposes of exporting the
+ -- transient declaration out of the Actions list. This signals the
+ -- machinery in Build_Finalizer to recognize this special case.
+
+ Set_Status_Flag_Or_Transient_Decl (Temp_Id, Decl);
+
+ -- Step 3: Hook the transient object to the temporary
+
+ if Is_Access_Type (Obj_Typ) then
+ Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
+ else
+ Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Reference_To (Obj_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
+
+ -- Generate:
+ -- Temp := Ptr_Id (Obj_Id);
+ -- <or>
+ -- Temp := Obj_Id'Unrestricted_Access;
+
+ Insert_After_And_Analyze (Decl,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression => Expr));
+ end Process_Transient_Object;
+
+ -- Local variables
+
+ Decl : Node_Id;
+
+ -- Start of processing for Expand_N_Expression_With_Actions
+
+ begin
+ Decl := First (Actions (N));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Object_Declaration
+ and then Is_Finalizable_Transient (Decl, N)
+ then
+ Process_Transient_Object (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Expand_N_Expression_With_Actions;
+
+ ----------------------------
+ -- Expand_N_If_Expression --
+ ----------------------------
+
+ -- Deal with limited types and condition actions
+
+ procedure Expand_N_If_Expression (N : Node_Id) is
+ function Create_Alternative
+ (Loc : Source_Ptr;
+ Temp_Id : Entity_Id;
+ Flag_Id : Entity_Id;
+ Expr : Node_Id) return List_Id;
+ -- Build the statements of a "then" or "else" dependent expression
+ -- alternative. Temp_Id is the if expression result, Flag_Id is a
+ -- finalization flag created to service expression Expr.
+
+ function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean;
+ -- Determine if expression Expr is a rewritten controlled function call
+
+ ------------------------
+ -- Create_Alternative --
+ ------------------------
+
+ function Create_Alternative
+ (Loc : Source_Ptr;
+ Temp_Id : Entity_Id;
+ Flag_Id : Entity_Id;
+ Expr : Node_Id) return List_Id
+ is
+ Result : constant List_Id := New_List;
+
+ begin
+ -- Generate:
+ -- Fnn := True;
+
+ if Present (Flag_Id)
+ and then not Is_Controlled_Function_Call (Expr)
+ then
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Flag_Id, Loc),
+ Expression => New_Reference_To (Standard_True, Loc)));
+ end if;
+
+ -- Generate:
+ -- Cnn := <expr>'Unrestricted_Access;
+
+ Append_To (Result,
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Temp_Id, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (Expr),
+ Attribute_Name => Name_Unrestricted_Access)));
+
+ return Result;
+ end Create_Alternative;
+
+ ---------------------------------
+ -- Is_Controlled_Function_Call --
+ ---------------------------------
+
+ function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean is
+ begin
+ return
+ Nkind (Original_Node (Expr)) = N_Function_Call
+ and then Needs_Finalization (Etype (Expr));
+ end Is_Controlled_Function_Call;
+
+ -- Local variables
- procedure Expand_N_Conditional_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := First (Expressions (N));
Thenx : constant Node_Id := Next (Cond);
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
+ Actions : List_Id;
Cnn : Entity_Id;
Decl : Node_Id;
+ Expr : Node_Id;
New_If : Node_Id;
New_N : Node_Id;
- P_Decl : Node_Id;
- Expr : Node_Id;
- Actions : List_Id;
+
+ -- Start of processing for Expand_N_If_Expression
begin
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
-- Fold at compile time if condition known. We have already folded
- -- static conditional expressions, but it is possible to fold any
- -- case in which the condition is known at compile time, even though
- -- the result is non-static.
+ -- static if expressions, but it is possible to fold any case in which
+ -- the condition is known at compile time, even though the result is
+ -- non-static.
-- Note that we don't do the fold of such cases in Sem_Elab because
-- it can cause infinite loops with the expander adding a conditional
if Present (Actions) then
- -- If we are not allowed to use Expression_With_Actions, just
- -- skip the optimization, it is not critical for correctness.
+ -- If we are not allowed to use Expression_With_Actions, just skip
+ -- the optimization, it is not critical for correctness.
if not Use_Expression_With_Actions then
goto Skip_Optimization;
end if;
-- Note that the result is never static (legitimate cases of static
- -- conditional expressions were folded in Sem_Eval).
+ -- if expressions were folded in Sem_Eval).
Set_Is_Static_Expression (N, False);
return;
-- Cnn := else-expr'Unrestricted_Access;
-- end if;
- -- and replace the conditional expression by a reference to Cnn.all.
+ -- and replace the if expression by a reference to Cnn.all.
-- This special case can be skipped if the back end handles limited
-- types properly and ensures that no incorrect copies are made.
if Is_By_Reference_Type (Typ)
and then not Back_End_Handles_Limited_Types
then
- Cnn := Make_Temporary (Loc, 'C', N);
+ declare
+ Flag_Id : Entity_Id;
+ Ptr_Typ : Entity_Id;
- P_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'A'),
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication => New_Reference_To (Typ, Loc)));
+ begin
+ Flag_Id := Empty;
- Insert_Action (N, P_Decl);
+ -- At least one of the if expression dependent expressions uses a
+ -- controlled function to provide the result. Create a status flag
+ -- to signal the finalization machinery that Cnn needs special
+ -- handling.
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cnn,
- Object_Definition =>
- New_Occurrence_Of (Defining_Identifier (P_Decl), Loc));
-
- New_If :=
- Make_Implicit_If_Statement (N,
- Condition => Relocate_Node (Cond),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Sloc (Thenx),
- Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => Relocate_Node (Thenx)))),
+ if Is_Controlled_Function_Call (Thenx)
+ or else
+ Is_Controlled_Function_Call (Elsex)
+ then
+ Flag_Id := Make_Temporary (Loc, 'F');
- Else_Statements => New_List (
- Make_Assignment_Statement (Sloc (Elsex),
- Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Unrestricted_Access,
- Prefix => Relocate_Node (Elsex)))));
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Flag_Id,
+ Object_Definition =>
+ New_Reference_To (Standard_Boolean, Loc),
+ Expression =>
+ New_Reference_To (Standard_False, Loc)));
+ end if;
- New_N :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Cnn, Loc));
+ -- Generate:
+ -- type Ann is access all Typ;
+
+ Ptr_Typ := Make_Temporary (Loc, 'A');
+
+ Insert_Action (N,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Reference_To (Typ, Loc))));
+
+ -- Generate:
+ -- Cnn : Ann;
+
+ Cnn := Make_Temporary (Loc, 'C', N);
+ Set_Ekind (Cnn, E_Variable);
+ Set_Status_Flag_Or_Transient_Decl (Cnn, Flag_Id);
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc));
+
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
+ Then_Statements =>
+ Create_Alternative (Sloc (Thenx), Cnn, Flag_Id, Thenx),
+ Else_Statements =>
+ Create_Alternative (Sloc (Elsex), Cnn, Flag_Id, Elsex));
+
+ New_N :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Cnn, Loc));
+ end;
-- For other types, we only need to expand if there are other actions
-- associated with either branch.
-- Cnn := else-expr
-- end if;
- -- and replace the conditional expression by a reference to Cnn
+ -- and replace the if expression by a reference to Cnn
else
Cnn := Make_Temporary (Loc, 'C', N);
Defining_Identifier => Cnn,
Object_Definition => New_Occurrence_Of (Typ, Loc));
- New_If :=
- Make_Implicit_If_Statement (N,
- Condition => Relocate_Node (Cond),
-
- Then_Statements => New_List (
- Make_Assignment_Statement (Sloc (Thenx),
- Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
- Expression => Relocate_Node (Thenx))),
-
- Else_Statements => New_List (
- Make_Assignment_Statement (Sloc (Elsex),
- Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
- Expression => Relocate_Node (Elsex))));
-
- Set_Assignment_OK (Name (First (Then_Statements (New_If))));
- Set_Assignment_OK (Name (First (Else_Statements (New_If))));
-
- New_N := New_Occurrence_Of (Cnn, Loc);
- end if;
-
- -- If no actions then no expansion needed, gigi will handle it using
- -- the same approach as a C conditional expression.
-
- else
- return;
- end if;
-
- -- Fall through here for either the limited expansion, or the case of
- -- inserting actions for non-limited types. In both these cases, we must
- -- move the SLOC of the parent If statement to the newly created one and
- -- change it to the SLOC of the expression which, after expansion, will
- -- correspond to what is being evaluated.
-
- if Present (Parent (N))
- and then Nkind (Parent (N)) = N_If_Statement
- then
- Set_Sloc (New_If, Sloc (Parent (N)));
- Set_Sloc (Parent (N), Loc);
- end if;
-
- -- Make sure Then_Actions and Else_Actions are appropriately moved
- -- to the new if statement.
-
- if Present (Then_Actions (N)) then
- Insert_List_Before
- (First (Then_Statements (New_If)), Then_Actions (N));
- end if;
-
- if Present (Else_Actions (N)) then
- Insert_List_Before
- (First (Else_Statements (New_If)), Else_Actions (N));
- end if;
-
- Insert_Action (N, Decl);
- Insert_Action (N, New_If);
- Rewrite (N, New_N);
- Analyze_And_Resolve (N, Typ);
- end Expand_N_Conditional_Expression;
-
- -----------------------------------
- -- Expand_N_Explicit_Dereference --
- -----------------------------------
-
- procedure Expand_N_Explicit_Dereference (N : Node_Id) is
- begin
- -- Insert explicit dereference call for the checked storage pool case
-
- Insert_Dereference_Action (Prefix (N));
- end Expand_N_Explicit_Dereference;
-
- --------------------------------------
- -- Expand_N_Expression_With_Actions --
- --------------------------------------
-
- procedure Expand_N_Expression_With_Actions (N : Node_Id) is
-
- procedure Process_Transient_Object (Decl : Node_Id);
- -- Given the declaration of a controlled transient declared inside the
- -- Actions list of an Expression_With_Actions, generate all necessary
- -- types and hooks in order to properly finalize the transient. This
- -- mechanism works in conjunction with Build_Finalizer.
-
- ------------------------------
- -- Process_Transient_Object --
- ------------------------------
-
- procedure Process_Transient_Object (Decl : Node_Id) is
- Ins_Nod : constant Node_Id := Parent (N);
- -- To avoid the insertion of generated code in the list of Actions,
- -- Insert_Action must look at the parent field of the EWA.
-
- Loc : constant Source_Ptr := Sloc (Decl);
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Entity_Id := Etype (Obj_Id);
- Desig_Typ : Entity_Id;
- Expr : Node_Id;
- Ptr_Decl : Node_Id;
- Ptr_Id : Entity_Id;
- Temp_Decl : Node_Id;
- Temp_Id : Node_Id;
-
- begin
- -- Step 1: Create the access type which provides a reference to
- -- the transient object.
-
- if Is_Access_Type (Obj_Typ) then
- Desig_Typ := Directly_Designated_Type (Obj_Typ);
- else
- Desig_Typ := Obj_Typ;
- end if;
-
- -- Generate:
- -- Ann : access [all] <Desig_Typ>;
-
- Ptr_Id := Make_Temporary (Loc, 'A');
-
- Ptr_Decl :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Id,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present =>
- Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication => New_Reference_To (Desig_Typ, Loc)));
-
- Insert_Action (Ins_Nod, Ptr_Decl);
- Analyze (Ptr_Decl);
-
- -- Step 2: Create a temporary which acts as a hook to the transient
- -- object. Generate:
-
- -- Temp : Ptr_Id := null;
-
- Temp_Id := Make_Temporary (Loc, 'T');
-
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Object_Definition => New_Reference_To (Ptr_Id, Loc));
-
- Insert_Action (Ins_Nod, Temp_Decl);
- Analyze (Temp_Decl);
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
- -- Mark this temporary as created for the purposes of "exporting" the
- -- transient declaration out of the Actions list. This signals the
- -- machinery in Build_Finalizer to recognize this special case.
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Thenx),
+ Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
+ Expression => Relocate_Node (Thenx))),
- Set_Return_Flag_Or_Transient_Decl (Temp_Id, Decl);
+ Else_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Elsex),
+ Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
+ Expression => Relocate_Node (Elsex))));
- -- Step 3: "Hook" the transient object to the temporary
+ Set_Assignment_OK (Name (First (Then_Statements (New_If))));
+ Set_Assignment_OK (Name (First (Else_Statements (New_If))));
- if Is_Access_Type (Obj_Typ) then
- Expr := Convert_To (Ptr_Id, New_Reference_To (Obj_Id, Loc));
- else
- Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Reference_To (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
+ New_N := New_Occurrence_Of (Cnn, Loc);
end if;
- -- Generate:
- -- Temp := Ptr_Id (Obj_Id);
- -- <or>
- -- Temp := Obj_Id'Unrestricted_Access;
+ -- If no actions then no expansion needed, gigi will handle it using
+ -- the same approach as a C conditional expression.
- Insert_After_And_Analyze (Decl,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Temp_Id, Loc),
- Expression => Expr));
- end Process_Transient_Object;
+ else
+ return;
+ end if;
- Decl : Node_Id;
+ -- Fall through here for either the limited expansion, or the case of
+ -- inserting actions for non-limited types. In both these cases, we must
+ -- move the SLOC of the parent If statement to the newly created one and
+ -- change it to the SLOC of the expression which, after expansion, will
+ -- correspond to what is being evaluated.
- -- Start of processing for Expand_N_Expression_With_Actions
+ if Present (Parent (N))
+ and then Nkind (Parent (N)) = N_If_Statement
+ then
+ Set_Sloc (New_If, Sloc (Parent (N)));
+ Set_Sloc (Parent (N), Loc);
+ end if;
- begin
- Decl := First (Actions (N));
- while Present (Decl) loop
- if Nkind (Decl) = N_Object_Declaration
- and then Is_Finalizable_Transient (Decl, N)
- then
- Process_Transient_Object (Decl);
- end if;
+ -- Make sure Then_Actions and Else_Actions are appropriately moved
+ -- to the new if statement.
- Next (Decl);
- end loop;
- end Expand_N_Expression_With_Actions;
+ if Present (Then_Actions (N)) then
+ Insert_List_Before
+ (First (Then_Statements (New_If)), Then_Actions (N));
+ end if;
+
+ if Present (Else_Actions (N)) then
+ Insert_List_Before
+ (First (Else_Statements (New_If)), Else_Actions (N));
+ end if;
+
+ Insert_Action (N, Decl);
+ Insert_Action (N, New_If);
+ Rewrite (N, New_N);
+ Analyze_And_Resolve (N, Typ);
+ end Expand_N_If_Expression;
-----------------
-- Expand_N_In --
Ltyp : Entity_Id;
Rtyp : Entity_Id;
- procedure Expand_Set_Membership;
- -- For each choice we create a simple equality or membership test.
- -- The whole membership is rewritten connecting these with OR ELSE.
-
- ---------------------------
- -- Expand_Set_Membership --
- ---------------------------
-
- procedure Expand_Set_Membership is
- Alt : Node_Id;
- Res : Node_Id;
-
- function Make_Cond (Alt : Node_Id) return Node_Id;
- -- If the alternative is a subtype mark, create a simple membership
- -- test. Otherwise create an equality test for it.
-
- ---------------
- -- Make_Cond --
- ---------------
-
- function Make_Cond (Alt : Node_Id) return Node_Id is
- Cond : Node_Id;
- L : constant Node_Id := New_Copy (Lop);
- R : constant Node_Id := Relocate_Node (Alt);
-
- begin
- if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
- or else Nkind (Alt) = N_Range
- then
- Cond :=
- Make_In (Sloc (Alt),
- Left_Opnd => L,
- Right_Opnd => R);
- else
- Cond :=
- Make_Op_Eq (Sloc (Alt),
- Left_Opnd => L,
- Right_Opnd => R);
- end if;
-
- return Cond;
- end Make_Cond;
-
- -- Start of processing for Expand_Set_Membership
-
- begin
- Alt := Last (Alternatives (N));
- Res := Make_Cond (Alt);
-
- Prev (Alt);
- while Present (Alt) loop
- Res :=
- Make_Or_Else (Sloc (Alt),
- Left_Opnd => Make_Cond (Alt),
- Right_Opnd => Res);
- Prev (Alt);
- end loop;
-
- Rewrite (N, Res);
- Analyze_And_Resolve (N, Standard_Boolean);
- end Expand_Set_Membership;
-
procedure Substitute_Valid_Check;
-- Replaces node N by Lop'Valid. This is done when we have an explicit
-- test for the left operand being in range of its subtype.
Analyze_And_Resolve (N, Restyp);
- Error_Msg_N ("?explicit membership test may be optimized away", N);
- Error_Msg_N -- CODEFIX
- ("\?use ''Valid attribute instead", N);
+ -- Give warning unless overflow checking is MINIMIZED or ELIMINATED,
+ -- in which case, this usage makes sense, and in any case, we have
+ -- actually eliminated the danger of optimization above.
+
+ if Overflow_Check_Mode not in Minimized_Or_Eliminated then
+ Error_Msg_N
+ ("??explicit membership test may be optimized away", N);
+ Error_Msg_N -- CODEFIX
+ ("\??use ''Valid attribute instead", N);
+ end if;
+
return;
end Substitute_Valid_Check;
-- If set membership case, expand with separate procedure
if Present (Alternatives (N)) then
- Remove_Side_Effects (Lop);
- Expand_Set_Membership;
+ Expand_Set_Membership (N);
return;
end if;
Ltyp := Etype (Left_Opnd (N));
Rtyp := Etype (Right_Opnd (N));
+ -- If MINIMIZED/ELIMINATED overflow mode and type is a signed integer
+ -- type, then expand with a separate procedure. Note the use of the
+ -- flag No_Minimize_Eliminate to prevent infinite recursion.
+
+ if Overflow_Check_Mode in Minimized_Or_Eliminated
+ and then Is_Signed_Integer_Type (Ltyp)
+ and then not No_Minimize_Eliminate (N)
+ then
+ Expand_Membership_Minimize_Eliminate_Overflow (N);
+ return;
+ end if;
+
-- Check case of explicit test for an expression in range of its
-- subtype. This is suspicious usage and we replace it with a 'Valid
- -- test and give a warning. For floating point types however, this is a
- -- standard way to check for finite numbers, and using 'Valid would
- -- typically be a pessimization. Also skip this test for predicated
- -- types, since it is perfectly reasonable to check if a value meets
- -- its predicate.
+ -- test and give a warning for scalar types.
if Is_Scalar_Type (Ltyp)
+
+ -- Only relevant for source comparisons
+
+ and then Comes_From_Source (N)
+
+ -- In floating-point this is a standard way to check for finite values
+ -- and using 'Valid would typically be a pessimization.
+
and then not Is_Floating_Point_Type (Ltyp)
+
+ -- Don't give the message unless right operand is a type entity and
+ -- the type of the left operand matches this type. Note that this
+ -- eliminates the cases where MINIMIZED/ELIMINATED mode overflow
+ -- checks have changed the type of the left operand.
+
and then Nkind (Rop) in N_Has_Entity
and then Ltyp = Entity (Rop)
- and then Comes_From_Source (N)
+
+ -- Skip in VM mode, where we have no sense of invalid values. The
+ -- warning still seems relevant, but not important enough to worry.
+
and then VM_Target = No_VM
- and then not (Is_Discrete_Type (Ltyp)
- and then Present (Predicate_Function (Ltyp)))
+
+ -- Skip this for predicated types, where such expressions are a
+ -- reasonable way of testing if something meets the predicate.
+
+ and then not Present (Predicate_Function (Ltyp))
then
Substitute_Valid_Check;
return;
-- Could use some individual comments for this complex test ???
if Is_Scalar_Type (Ltyp)
+
+ -- And left operand is X'First where X matches left operand
+ -- type (this eliminates cases of type mismatch, including
+ -- the cases where ELIMINATED/MINIMIZED mode has changed the
+ -- type of the left operand.
+
and then Nkind (Lo_Orig) = N_Attribute_Reference
and then Attribute_Name (Lo_Orig) = Name_First
and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
and then Entity (Prefix (Lo_Orig)) = Ltyp
+
+ -- Same tests for right operand
+
and then Nkind (Hi_Orig) = N_Attribute_Reference
and then Attribute_Name (Hi_Orig) = Name_Last
and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
and then Entity (Prefix (Hi_Orig)) = Ltyp
+
+ -- Relevant only for source cases
+
and then Comes_From_Source (N)
+
+ -- Omit for VM cases, where we don't have invalid values
+
and then VM_Target = No_VM
then
Substitute_Valid_Check;
and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo)
- -- Kill warnings in instances, since they may be cases where we
- -- have a test in the generic that makes sense with some types
- -- and not with other types.
+ -- Kill warnings in instances, since they may be cases where we
+ -- have a test in the generic that makes sense with some types
+ -- and not with other types.
and then not In_Instance
then
if Lcheck = LT or else Ucheck = GT then
if Warn1 then
- Error_Msg_N ("?range test optimized away", N);
- Error_Msg_N ("\?value is known to be out of range", N);
+ Error_Msg_N ("?c?range test optimized away", N);
+ Error_Msg_N ("\?c?value is known to be out of range", N);
end if;
Rewrite (N, New_Reference_To (Standard_False, Loc));
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
if Warn1 then
- Error_Msg_N ("?range test optimized away", N);
- Error_Msg_N ("\?value is known to be in range", N);
+ Error_Msg_N ("?c?range test optimized away", N);
+ Error_Msg_N ("\?c?value is known to be in range", N);
end if;
Rewrite (N, New_Reference_To (Standard_True, Loc));
elsif Lcheck in Compare_GE then
if Warn2 and then not In_Instance then
- Error_Msg_N ("?lower bound test optimized away", Lo);
- Error_Msg_N ("\?value is known to be in range", Lo);
+ Error_Msg_N ("??lower bound test optimized away", Lo);
+ Error_Msg_N ("\??value is known to be in range", Lo);
end if;
Rewrite (N,
elsif Ucheck in Compare_LE then
if Warn2 and then not In_Instance then
- Error_Msg_N ("?upper bound test optimized away", Hi);
- Error_Msg_N ("\?value is known to be in range", Hi);
+ Error_Msg_N ("??upper bound test optimized away", Hi);
+ Error_Msg_N ("\??value is known to be in range", Hi);
end if;
Rewrite (N,
if Lcheck = LT or else Ucheck = GT then
Error_Msg_N
- ("?value can only be in range if it is invalid", N);
+ ("?c?value can only be in range if it is invalid", N);
-- Result is in range for valid value
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
Error_Msg_N
- ("?value can only be out of range if it is invalid", N);
+ ("?c?value can only be out of range if it is invalid", N);
-- Lower bound check succeeds if value is valid
elsif Warn2 and then Lcheck in Compare_GE then
Error_Msg_N
- ("?lower bound check only fails if it is invalid", Lo);
+ ("?c?lower bound check only fails if it is invalid", Lo);
-- Upper bound check succeeds if value is valid
elsif Warn2 and then Ucheck in Compare_LE then
Error_Msg_N
- ("?upper bound check only fails for invalid values", Hi);
+ ("?c?upper bound check only fails for invalid values", Hi);
end if;
end if;
end;
-- type if they come from the original type definition. Also this
-- way we get all the processing above for an explicit range.
- -- Don't do this for predicated types, since in this case we
- -- want to check the predicate!
+ -- Don't do this for predicated types, since in this case we
+ -- want to check the predicate!
elsif Is_Scalar_Type (Typ) then
if No (Predicate_Function (Typ)) then
Low_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
- Prefix => New_Reference_To (Typ, Loc)),
+ Prefix => New_Reference_To (Typ, Loc)),
High_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
- Prefix => New_Reference_To (Typ, Loc))));
+ Prefix => New_Reference_To (Typ, Loc))));
Analyze_And_Resolve (N, Restyp);
end if;
Reason => PE_Unchecked_Union_Restriction));
-- Prevent Gigi from generating incorrect code by rewriting the
- -- test as False.
+ -- test as False. What is this undocumented thing about ???
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
goto Leave;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Restyp);
end if;
+
+ -- Ada 2012 (AI05-0149): Handle membership tests applied to an
+ -- expression of an anonymous access type. This can involve an
+ -- accessibility test and a tagged type membership test in the
+ -- case of tagged designated types.
+
+ if Ada_Version >= Ada_2012
+ and then Is_Acc
+ and then Ekind (Ltyp) = E_Anonymous_Access_Type
+ then
+ declare
+ Expr_Entity : Entity_Id := Empty;
+ New_N : Node_Id;
+ Param_Level : Node_Id;
+ Type_Level : Node_Id;
+
+ begin
+ if Is_Entity_Name (Lop) then
+ Expr_Entity := Param_Entity (Lop);
+
+ if not Present (Expr_Entity) then
+ Expr_Entity := Entity (Lop);
+ end if;
+ end if;
+
+ -- If a conversion of the anonymous access value to the
+ -- tested type would be illegal, then the result is False.
+
+ if not Valid_Conversion
+ (Lop, Rtyp, Lop, Report_Errs => False)
+ then
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
+ Analyze_And_Resolve (N, Restyp);
+
+ -- Apply an accessibility check if the access object has an
+ -- associated access level and when the level of the type is
+ -- less deep than the level of the access parameter. This
+ -- only occur for access parameters and stand-alone objects
+ -- of an anonymous access type.
+
+ else
+ if Present (Expr_Entity)
+ and then
+ Present
+ (Effective_Extra_Accessibility (Expr_Entity))
+ and then UI_Gt (Object_Access_Level (Lop),
+ Type_Access_Level (Rtyp))
+ then
+ Param_Level :=
+ New_Occurrence_Of
+ (Effective_Extra_Accessibility (Expr_Entity), Loc);
+
+ Type_Level :=
+ Make_Integer_Literal (Loc, Type_Access_Level (Rtyp));
+
+ -- Return True only if the accessibility level of the
+ -- expression entity is not deeper than the level of
+ -- the tested access type.
+
+ Rewrite (N,
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (N),
+ Right_Opnd => Make_Op_Le (Loc,
+ Left_Opnd => Param_Level,
+ Right_Opnd => Type_Level)));
+
+ Analyze_And_Resolve (N);
+ end if;
+
+ -- If the designated type is tagged, do tagged membership
+ -- operation.
+
+ -- *** NOTE: we have to check not null before doing the
+ -- tagged membership test (but maybe that can be done
+ -- inside Tagged_Membership?).
+
+ if Is_Tagged_Type (Typ) then
+ Rewrite (N,
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (N),
+ Right_Opnd =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Obj,
+ Right_Opnd => Make_Null (Loc))));
+
+ -- No expansion will be performed when VM_Target, as
+ -- the VM back-ends will handle the membership tests
+ -- directly (tags are not explicitly represented in
+ -- Java objects, so the normal tagged membership
+ -- expansion is not what we want).
+
+ if Tagged_Type_Expansion then
+
+ -- Note that we have to pass Original_Node, because
+ -- the membership test might already have been
+ -- rewritten by earlier parts of membership test.
+
+ Tagged_Membership
+ (Original_Node (N), SCIL_Node, New_N);
+
+ -- Update decoration of relocated node referenced
+ -- by the SCIL node.
+
+ if Generate_SCIL and then Present (SCIL_Node) then
+ Set_SCIL_Node (New_N, SCIL_Node);
+ end if;
+
+ Rewrite (N,
+ Make_And_Then (Loc,
+ Left_Opnd => Relocate_Node (N),
+ Right_Opnd => New_N));
+
+ Analyze_And_Resolve (N, Restyp);
+ end if;
+ end if;
+ end if;
+ end;
+ end if;
end;
end if;
-- If a predicate is present, then we do the predicate test, but we
-- most certainly want to omit this if we are within the predicate
-- function itself, since otherwise we have an infinite recursion!
+ -- The check should also not be emitted when testing against a range
+ -- (the check is only done when the right operand is a subtype; see
+ -- RM12-4.5.2 (28.1/3-30/3)).
declare
PFunc : constant Entity_Id := Predicate_Function (Rtyp);
begin
if Present (PFunc)
and then Current_Scope /= PFunc
+ and then Nkind (Rop) /= N_Range
then
Rewrite (N,
Make_And_Then (Loc,
Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
-- Analyze new expression, mark left operand as analyzed to
- -- avoid infinite recursion adding predicate calls.
+ -- avoid infinite recursion adding predicate calls. Similarly,
+ -- suppress further range checks on the call.
Set_Analyzed (Left_Opnd (N));
- Analyze_And_Resolve (N, Standard_Boolean);
+ Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
-- All done, skip attempt at compile time determination of result
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
+ Atp : Entity_Id;
begin
-- A special optimization, if we have an indexed component that is
if Is_Access_Type (T) then
Insert_Explicit_Dereference (P);
Analyze_And_Resolve (P, Designated_Type (T));
+ Atp := Designated_Type (T);
+ else
+ Atp := T;
end if;
-- Generate index and validity checks
Apply_Subscript_Validity_Checks (N);
end if;
+ -- If selecting from an array with atomic components, and atomic sync
+ -- is not suppressed for this array type, set atomic sync flag.
+
+ if (Has_Atomic_Components (Atp)
+ and then not Atomic_Synchronization_Disabled (Atp))
+ or else (Is_Atomic (Typ)
+ and then not Atomic_Synchronization_Disabled (Typ))
+ then
+ Activate_Atomic_Synchronization (N);
+ end if;
+
-- All done for the non-packed case
if not Is_Packed (Etype (Prefix (N))) then
begin
Unary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
-- Deal with software overflow checking
if not Backend_Overflow_Checks_On_Target
begin
Binary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
-- N + 0 = 0 + N = N for integer types
if Is_Integer_Type (Typ) then
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
-
- -- Replace AND by AND THEN if Short_Circuit_And_Or active and the
- -- type is standard Boolean (do not mess with AND that uses a non-
- -- standard Boolean type, because something strange is going on).
-
- if Short_Circuit_And_Or and then Typ = Standard_Boolean then
- Rewrite (N,
- Make_And_Then (Sloc (N),
- Left_Opnd => Relocate_Node (Left_Opnd (N)),
- Right_Opnd => Relocate_Node (Right_Opnd (N))));
- Analyze_And_Resolve (N, Typ);
-
- -- Otherwise, adjust conditions
-
- else
- Adjust_Condition (Left_Opnd (N));
- Adjust_Condition (Right_Opnd (N));
- Set_Etype (N, Standard_Boolean);
- Adjust_Result_Type (N, Typ);
- end if;
+ Adjust_Condition (Left_Opnd (N));
+ Adjust_Condition (Right_Opnd (N));
+ Set_Etype (N, Standard_Boolean);
+ Adjust_Result_Type (N, Typ);
elsif Is_Intrinsic_Subprogram (Entity (N)) then
Expand_Intrinsic_Call (N, Entity (N));
begin
Binary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
+ -- Otherwise proceed with expansion of division
+
if Rknow then
Rval := Expr_Value (Ropnd);
end if;
-- Non-fixed point cases, do integer zero divide and overflow checks
elsif Is_Integer_Type (Typ) then
- Apply_Divide_Check (N);
+ Apply_Divide_Checks (N);
-- Deal with Vax_Float
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with private types
+
if Ekind (Typl) = E_Private_Type then
Typl := Underlying_Type (Typl);
elsif Ekind (Typl) = E_Private_Subtype then
Typl := Base_Type (Typl);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- means we no longer have a comparison operation, we are all done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Eq then
+ return;
+ end if;
+
-- Boolean types (requiring handling of non-standard case)
if Is_Boolean_Type (Typl) then
Reason => PE_Unchecked_Union_Restriction));
-- Prevent Gigi from generating incorrect code by rewriting the
- -- equality as a standard False.
+ -- equality as a standard False. (is this documented somewhere???)
Rewrite (N,
New_Occurrence_Of (Standard_False, Loc));
Reason => PE_Unchecked_Union_Restriction));
-- Prevent Gigi from generating incorrect code by rewriting
- -- the equality as a standard False.
+ -- the equality as a standard False (documented where???).
Rewrite (N,
New_Occurrence_Of (Standard_False, Loc));
Exptyp : constant Entity_Id := Etype (Exp);
Ovflo : constant Boolean := Do_Overflow_Check (N);
Expv : Uint;
- Xnode : Node_Id;
Temp : Node_Id;
Rent : RE_Id;
Ent : Entity_Id;
Etyp : Entity_Id;
+ Xnode : Node_Id;
begin
Binary_Op_Validity_Checks (N);
-- CodePeer and GNATprove want to see the unexpanded N_Op_Expon node
- if CodePeer_Mode or ALFA_Mode then
+ if CodePeer_Mode or Alfa_Mode then
return;
end if;
end;
end if;
- -- Test for case of known right argument
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
+ -- Test for case of known right argument where we can replace the
+ -- exponentiation by an equivalent expression using multiplication.
if Compile_Time_Known_Value (Exp) then
Expv := Expr_Value (Exp);
Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
-- X ** 4 ->
+
+ -- do
-- En : constant base'type := base * base;
- -- ...
+ -- in
-- En * En
- else -- Expv = 4
+ else
+ pragma Assert (Expv = 4);
Temp := Make_Temporary (Loc, 'E', Base);
- Insert_Actions (N, New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Typ, Loc),
+ Xnode :=
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Typ, Loc),
+ Expression =>
+ Make_Op_Multiply (Loc,
+ Left_Opnd =>
+ Duplicate_Subexpr (Base),
+ Right_Opnd =>
+ Duplicate_Subexpr_No_Checks (Base)))),
+
Expression =>
Make_Op_Multiply (Loc,
- Left_Opnd => Duplicate_Subexpr (Base),
- Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
-
- Xnode :=
- Make_Op_Multiply (Loc,
- Left_Opnd => New_Reference_To (Temp, Loc),
- Right_Opnd => New_Reference_To (Temp, Loc));
+ Left_Opnd => New_Reference_To (Temp, Loc),
+ Right_Opnd => New_Reference_To (Temp, Loc)));
end if;
Rewrite (N, Xnode);
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- means we no longer have a comparison operation, we are all done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Ge then
+ return;
+ end if;
+
+ -- Array type case
+
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with boolean operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- means we no longer have a comparison operation, we are all done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Gt then
+ return;
+ end if;
+
+ -- Deal with array type operands
+
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with boolean type operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
- begin
- Binary_Op_Validity_Checks (N);
+ begin
+ Binary_Op_Validity_Checks (N);
+
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- means we no longer have a comparison operation, we are all done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Le then
+ return;
+ end if;
+
+ -- Deal with array type operands
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with Boolean type operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
begin
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if that
+ -- means we no longer have a comparison operation, we are all done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Lt then
+ return;
+ end if;
+
+ -- Deal with array type operands
+
if Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
+ -- Deal with Boolean type operands
+
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
begin
Unary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
if not Backend_Overflow_Checks_On_Target
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
procedure Expand_N_Op_Mod (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
- Left : constant Node_Id := Left_Opnd (N);
- Right : constant Node_Id := Right_Opnd (N);
- DOC : constant Boolean := Do_Overflow_Check (N);
DDC : constant Boolean := Do_Division_Check (N);
+ Left : Node_Id;
+ Right : Node_Id;
+
LLB : Uint;
Llo : Uint;
Lhi : Uint;
begin
Binary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
+ if Is_Integer_Type (Etype (N)) then
+ Apply_Divide_Checks (N);
+
+ -- All done if we don't have a MOD any more, which can happen as a
+ -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
+
+ if Nkind (N) /= N_Op_Mod then
+ return;
+ end if;
+ end if;
+
+ -- Proceed with expansion of mod operator
+
+ Left := Left_Opnd (N);
+ Right := Right_Opnd (N);
+
Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
Set_Entity (N, Standard_Entity (S_Op_Rem));
Set_Etype (N, Typ);
- Set_Do_Overflow_Check (N, DOC);
Set_Do_Division_Check (N, DDC);
Expand_N_Op_Rem (N);
Set_Analyzed (N);
-- Otherwise, normal mod processing
else
- if Is_Integer_Type (Etype (N)) then
- Apply_Divide_Check (N);
- end if;
-
-- Apply optimization x mod 1 = 0. We don't really need that with
-- gcc, but it is useful with other back ends (e.g. AAMP), and is
-- certainly harmless.
end if;
-- Deal with annoying case of largest negative number remainder
- -- minus one. Gigi does not handle this case correctly, because
- -- it generates a divide instruction which may trap in this case.
+ -- minus one. Gigi may not handle this case correctly, because
+ -- on some targets, the mod value is computed using a divide
+ -- instruction which gives an overflow trap for this case.
+
+ -- It would be a bit more efficient to figure out which targets
+ -- this is really needed for, but in practice it is reasonable
+ -- to do the following special check in all cases, since it means
+ -- we get a clearer message, and also the overhead is minimal given
+ -- that division is expensive in any case.
-- In fact the check is quite easy, if the right operand is -1, then
-- the mod value is always 0, and we can just ignore the left operand
-- completely in this case.
- -- The operand type may be private (e.g. in the expansion of an
- -- intrinsic operation) so we must use the underlying type to get the
- -- bounds, and convert the literals explicitly.
+ -- This only applies if we still have a mod operator. Skip if we
+ -- have already rewritten this (e.g. in the case of eliminated
+ -- overflow checks which have driven us into bignum mode).
- LLB :=
- Expr_Value
- (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
+ if Nkind (N) = N_Op_Mod then
- if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
- and then
- ((not LOK) or else (Llo = LLB))
- then
- Rewrite (N,
- Make_Conditional_Expression (Loc,
- Expressions => New_List (
- Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Right),
- Right_Opnd =>
- Unchecked_Convert_To (Typ,
- Make_Integer_Literal (Loc, -1))),
- Unchecked_Convert_To (Typ,
- Make_Integer_Literal (Loc, Uint_0)),
- Relocate_Node (N))));
+ -- The operand type may be private (e.g. in the expansion of an
+ -- intrinsic operation) so we must use the underlying type to get
+ -- the bounds, and convert the literals explicitly.
- Set_Analyzed (Next (Next (First (Expressions (N)))));
- Analyze_And_Resolve (N, Typ);
+ LLB :=
+ Expr_Value
+ (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
+
+ if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
+ and then
+ ((not LOK) or else (Llo = LLB))
+ then
+ Rewrite (N,
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr (Right),
+ Right_Opnd =>
+ Unchecked_Convert_To (Typ,
+ Make_Integer_Literal (Loc, -1))),
+ Unchecked_Convert_To (Typ,
+ Make_Integer_Literal (Loc, Uint_0)),
+ Relocate_Node (N))));
+
+ Set_Analyzed (Next (Next (First (Expressions (N)))));
+ Analyze_And_Resolve (N, Typ);
+ end if;
end if;
end if;
end Expand_N_Op_Mod;
begin
Binary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
-- Special optimizations for integer types
if Is_Integer_Type (Typ) then
then
Binary_Op_Validity_Checks (N);
+ -- Deal with overflow checks in MINIMIZED/ELIMINATED mode and if
+ -- means we no longer have a /= operation, we are all done.
+
+ Expand_Compare_Minimize_Eliminate_Overflow (N);
+
+ if Nkind (N) /= N_Op_Ne then
+ return;
+ end if;
+
-- Boolean types (requiring handling of non-standard case)
if Is_Boolean_Type (Typ) then
end;
end if;
- -- Only array types need any other processing. In formal verification
- -- mode, no other processing is done.
+ -- Only array types need any other processing
- if not Is_Array_Type (Typ) or else ALFA_Mode then
+ if not Is_Array_Type (Typ) then
return;
end if;
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
-
- -- Replace OR by OR ELSE if Short_Circuit_And_Or active and the type
- -- is standard Boolean (do not mess with AND that uses a non-standard
- -- Boolean type, because something strange is going on).
-
- if Short_Circuit_And_Or and then Typ = Standard_Boolean then
- Rewrite (N,
- Make_Or_Else (Sloc (N),
- Left_Opnd => Relocate_Node (Left_Opnd (N)),
- Right_Opnd => Relocate_Node (Right_Opnd (N))));
- Analyze_And_Resolve (N, Typ);
-
- -- Otherwise, adjust conditions
-
- else
- Adjust_Condition (Left_Opnd (N));
- Adjust_Condition (Right_Opnd (N));
- Set_Etype (N, Standard_Boolean);
- Adjust_Result_Type (N, Typ);
- end if;
+ Adjust_Condition (Left_Opnd (N));
+ Adjust_Condition (Right_Opnd (N));
+ Set_Etype (N, Standard_Boolean);
+ Adjust_Result_Type (N, Typ);
elsif Is_Intrinsic_Subprogram (Entity (N)) then
Expand_Intrinsic_Call (N, Entity (N));
procedure Expand_N_Op_Plus (N : Node_Id) is
begin
Unary_Op_Validity_Checks (N);
+
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
end Expand_N_Op_Plus;
---------------------
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
- Left : constant Node_Id := Left_Opnd (N);
- Right : constant Node_Id := Right_Opnd (N);
+ Left : Node_Id;
+ Right : Node_Id;
Lo : Uint;
Hi : Uint;
begin
Binary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
if Is_Integer_Type (Etype (N)) then
- Apply_Divide_Check (N);
+ Apply_Divide_Checks (N);
+
+ -- All done if we don't have a REM any more, which can happen as a
+ -- result of overflow expansion in MINIMIZED or ELIMINATED modes.
+
+ if Nkind (N) /= N_Op_Rem then
+ return;
+ end if;
end if;
+ -- Proceed with expansion of REM
+
+ Left := Left_Opnd (N);
+ Right := Right_Opnd (N);
+
-- Apply optimization x rem 1 = 0. We don't really need that with gcc,
-- but it is useful with other back ends (e.g. AAMP), and is certainly
-- harmless.
end if;
-- Deal with annoying case of largest negative number remainder minus
- -- one. Gigi does not handle this case correctly, because it generates
- -- a divide instruction which may trap in this case.
+ -- one. Gigi may not handle this case correctly, because on some
+ -- targets, the mod value is computed using a divide instruction
+ -- which gives an overflow trap for this case.
+
+ -- It would be a bit more efficient to figure out which targets this
+ -- is really needed for, but in practice it is reasonable to do the
+ -- following special check in all cases, since it means we get a clearer
+ -- message, and also the overhead is minimal given that division is
+ -- expensive in any case.
-- In fact the check is quite easy, if the right operand is -1, then
-- the remainder is always 0, and we can just ignore the left operand
if Lneg and Rneg then
Rewrite (N,
- Make_Conditional_Expression (Loc,
+ Make_If_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
begin
Binary_Op_Validity_Checks (N);
+ -- Check for MINIMIZED/ELIMINATED overflow mode
+
+ if Minimized_Eliminated_Overflow_Check (N) then
+ Apply_Arithmetic_Overflow_Check (N);
+ return;
+ end if;
+
-- N - 0 = N for integer types
if Is_Integer_Type (Typ)
begin
-- Do validity check if validity checking operands
- if Validity_Checks_On
- and then Validity_Check_Operands
- then
+ if Validity_Checks_On and then Validity_Check_Operands then
Ensure_Valid (Operand);
end if;
-- end if;
-- end loop;
- -- Conversely, an existentially quantified expression:
+ -- Similarly, an existentially quantified expression:
-- for some X in range => Cond
-- given by an iterator specification, not a loop parameter specification.
procedure Expand_N_Quantified_Expression (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Is_Universal : constant Boolean := All_Present (N);
- Actions : constant List_Id := New_List;
- Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
- Cond : Node_Id;
- Decl : Node_Id;
- I_Scheme : Node_Id;
- Test : Node_Id;
+ Actions : constant List_Id := New_List;
+ For_All : constant Boolean := All_Present (N);
+ Iter_Spec : constant Node_Id := Iterator_Specification (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Loop_Spec : constant Node_Id := Loop_Parameter_Specification (N);
+ Cond : Node_Id;
+ Flag : Entity_Id;
+ Scheme : Node_Id;
+ Stmts : List_Id;
begin
- -- Do not expand quantified expressions in ALFA mode
- -- why not???
+ -- Create the declaration of the flag which tracks the status of the
+ -- quantified expression. Generate:
- if ALFA_Mode then
- return;
- end if;
+ -- Flag : Boolean := (True | False);
+
+ Flag := Make_Temporary (Loc, 'T', N);
- Decl :=
+ Append_To (Actions,
Make_Object_Declaration (Loc,
- Defining_Identifier => Tnn,
+ Defining_Identifier => Flag,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
- New_Occurrence_Of (Boolean_Literals (Is_Universal), Loc));
- Append_To (Actions, Decl);
+ New_Occurrence_Of (Boolean_Literals (For_All), Loc)));
- Cond := Relocate_Node (Condition (N));
+ -- Construct the circuitry which tracks the status of the quantified
+ -- expression. Generate:
- -- Reset flag analyzed in the condition to force its analysis. Required
- -- since the previous analysis was done with expansion disabled (see
- -- Resolve_Quantified_Expression) and hence checks were not inserted
- -- and record comparisons have not been expanded.
+ -- if [not] Cond then
+ -- Flag := (False | True);
+ -- exit;
+ -- end if;
- Reset_Analyzed_Flags (Cond);
+ Cond := Relocate_Node (Condition (N));
- if Is_Universal then
+ if For_All then
Cond := Make_Op_Not (Loc, Cond);
end if;
- Test :=
+ Stmts := New_List (
Make_Implicit_If_Statement (N,
Condition => Cond,
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Tnn, Loc),
+ Name => New_Occurrence_Of (Flag, Loc),
Expression =>
- New_Occurrence_Of (Boolean_Literals (not Is_Universal), Loc)),
- Make_Exit_Statement (Loc)));
+ New_Occurrence_Of (Boolean_Literals (not For_All), Loc)),
+ Make_Exit_Statement (Loc))));
+
+ -- Build the loop equivalent of the quantified expression
- if Present (Loop_Parameter_Specification (N)) then
- I_Scheme :=
+ if Present (Iter_Spec) then
+ Scheme :=
Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Loop_Parameter_Specification (N));
+ Iterator_Specification => Iter_Spec);
else
- I_Scheme :=
+ Scheme :=
Make_Iteration_Scheme (Loc,
- Iterator_Specification => Iterator_Specification (N));
+ Loop_Parameter_Specification => Loop_Spec);
end if;
Append_To (Actions,
Make_Loop_Statement (Loc,
- Iteration_Scheme => I_Scheme,
- Statements => New_List (Test),
+ Iteration_Scheme => Scheme,
+ Statements => Stmts,
End_Label => Empty));
- -- The components of the scheme have already been analyzed, and the loop
- -- parameter declaration has been processed.
-
- Set_Analyzed (Iteration_Scheme (Last (Actions)));
+ -- Transform the quantified expression
Rewrite (N,
Make_Expression_With_Actions (Loc,
- Expression => New_Occurrence_Of (Tnn, Loc),
+ Expression => New_Occurrence_Of (Flag, Loc),
Actions => Actions));
-
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_N_Quantified_Expression;
-- Expand_N_Selected_Component --
---------------------------------
- -- If the selector is a discriminant of a concurrent object, rewrite the
- -- prefix to denote the corresponding record type.
-
procedure Expand_N_Selected_Component (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Par : constant Node_Id := Parent (N);
-- Insert explicit dereference if required
if Is_Access_Type (Ptyp) then
+
+ -- First set prefix type to proper access type, in case it currently
+ -- has a private (non-access) view of this type.
+
+ Set_Etype (P, Ptyp);
+
Insert_Explicit_Dereference (P);
Analyze_And_Resolve (P, Designated_Type (Ptyp));
Rewrite (N, New_N);
Analyze (N);
end if;
+
+ -- Set Atomic_Sync_Required if necessary for atomic component
+
+ if Nkind (N) = N_Selected_Component then
+ declare
+ E : constant Entity_Id := Entity (Selector_Name (N));
+ Set : Boolean;
+
+ begin
+ -- If component is atomic, but type is not, setting depends on
+ -- disable/enable state for the component.
+
+ if Is_Atomic (E) and then not Is_Atomic (Etype (E)) then
+ Set := not Atomic_Synchronization_Disabled (E);
+
+ -- If component is not atomic, but its type is atomic, setting
+ -- depends on disable/enable state for the type.
+
+ elsif not Is_Atomic (E) and then Is_Atomic (Etype (E)) then
+ Set := not Atomic_Synchronization_Disabled (Etype (E));
+
+ -- If both component and type are atomic, we disable if either
+ -- component or its type have sync disabled.
+
+ elsif Is_Atomic (E) and then Is_Atomic (Etype (E)) then
+ Set := (not Atomic_Synchronization_Disabled (E))
+ and then
+ (not Atomic_Synchronization_Disabled (Etype (E)));
+
+ else
+ Set := False;
+ end if;
+
+ -- Set flag if required
+
+ if Set then
+ Activate_Atomic_Synchronization (N);
+ end if;
+ end;
+ end if;
end Expand_N_Selected_Component;
--------------------
procedure Real_Range_Check;
-- Handles generation of range check for real target value
+ function Has_Extra_Accessibility (Id : Entity_Id) return Boolean;
+ -- True iff Present (Effective_Extra_Accessibility (Id)) successfully
+ -- evaluates to True.
+
-----------------------------------
-- Handle_Changed_Representation --
-----------------------------------
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Target_Type);
- Error_Msg_N ("?accessibility check failure", N);
+ Error_Msg_N
+ ("??accessibility check failure", N);
Error_Msg_NE
- ("\?& will be raised at run time", N, Standard_Program_Error);
+ ("\??& will be raised at run time", N, Standard_Program_Error);
end Raise_Accessibility_Error;
----------------------
Analyze_And_Resolve (N, Btyp);
end Real_Range_Check;
+ -----------------------------
+ -- Has_Extra_Accessibility --
+ -----------------------------
+
+ -- Returns true for a formal of an anonymous access type or for
+ -- an Ada 2012-style stand-alone object of an anonymous access type.
+
+ function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
+ begin
+ if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
+ return Present (Effective_Extra_Accessibility (Id));
+ else
+ return False;
+ end if;
+ end Has_Extra_Accessibility;
+
-- Start of processing for Expand_N_Type_Conversion
begin
-- as tagged type checks).
if Is_Entity_Name (Operand)
- and then
- (Is_Formal (Entity (Operand))
- or else
- (Present (Renamed_Object (Entity (Operand)))
- and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
- and then Is_Formal
- (Entity (Renamed_Object (Entity (Operand))))))
+ and then Has_Extra_Accessibility (Entity (Operand))
and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
or else Attribute_Name (Original_Node (N)) = Name_Access)
-- of the object designated by the result value identifies T.
-- Constraint_Error is raised if this check fails.
- if Nkind (Parent (N)) = Sinfo.N_Return_Statement then
+ if Nkind (Parent (N)) = N_Simple_Return_Statement then
declare
Func : Entity_Id;
Func_Typ : Entity_Id;
then
-- To prevent Gigi from generating illegal code, we generate a
-- Program_Error node, but we give it the target type of the
- -- conversion.
+ -- conversion (is this requirement documented somewhere ???)
declare
PE : constant Node_Id := Make_Raise_Program_Error (Loc,
-- Convert: x(y) to x'val (ytyp'val (y))
Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Target_Type, Loc),
- Attribute_Name => Name_Val,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Operand_Type, Loc),
- Attribute_Name => Name_Pos,
- Expressions => New_List (Operand)))));
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Target_Type, Loc),
+ Attribute_Name => Name_Val,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Operand_Type, Loc),
+ Attribute_Name => Name_Pos,
+ Expressions => New_List (Operand)))));
Analyze_And_Resolve (N, Target_Type);
end if;
end if;
-- Otherwise force evaluation unless Assignment_OK flag is set (this
- -- flag indicates ??? -- more comments needed here)
+ -- flag indicates ??? More comments needed here)
if Assignment_OK (N) then
null;
then
return Suitable_Element (Next_Entity (C));
+ -- Below test for C /= Original_Record_Component (C) is dubious
+ -- if Typ is a constrained record subtype???
+
elsif Is_Tagged_Type (Typ)
and then C /= Original_Record_Component (C)
then
return Result;
end Expand_Record_Equality;
+ ---------------------------
+ -- Expand_Set_Membership --
+ ---------------------------
+
+ procedure Expand_Set_Membership (N : Node_Id) is
+ Lop : constant Node_Id := Left_Opnd (N);
+ Alt : Node_Id;
+ Res : Node_Id;
+
+ function Make_Cond (Alt : Node_Id) return Node_Id;
+ -- If the alternative is a subtype mark, create a simple membership
+ -- test. Otherwise create an equality test for it.
+
+ ---------------
+ -- Make_Cond --
+ ---------------
+
+ function Make_Cond (Alt : Node_Id) return Node_Id is
+ Cond : Node_Id;
+ L : constant Node_Id := New_Copy (Lop);
+ R : constant Node_Id := Relocate_Node (Alt);
+
+ begin
+ if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
+ or else Nkind (Alt) = N_Range
+ then
+ Cond :=
+ Make_In (Sloc (Alt),
+ Left_Opnd => L,
+ Right_Opnd => R);
+ else
+ Cond :=
+ Make_Op_Eq (Sloc (Alt),
+ Left_Opnd => L,
+ Right_Opnd => R);
+ end if;
+
+ return Cond;
+ end Make_Cond;
+
+ -- Start of processing for Expand_Set_Membership
+
+ begin
+ Remove_Side_Effects (Lop);
+
+ Alt := Last (Alternatives (N));
+ Res := Make_Cond (Alt);
+
+ Prev (Alt);
+ while Present (Alt) loop
+ Res :=
+ Make_Or_Else (Sloc (Alt),
+ Left_Opnd => Make_Cond (Alt),
+ Right_Opnd => Res);
+ Prev (Alt);
+ end loop;
+
+ Rewrite (N, Res);
+ Analyze_And_Resolve (N, Standard_Boolean);
+ end Expand_Set_Membership;
+
-----------------------------------
-- Expand_Short_Circuit_Operator --
-----------------------------------
--------------------------------
function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
- Sel_Comp : Node_Id := N;
+ Sel_Comp : Node_Id;
begin
-- Move to the left-most prefix by climbing up the tree
+ Sel_Comp := N;
while Present (Parent (Sel_Comp))
and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
loop
-- Start of processing for Has_Inferable_Discriminants
begin
- -- For identifiers and indexed components, it is sufficient to have a
- -- constrained Unchecked_Union nominal subtype.
-
- if Nkind_In (N, N_Identifier, N_Indexed_Component) then
- return Is_Unchecked_Union (Base_Type (Etype (N)))
- and then
- Is_Constrained (Etype (N));
-
-- For selected components, the subtype of the selector must be a
-- constrained Unchecked_Union. If the component is subject to a
-- per-object constraint, then the enclosing object must have inferable
-- discriminants.
- elsif Nkind (N) = N_Selected_Component then
+ if Nkind (N) = N_Selected_Component then
if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
-- A small hack. If we have a per-object constrained selected
if Prefix_Is_Formal_Parameter (N) then
return True;
- end if;
-- Otherwise, check the enclosing object and the selector
- return Has_Inferable_Discriminants (Prefix (N))
- and then
- Has_Inferable_Discriminants (Selector_Name (N));
- end if;
+ else
+ return Has_Inferable_Discriminants (Prefix (N))
+ and then Has_Inferable_Discriminants (Selector_Name (N));
+ end if;
-- The call to Has_Inferable_Discriminants will determine whether
-- the selector has a constrained Unchecked_Union nominal type.
- return Has_Inferable_Discriminants (Selector_Name (N));
+ else
+ return Has_Inferable_Discriminants (Selector_Name (N));
+ end if;
-- A qualified expression has inferable discriminants if its subtype
-- mark is a constrained Unchecked_Union subtype.
elsif Nkind (N) = N_Qualified_Expression then
- return Is_Unchecked_Union (Subtype_Mark (N))
- and then
- Is_Constrained (Subtype_Mark (N));
+ return Is_Unchecked_Union (Etype (Subtype_Mark (N)))
+ and then Is_Constrained (Etype (Subtype_Mark (N)));
- end if;
+ -- For all other names, it is sufficient to have a constrained
+ -- Unchecked_Union nominal subtype.
- return False;
+ else
+ return Is_Unchecked_Union (Base_Type (Etype (N)))
+ and then Is_Constrained (Etype (N));
+ end if;
end Has_Inferable_Discriminants;
-------------------------------
-------------------------------
procedure Insert_Dereference_Action (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
- Pnod : constant Node_Id := Parent (N);
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
-- Return true if type of P is derived from Checked_Pool;
return False;
end Is_Checked_Storage_Pool;
+ -- Local variables
+
+ Typ : constant Entity_Id := Etype (N);
+ Desig : constant Entity_Id := Available_View (Designated_Type (Typ));
+ Loc : constant Source_Ptr := Sloc (N);
+ Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
+ Pnod : constant Node_Id := Parent (N);
+
+ Addr : Entity_Id;
+ Alig : Entity_Id;
+ Deref : Node_Id;
+ Size : Entity_Id;
+ Stmt : Node_Id;
+
-- Start of processing for Insert_Dereference_Action
begin
pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
- if not (Is_Checked_Storage_Pool (Pool)
- and then Comes_From_Source (Original_Node (Pnod)))
- then
+ -- Do not re-expand a dereference which has already been processed by
+ -- this routine.
+
+ if Has_Dereference_Action (Pnod) then
+ return;
+
+ -- Do not perform this type of expansion for internally-generated
+ -- dereferences.
+
+ elsif not Comes_From_Source (Original_Node (Pnod)) then
+ return;
+
+ -- A dereference action is only applicable to objects which have been
+ -- allocated on a checked pool.
+
+ elsif not Is_Checked_Storage_Pool (Pool) then
return;
end if;
+ -- Extract the address of the dereferenced object. Generate:
+
+ -- Addr : System.Address := <N>'Pool_Address;
+
+ Addr := Make_Temporary (Loc, 'P');
+
Insert_Action (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Reference_To (
- Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Addr,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Address), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr_Move_Checks (N),
+ Attribute_Name => Name_Pool_Address)));
- Parameter_Associations => New_List (
+ -- Calculate the size of the dereferenced object. Generate:
- -- Pool
+ -- Size : Storage_Count := <N>.all'Size / Storage_Unit;
- New_Reference_To (Pool, Loc),
+ Deref :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => Duplicate_Subexpr_Move_Checks (N));
+ Set_Has_Dereference_Action (Deref);
- -- Storage_Address. We use the attribute Pool_Address, which uses
- -- the pointer itself to find the address of the object, and which
- -- handles unconstrained arrays properly by computing the address
- -- of the template. i.e. the correct address of the corresponding
- -- allocation.
+ Size := Make_Temporary (Loc, 'S');
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr_Move_Checks (N),
- Attribute_Name => Name_Pool_Address),
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size,
- -- Size_In_Storage_Elements
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Storage_Count), Loc),
- Make_Op_Divide (Loc,
- Left_Opnd =>
+ Expression =>
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- Duplicate_Subexpr_Move_Checks (N)),
+ Prefix => Deref,
Attribute_Name => Name_Size),
Right_Opnd =>
- Make_Integer_Literal (Loc, System_Storage_Unit)),
+ Make_Integer_Literal (Loc, System_Storage_Unit))));
- -- Alignment
+ -- Calculate the alignment of the dereferenced object. Generate:
+ -- Alig : constant Storage_Count := <N>.all'Alignment;
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- Duplicate_Subexpr_Move_Checks (N)),
- Attribute_Name => Name_Alignment))));
+ Deref :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => Duplicate_Subexpr_Move_Checks (N));
+ Set_Has_Dereference_Action (Deref);
+
+ Alig := Make_Temporary (Loc, 'A');
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Alig,
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Storage_Count), Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Deref,
+ Attribute_Name => Name_Alignment)));
+
+ -- A dereference of a controlled object requires special processing. The
+ -- finalization machinery requests additional space from the underlying
+ -- pool to allocate and hide two pointers. As a result, a checked pool
+ -- may mark the wrong memory as valid. Since checked pools do not have
+ -- knowledge of hidden pointers, we have to bring the two pointers back
+ -- in view in order to restore the original state of the object.
+
+ if Needs_Finalization (Desig) then
+
+ -- Adjust the address and size of the dereferenced object. Generate:
+ -- Adjust_Controlled_Dereference (Addr, Size, Alig);
+
+ Stmt :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Adjust_Controlled_Dereference), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (Addr, Loc),
+ New_Reference_To (Size, Loc),
+ New_Reference_To (Alig, Loc)));
+
+ -- Class-wide types complicate things because we cannot determine
+ -- statically whether the actual object is truly controlled. We must
+ -- generate a runtime check to detect this property. Generate:
+ --
+ -- if Needs_Finalization (<N>.all'Tag) then
+ -- <Stmt>;
+ -- end if;
+
+ if Is_Class_Wide_Type (Desig) then
+ Deref :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => Duplicate_Subexpr_Move_Checks (N));
+ Set_Has_Dereference_Action (Deref);
+
+ Stmt :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Needs_Finalization), Loc),
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Deref,
+ Attribute_Name => Name_Tag))),
+ Then_Statements => New_List (Stmt));
+ end if;
+
+ Insert_Action (N, Stmt);
+ end if;
+
+ -- Generate:
+ -- Dereference (Pool, Addr, Size, Alig);
+
+ Insert_Action (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To
+ (Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (Pool, Loc),
+ New_Reference_To (Addr, Loc),
+ New_Reference_To (Size, Loc),
+ New_Reference_To (Alig, Loc))));
+
+ -- Mark the explicit dereference as processed to avoid potential
+ -- infinite expansion.
+
+ Set_Has_Dereference_Action (Pnod);
exception
when RE_Not_Available =>
return Func_Body;
end Make_Boolean_Array_Op;
+ -----------------------------------------
+ -- Minimized_Eliminated_Overflow_Check --
+ -----------------------------------------
+
+ function Minimized_Eliminated_Overflow_Check (N : Node_Id) return Boolean is
+ begin
+ return
+ Is_Signed_Integer_Type (Etype (N))
+ and then Overflow_Check_Mode in Minimized_Or_Eliminated;
+ end Minimized_Eliminated_Overflow_Check;
+
--------------------------------
-- Optimize_Length_Comparison --
--------------------------------
if Constant_Condition_Warnings
and then Comes_From_Source (Original_Node (N))
then
- Error_Msg_N ("could replace by ""'=""?", N);
+ Error_Msg_N ("could replace by ""'=""?c?", N);
end if;
Op := N_Op_Eq;
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
- ("can never be greater than, could replace by ""'=""?", N);
+ ("can never be greater than, could replace by ""'=""?c?",
+ N);
Warning_Generated := True;
end if;
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
Error_Msg_N
- ("can never be less than, could replace by ""'=""?", N);
+ ("can never be less than, could replace by ""'=""?c?", N);
Warning_Generated := True;
end if;
if AV = False then
if True_Result or False_Result then
- if True_Result then
- Result := Standard_True;
- else
- Result := Standard_False;
- end if;
-
+ Result := Boolean_Literals (True_Result);
Rewrite (N,
Convert_To (Typ,
New_Occurrence_Of (Result, Sloc (N))));
then
if True_Result then
Error_Msg_N
- ("condition can only be False if invalid values present?",
+ ("condition can only be False if invalid values present??",
N);
elsif False_Result then
Error_Msg_N
- ("condition can only be True if invalid values present?",
+ ("condition can only be True if invalid values present??",
N);
end if;
end if;
end if;
end Is_Safe_Operand;
- -- Start of processing for Is_Safe_In_Place_Array_Op
+ -- Start of processing for Safe_In_Place_Array_Op
begin
-- Skip this processing if the component size is different from system
Left_Type := Available_View (Etype (Left));
Right_Type := Available_View (Etype (Right));
+ -- In the case where the type is an access type, the test is applied
+ -- using the designated types (needed in Ada 2012 for implicit anonymous
+ -- access conversions, for AI05-0149).
+
+ if Is_Access_Type (Right_Type) then
+ Left_Type := Designated_Type (Left_Type);
+ Right_Type := Designated_Type (Right_Type);
+ end if;
+
if Is_Class_Wide_Type (Left_Type) then
Left_Type := Root_Type (Left_Type);
end if;
projects / gcc.git / blobdiff