-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
+with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
+with SCIL_LL; use SCIL_LL;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-- Common expansion processing for Boolean operators (And, Or, Xor) for the
-- case of array type arguments.
+ procedure Expand_Short_Circuit_Operator (N : Node_Id);
+ -- Common expansion processing for short-circuit boolean operators
+
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
-- its expression. If N is neither comparison nor a type conversion, the
-- call has no effect.
- function Tagged_Membership (N : Node_Id) return Node_Id;
+ procedure Tagged_Membership
+ (N : Node_Id;
+ SCIL_Node : out Node_Id;
+ Result : out Node_Id);
-- Construct the expression corresponding to the tagged membership test.
-- Deals with a second operand being (or not) a class-wide type.
Prefix => Name (N),
Attribute_Name => Name_Address);
- Arg1 : constant Node_Id := Op1;
+ Arg1 : Node_Id := Op1;
Arg2 : Node_Id := Op2;
Call_Node : Node_Id;
Proc_Name : Entity_Id;
-- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
if Nkind (Op1) = N_Op_Not then
+ Arg1 := Right_Opnd (Op1);
+ Arg2 := Right_Opnd (Op2);
if Kind = N_Op_And then
Proc_Name := RTE (RE_Vector_Nor);
-
elsif Kind = N_Op_Or then
Proc_Name := RTE (RE_Vector_Nand);
-
else
Proc_Name := RTE (RE_Vector_Xor);
end if;
else
if Kind = N_Op_And then
Proc_Name := RTE (RE_Vector_And);
-
elsif Kind = N_Op_Or then
Proc_Name := RTE (RE_Vector_Or);
-
elsif Nkind (Op2) = N_Op_Not then
Proc_Name := RTE (RE_Vector_Nxor);
Arg2 := Right_Opnd (Op2);
-
else
Proc_Name := RTE (RE_Vector_Xor);
end if;
Name => New_Occurrence_Of (Proc_Name, Loc),
Parameter_Associations => New_List (
Target,
- Make_Attribute_Reference (Loc,
- Prefix => Arg1,
- Attribute_Name => Name_Address),
- Make_Attribute_Reference (Loc,
- Prefix => Arg2,
- Attribute_Name => Name_Address),
- Make_Attribute_Reference (Loc,
- Prefix => Op1,
- Attribute_Name => Name_Length)));
+ Make_Attribute_Reference (Loc,
+ Prefix => Arg1,
+ Attribute_Name => Name_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix => Arg2,
+ Attribute_Name => Name_Address),
+ Make_Attribute_Reference (Loc,
+ Prefix => Arg1,
+ Attribute_Name => Name_Length)));
end if;
Rewrite (N, Call_Node);
-- Do nothing in case of VM targets: the virtual machine will handle
-- interfaces directly.
- if VM_Target /= No_VM then
+ if not Tagged_Type_Expansion then
return;
end if;
and then Nkind (Orig_Node) = N_Allocator);
PtrT := Etype (Orig_Node);
- Dtyp := Designated_Type (PtrT);
+ Dtyp := Available_View (Designated_Type (PtrT));
Etyp := Etype (Expression (Orig_Node));
if Is_Class_Wide_Type (Dtyp)
-- there does not seem to be any practical way of implementing it.
if Ada_Version >= Ada_05
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
and then Is_Class_Wide_Type (DesigT)
and then not Scope_Suppress (Accessibility_Check)
and then
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,...); Pnnn
+
+ -- Allocate the object with no 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);
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (PtrT, Loc),
+ Expression => Node));
+
+ Apply_Accessibility_Check (Temp);
+
+ -- Locate the enclosing list and insert the C++ constructor call
+
+ declare
+ P : Node_Id;
+
+ begin
+ P := Parent (Node);
+ while not Is_List_Member (P) loop
+ P := Parent (P);
+ end loop;
+
+ 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;
+
+ Rewrite (N, New_Reference_To (Temp, Loc));
+ Analyze_And_Resolve (N, PtrT);
+ return;
+ end if;
+
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object
-- must be passed to the function. Currently we limit such functions
Remove_Side_Effects (Exp);
end if;
- Temp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Temp := Make_Temporary (Loc, 'P', N);
-- For a class wide allocation generate the following code:
if Is_Class_Wide_Type (Etype (Exp))
and then Is_Interface (Etype (Exp))
- and then VM_Target = No_VM
+ and then Tagged_Type_Expansion
then
Set_Expression
(Expression (N),
else
declare
- Def_Id : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('T'));
+ Def_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
New_Decl : Node_Id;
begin
New_Decl :=
Make_Object_Declaration (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc,
- New_Internal_Name ('P')),
+ Defining_Identifier => Make_Temporary (Loc, 'P'),
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Unchecked_Convert_To (PtrT,
New_Reference_To (Temp, Loc)));
-- Suppress the tag assignment when VM_Target because VM tags are
-- represented implicitly in objects.
- if VM_Target /= No_VM then
+ if not Tagged_Type_Expansion then
null;
-- Ada 2005 (AI-251): Suppress the tag assignment with class-wide
if Is_RTE (Apool, RE_SS_Pool) then
declare
- F : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('F'));
+ F : constant Entity_Id := Make_Temporary (Loc, 'F');
begin
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => F,
- Object_Definition => New_Reference_To (RTE
- (RE_Finalizable_Ptr), Loc)));
-
+ Object_Definition =>
+ New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
Flist := New_Reference_To (F, Loc);
Attach := Make_Integer_Literal (Loc, 1);
end;
-- want to Adjust.
if not Aggr_In_Place
- and then not Is_Inherently_Limited_Type (T)
+ and then not Is_Immutably_Limited_Type (T)
then
Insert_Actions (N,
Make_Adjust_Call (
end if;
elsif Aggr_In_Place then
- Temp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Temp := Make_Temporary (Loc, 'P', N);
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Apply_Constraint_Check (Exp, T, No_Sliding => True);
+ if Do_Range_Check (Exp) then
+ Set_Do_Range_Check (Exp, False);
+ Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
+ end if;
+
-- A check is also needed in cases where the designated subtype is
-- constrained and differs from the subtype given in the qualified
-- expression. Note that the check on the qualified expression does
then
Apply_Constraint_Check
(Exp, DesigT, No_Sliding => False);
+
+ if Do_Range_Check (Exp) then
+ Set_Do_Range_Check (Exp, False);
+ Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
+ end if;
end if;
-- For an access to unconstrained packed array, GIGI needs to see an
and then Is_Packed (T)
then
declare
- ConstrT : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
Internal_Exp : constant Node_Id := Relocate_Node (Exp);
begin
Insert_Action (Exp,
-- constrained types, then we can use the same index for both
-- of the arrays.
- An : constant Entity_Id := Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('A'));
+ An : constant Entity_Id := Make_Temporary (Loc, 'A');
Bn : Entity_Id;
Index_T : Entity_Id;
Index_T := Base_Type (Etype (Index));
if Need_Separate_Indexes then
- Bn :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('B'));
+ Bn := Make_Temporary (Loc, 'B');
else
Bn := An;
end if;
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Rtyp, Loc)));
- Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Func_Name := Make_Temporary (Loc, 'E');
-- Build statement sequence for function
Lhs_Discr_Val,
Rhs_Discr_Val));
end;
+
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Eq_Op, Loc),
+ Parameter_Associations => New_List (Lhs, Rhs));
end if;
+ end if;
- -- Shouldn't this be an else, we can't fall through the above
- -- IF, right???
+ elsif Ada_Version >= Ada_2012 then
- return
- Make_Function_Call (Loc,
- Name => New_Reference_To (Eq_Op, Loc),
- Parameter_Associations => New_List (Lhs, Rhs));
- end if;
+ -- if no TSS has been created for the type, check whether there is
+ -- a primitive equality declared for it. If it is abstract replace
+ -- the call with an explicit raise (AI05-0123).
+
+ declare
+ Prim : Elmt_Id;
+
+ begin
+ Prim := First_Elmt (Collect_Primitive_Operations (Full_Type));
+ while Present (Prim) loop
+
+ -- Locate primitive equality with the right signature
+
+ if Chars (Node (Prim)) = Name_Op_Eq
+ and then Etype (First_Formal (Node (Prim))) =
+ Etype (Next_Formal (First_Formal (Node (Prim))))
+ and then Etype (Node (Prim)) = Standard_Boolean
+ then
+ if Is_Abstract_Subprogram (Node (Prim)) then
+ return
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Explicit_Raise);
+ else
+ return
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Node (Prim), Loc),
+ Parameter_Associations => New_List (Lhs, Rhs));
+ end if;
+ end if;
+
+ Next_Elmt (Prim);
+ end loop;
+ end;
+
+ -- Use predefined equality iff no user-defined primitive exists
+
+ return Make_Op_Eq (Loc, Lhs, Rhs);
else
return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
end if;
else
- -- It can be a simple record or the full view of a scalar private
+ -- If not array or record type, it is predefined equality.
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
end if;
Operands (NN) := Opnd;
Is_Fixed_Length (NN) := False;
- Var_Length (NN) :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
+ Var_Length (NN) := Make_Temporary (Loc, 'L');
Append_To (Actions,
Make_Object_Declaration (Loc,
-- create an entity initialized to this length.
else
- Ent :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
+ Ent := Make_Temporary (Loc, 'L');
if Is_Fixed_Length (NN) then
Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
end Get_Known_Bound;
begin
- Ent :=
- Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('L'));
+ Ent := Make_Temporary (Loc, 'L');
Append_To (Actions,
Make_Object_Declaration (Loc,
Insert_Actions (Cnode, Actions, Suppress => All_Checks);
- -- Now we construct an array object with appropriate bounds
+ -- Now we construct an array object with appropriate bounds. We mark
+ -- the target as internal to prevent useless initialization when
+ -- Initialize_Scalars is enabled.
- Ent :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ Ent := Make_Temporary (Loc, 'S');
+ Set_Is_Internal (Ent);
-- If the bound is statically known to be out of range, we do not want
-- to abort, we want a warning and a runtime constraint error. Note that
procedure Expand_N_Allocator (N : Node_Id) is
PtrT : constant Entity_Id := Etype (N);
- Dtyp : constant Entity_Id := Designated_Type (PtrT);
+ 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;
declare
Decl : Node_Id;
Outer_S : Entity_Id;
- S : Entity_Id := Current_Scope;
+ S : Entity_Id;
begin
+ S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop
if Ekind (S) = E_Function then
Outer_S := Scope (S);
-------------------------
procedure Rewrite_Coextension (N : Node_Id) is
- Temp : constant Node_Id :=
- Make_Defining_Identifier (Loc,
- New_Internal_Name ('C'));
+ Temp : constant Node_Id := Make_Temporary (Loc, 'C');
-- Generate:
-- Cnn : aliased Etyp;
-- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
-- marked as requiring static allocation.
- Temp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
-
+ Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
Desig := Subtype_Mark (Expression (N));
-- If context is constrained, use constrained subtype directly,
if not Restriction_Active (No_Default_Initialization) then
Init := Base_Init_Proc (T);
Nod := N;
- Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Temp := Make_Temporary (Loc, 'P');
-- Construct argument list for the initialization routine call
if Has_Task (T) then
if No (Master_Id (Base_Type (PtrT))) then
- -- If we have a non-library level task with restriction
- -- No_Task_Hierarchy set, then no point in expanding.
-
- if not Is_Library_Level_Entity (T)
- and then Restriction_Active (No_Task_Hierarchy)
- then
- return;
- end if;
-
-- The designated type was an incomplete type, and the
-- access type did not get expanded. Salvage it now.
- pragma Assert (Present (Parent (Base_Type (PtrT))));
- Expand_N_Full_Type_Declaration
- (Parent (Base_Type (PtrT)));
+ if not Restriction_Active (No_Task_Hierarchy) then
+ pragma Assert (Present (Parent (Base_Type (PtrT))));
+ Expand_N_Full_Type_Declaration
+ (Parent (Base_Type (PtrT)));
+ end if;
end if;
-- If the context of the allocator is a declaration or an
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
- Append_To (Args,
- New_Reference_To
- (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
+ if Restriction_Active (No_Task_Hierarchy) then
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Library_Task_Level), Loc));
+ else
+ Append_To (Args,
+ New_Reference_To
+ (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
+ end if;
+
Append_To (Args, Make_Identifier (Loc, Name_uChain));
Decl := Last (Decls);
Append_To (Args,
New_Occurrence_Of (Defining_Identifier (Decl), Loc));
- -- Has_Task is false, Decls not used
+ -- Has_Task is false, Decls not used
else
Decls := No_List;
-- Expand_N_And_Then --
-----------------------
- -- Expand into conditional expression if Actions present, and also deal
- -- with optimizing case of arguments being True or False.
+ procedure Expand_N_And_Then (N : Node_Id)
+ renames Expand_Short_Circuit_Operator;
+
+ ------------------------------
+ -- Expand_N_Case_Expression --
+ ------------------------------
- procedure Expand_N_And_Then (N : Node_Id) is
+ procedure Expand_N_Case_Expression (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);
- Actlist : List_Id;
+ Cstmt : Node_Id;
+ Tnn : Entity_Id;
+ Pnn : Entity_Id;
+ Actions : List_Id;
+ Ttyp : Entity_Id;
+ Alt : Node_Id;
+ Fexp : Node_Id;
begin
- -- Deal with non-standard booleans
+ -- We expand
+
+ -- case X is when A => AX, when B => BX ...
+
+ -- to
+
+ -- do
+ -- Tnn : typ;
+ -- case X is
+ -- when A =>
+ -- Tnn := AX;
+ -- when B =>
+ -- Tnn := BX;
+ -- ...
+ -- end case;
+ -- in Tnn end;
+
+ -- However, this expansion is wrong for limited types, and also
+ -- 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:
+
+ -- do
+ -- type Pnn is access all typ;
+ -- Tnn : Pnn;
+ -- case X is
+ -- when A =>
+ -- T := AX'Unrestricted_Access;
+ -- when B =>
+ -- T := BX'Unrestricted_Access;
+ -- ...
+ -- end case;
+ -- in Tnn.all end;
+
+ Cstmt :=
+ Make_Case_Statement (Loc,
+ Expression => Expression (N),
+ Alternatives => New_List);
+
+ Actions := New_List;
+
+ -- Scalar case
+
+ if Is_Scalar_Type (Typ) then
+ Ttyp := Typ;
- if Is_Boolean_Type (Typ) then
- Adjust_Condition (Left);
- Adjust_Condition (Right);
- Set_Etype (N, Standard_Boolean);
+ else
+ Pnn := Make_Temporary (Loc, 'P');
+ Append_To (Actions,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Pnn,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication =>
+ New_Reference_To (Typ, Loc))));
+ Ttyp := Pnn;
end if;
- -- Check for cases where left argument is known to be True or False
+ Tnn := Make_Temporary (Loc, 'T');
+ Append_To (Actions,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Tnn,
+ Object_Definition => New_Occurrence_Of (Ttyp, Loc)));
- if Compile_Time_Known_Value (Left) then
+ -- Now process the alternatives
- -- If left argument is True, change (True and then Right) to Right.
- -- Any actions associated with Right will be executed unconditionally
- -- and can thus be inserted into the tree unconditionally.
+ Alt := First (Alternatives (N));
+ while Present (Alt) loop
+ declare
+ Aexp : Node_Id := Expression (Alt);
+ Aloc : constant Source_Ptr := Sloc (Aexp);
- if Expr_Value_E (Left) = Standard_True then
- if Present (Actions (N)) then
- Insert_Actions (N, Actions (N));
+ begin
+ if not Is_Scalar_Type (Typ) then
+ Aexp :=
+ Make_Attribute_Reference (Aloc,
+ Prefix => Relocate_Node (Aexp),
+ Attribute_Name => Name_Unrestricted_Access);
end if;
- Rewrite (N, Right);
-
- -- If left argument is False, change (False and then Right) to False.
- -- In this case we can forget the actions associated with Right,
- -- since they will never be executed.
-
- else pragma Assert (Expr_Value_E (Left) = Standard_False);
- Kill_Dead_Code (Right);
- Kill_Dead_Code (Actions (N));
- Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
- end if;
-
- Adjust_Result_Type (N, Typ);
- return;
- end if;
-
- -- If Actions are present, we expand
-
- -- left and then right
-
- -- into
+ 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))));
+ end;
- -- if left then right else false end
+ Next (Alt);
+ end loop;
- -- with the actions becoming the Then_Actions of the conditional
- -- expression. This conditional expression is then further expanded
- -- (and will eventually disappear)
+ Append_To (Actions, Cstmt);
- if Present (Actions (N)) then
- Actlist := Actions (N);
- Rewrite (N,
- Make_Conditional_Expression (Loc,
- Expressions => New_List (
- Left,
- Right,
- New_Occurrence_Of (Standard_False, Loc))));
+ -- Construct and return final expression with actions
- Set_Then_Actions (N, Actlist);
- Analyze_And_Resolve (N, Standard_Boolean);
- Adjust_Result_Type (N, Typ);
- return;
+ if Is_Scalar_Type (Typ) then
+ Fexp := New_Occurrence_Of (Tnn, Loc);
+ else
+ Fexp :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Tnn, Loc));
end if;
- -- No actions present, check for cases of right argument True/False
-
- if Compile_Time_Known_Value (Right) then
-
- -- Change (Left and then True) to Left. Note that we know there are
- -- no actions associated with the True operand, since we just checked
- -- for this case above.
-
- if Expr_Value_E (Right) = Standard_True then
- Rewrite (N, Left);
-
- -- Change (Left and then False) to False, making sure to preserve any
- -- side effects associated with the Left operand.
-
- else pragma Assert (Expr_Value_E (Right) = Standard_False);
- Remove_Side_Effects (Left);
- Rewrite
- (N, New_Occurrence_Of (Standard_False, Loc));
- end if;
- end if;
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => Fexp,
+ Actions => Actions));
- Adjust_Result_Type (N, Typ);
- end Expand_N_And_Then;
+ Analyze_And_Resolve (N, Typ);
+ end Expand_N_Case_Expression;
-------------------------------------
-- Expand_N_Conditional_Expression --
-------------------------------------
- -- Expand into expression actions if then/else actions present
+ -- Deal with limited types and expression actions
procedure Expand_N_Conditional_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Thenx : constant Node_Id := Next (Cond);
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
- Cnn : Entity_Id;
- New_If : Node_Id;
+
+ Cnn : Entity_Id;
+ Decl : Node_Id;
+ New_If : Node_Id;
+ New_N : Node_Id;
+ P_Decl : Node_Id;
+ Expr : Node_Id;
+ Actions : List_Id;
begin
- -- If either then or else actions are present, then given:
+ -- 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.
+
+ -- 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
+ -- expression, and Sem_Elab circuitry removing it repeatedly.
+
+ if Compile_Time_Known_Value (Cond) then
+ if Is_True (Expr_Value (Cond)) then
+ Expr := Thenx;
+ Actions := Then_Actions (N);
+ else
+ Expr := Elsex;
+ Actions := Else_Actions (N);
+ end if;
+
+ Remove (Expr);
+
+ 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 not Use_Expression_With_Actions then
+ goto Skip_Optimization;
+ end if;
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => Relocate_Node (Expr),
+ Actions => Actions));
+ Analyze_And_Resolve (N, Typ);
+
+ else
+ Rewrite (N, Relocate_Node (Expr));
+ end if;
+
+ -- Note that the result is never static (legitimate cases of static
+ -- conditional expressions were folded in Sem_Eval).
+
+ Set_Is_Static_Expression (N, False);
+ return;
+ end if;
- -- if cond then then-expr else else-expr end
+ <<Skip_Optimization>>
- -- we insert the following sequence of actions (using Insert_Actions):
+ -- If the type is limited or unconstrained, we expand as follows to
+ -- avoid any possibility of improper copies.
- -- Cnn : typ;
+ -- Note: it may be possible to avoid this special processing if the
+ -- back end uses its own mechanisms for handling by-reference types ???
+
+ -- type Ptr is access all Typ;
+ -- Cnn : Ptr;
-- if cond then
-- <<then actions>>
- -- Cnn := then-expr;
+ -- Cnn := then-expr'Unrestricted_Access;
-- else
-- <<else actions>>
- -- Cnn := else-expr
+ -- Cnn := else-expr'Unrestricted_Access;
-- end if;
- -- and replace the conditional expression by a reference to Cnn
+ -- and replace the conditional expresion 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);
+
+ 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)));
+
+ Insert_Action (N, P_Decl);
- if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
- Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+ 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,
Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
- Expression => Relocate_Node (Thenx))),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unrestricted_Access,
+ Prefix => Relocate_Node (Thenx)))),
Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
- Expression => Relocate_Node (Elsex))));
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Unrestricted_Access,
+ Prefix => Relocate_Node (Elsex)))));
+
+ New_N :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Cnn, Loc));
+
+ -- For other types, we only need to expand if there are other actions
+ -- associated with either branch.
+
+ elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
+
+ -- We have two approaches to handling this. If we are allowed to use
+ -- N_Expression_With_Actions, then we can just wrap the actions into
+ -- the appropriate expression.
+
+ if Use_Expression_With_Actions then
+ if Present (Then_Actions (N)) then
+ Rewrite (Thenx,
+ Make_Expression_With_Actions (Sloc (Thenx),
+ Actions => Then_Actions (N),
+ Expression => Relocate_Node (Thenx)));
+ Set_Then_Actions (N, No_List);
+ Analyze_And_Resolve (Thenx, Typ);
+ end if;
- Set_Assignment_OK (Name (First (Then_Statements (New_If))));
- Set_Assignment_OK (Name (First (Else_Statements (New_If))));
+ if Present (Else_Actions (N)) then
+ Rewrite (Elsex,
+ Make_Expression_With_Actions (Sloc (Elsex),
+ Actions => Else_Actions (N),
+ Expression => Relocate_Node (Elsex)));
+ Set_Else_Actions (N, No_List);
+ Analyze_And_Resolve (Elsex, Typ);
+ end if;
- if Present (Then_Actions (N)) then
- Insert_List_Before
- (First (Then_Statements (New_If)), Then_Actions (N));
- end if;
+ return;
+
+ -- if we can't use N_Expression_With_Actions nodes, then we insert
+ -- the following sequence of actions (using Insert_Actions):
+
+ -- Cnn : typ;
+ -- if cond then
+ -- <<then actions>>
+ -- Cnn := then-expr;
+ -- else
+ -- <<else actions>>
+ -- Cnn := else-expr
+ -- end if;
+
+ -- and replace the conditional expression by a reference to Cnn
+
+ else
+ Cnn := Make_Temporary (Loc, 'C', N);
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
- if Present (Else_Actions (N)) then
- Insert_List_Before
- (First (Else_Statements (New_If)), Else_Actions (N));
+ 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;
- Rewrite (N, New_Occurrence_Of (Cnn, Loc));
+ -- If no actions then no expansion needed, gigi will handle it using
+ -- the same approach as a C conditional expression.
- Insert_Action (N,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cnn,
- Object_Definition => New_Occurrence_Of (Typ, Loc)));
+ else
+ return;
+ end if;
- Insert_Action (N, New_If);
- Analyze_And_Resolve (N, Typ);
+ -- 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;
-----------------------------------
Rop : constant Node_Id := Right_Opnd (N);
Static : constant Boolean := Is_OK_Static_Expression (N);
+ procedure Expand_Set_Membership;
+ -- For each disjunct we create a simple equality or membership test.
+ -- The whole membership is rewritten as a short-circuit disjunction.
+
+ ---------------------------
+ -- 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))
+ 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 proessing for Expand_N_In
+
+ 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, Rtyp);
Error_Msg_N ("?explicit membership test may be optimized away", N);
- Error_Msg_N ("\?use ''Valid attribute instead", N);
+ Error_Msg_N -- CODEFIX
+ ("\?use ''Valid attribute instead", N);
return;
end Substitute_Valid_Check;
-- Start of processing for Expand_N_In
begin
+ if Present (Alternatives (N)) then
+ Remove_Side_Effects (Lop);
+ Expand_Set_Membership;
+ 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.
+ -- test and give a warning. For floating point types however, this is a
+ -- standard way to check for finite numbers, and using 'Valid vould
+ -- typically be a pessimization.
if Is_Scalar_Type (Etype (Lop))
+ and then not Is_Floating_Point_Type (Etype (Lop))
and then Nkind (Rop) in N_Has_Entity
and then Etype (Lop) = Entity (Rop)
and then Comes_From_Source (N)
and then Comes_From_Source (N)
and then not In_Instance;
-- This must be true for any of the optimization warnings, we
- -- clearly want to give them only for source with the flag on.
- -- We also skip these warnings in an instance since it may be
- -- the case that different instantiations have different ranges.
+ -- clearly want to give them only for source with the flag on. We
+ -- also skip these warnings in an instance since it may be the
+ -- case that different instantiations have different ranges.
Warn2 : constant Boolean :=
Warn1
-- For the case where only one bound warning is elided, we also
-- insist on an explicit range and an integer type. The reason is
-- that the use of enumeration ranges including an end point is
- -- common, as is the use of a subtype name, one of whose bounds
- -- is the same as the type of the expression.
+ -- common, as is the use of a subtype name, one of whose bounds is
+ -- the same as the type of the expression.
begin
-- If test is explicit x'first .. x'last, replace by valid check
return;
end if;
- -- If we have an explicit range, do a bit of optimization based
- -- on range analysis (we may be able to kill one or both checks).
+ -- If we have an explicit range, do a bit of optimization based on
+ -- range analysis (we may be able to kill one or both checks).
Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
Error_Msg_N ("\?value is known to be out of range", N);
end if;
- Rewrite (N,
- New_Reference_To (Standard_False, Loc));
+ Rewrite (N, New_Reference_To (Standard_False, Loc));
Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static);
Error_Msg_N ("\?value is known to be in range", N);
end if;
- Rewrite (N,
- New_Reference_To (Standard_True, Loc));
+ Rewrite (N, New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
Set_Is_Static_Expression (N, Static);
else
declare
- Typ : Entity_Id := Etype (Rop);
- Is_Acc : constant Boolean := Is_Access_Type (Typ);
- Obj : Node_Id := Lop;
- Cond : Node_Id := Empty;
+ Typ : Entity_Id := Etype (Rop);
+ Is_Acc : constant Boolean := Is_Access_Type (Typ);
+ Cond : Node_Id := Empty;
+ New_N : Node_Id;
+ Obj : Node_Id := Lop;
+ SCIL_Node : Node_Id;
begin
Remove_Side_Effects (Obj);
-- are not explicitly represented in Java objects, so the
-- normal tagged membership expansion is not what we want).
- if VM_Target = No_VM then
- Rewrite (N, Tagged_Membership (N));
+ if Tagged_Type_Expansion then
+ Tagged_Membership (N, SCIL_Node, New_N);
+ Rewrite (N, New_N);
Analyze_And_Resolve (N, Rtyp);
+
+ -- Update decoration of relocated node referenced by the
+ -- SCIL node.
+
+ if Generate_SCIL and then Present (SCIL_Node) then
+ Set_SCIL_Node (N, SCIL_Node);
+ end if;
end if;
return;
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
- -- Prevent Gigi from generating incorrect code by rewriting
- -- the test as a standard False.
-
- Rewrite (N,
- New_Occurrence_Of (Standard_False, Loc));
+ -- Prevent Gigi from generating incorrect code by rewriting the
+ -- test as False.
+ Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
return;
end if;
end if;
if not Is_Constrained (Typ) then
- Rewrite (N,
- New_Reference_To (Standard_True, Loc));
+ Rewrite (N, New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
-- For the constrained array case, we have to check the subscripts
-- must match in any case).
elsif Is_Array_Type (Typ) then
-
Check_Subscripts : declare
- function Construct_Attribute_Reference
+ function Build_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat) return Node_Id;
- -- Build attribute reference E'Nam(Dim)
+ -- Build attribute reference E'Nam (Dim)
- -----------------------------------
- -- Construct_Attribute_Reference --
- -----------------------------------
+ -------------------------------
+ -- Build_Attribute_Reference --
+ -------------------------------
- function Construct_Attribute_Reference
+ function Build_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat) return Node_Id
begin
return
Make_Attribute_Reference (Loc,
- Prefix => E,
+ Prefix => E,
Attribute_Name => Nam,
- Expressions => New_List (
+ Expressions => New_List (
Make_Integer_Literal (Loc, Dim)));
- end Construct_Attribute_Reference;
+ end Build_Attribute_Reference;
-- Start of processing for Check_Subscripts
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
- Construct_Attribute_Reference
+ Build_Attribute_Reference
(Duplicate_Subexpr_No_Checks (Obj),
Name_First, J),
Right_Opnd =>
- Construct_Attribute_Reference
+ Build_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_First, J)));
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
- Construct_Attribute_Reference
+ Build_Attribute_Reference
(Duplicate_Subexpr_No_Checks (Obj),
Name_Last, J),
Right_Opnd =>
- Construct_Attribute_Reference
+ Build_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_Last, J)));
end loop;
end if;
-- If the prefix is an access type, then we unconditionally rewrite if
- -- as an explicit deference. This simplifies processing for several
+ -- as an explicit dereference. This simplifies processing for several
-- cases, including packed array cases and certain cases in which checks
-- must be generated. We used to try to do this only when it was
-- necessary, but it cleans up the code to do it all the time.
-- The second expression in a 'Read attribute reference
- -- The prefix of an address or size attribute reference
+ -- The prefix of an address or bit or size attribute reference
-- The following circuit detects these exceptions
elsif Nkind (Parnt) = N_Attribute_Reference
and then (Attribute_Name (Parnt) = Name_Address
or else
+ Attribute_Name (Parnt) = Name_Bit
+ or else
Attribute_Name (Parnt) = Name_Size)
and then Prefix (Parnt) = Child
then
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N))));
+ -- If this is a set membership, preserve list of alternatives
+
+ Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
+
-- We want this to appear as coming from source if original does (see
-- transformations in Expand_N_In).
-- Expand_N_Null --
-------------------
- -- The only replacement required is for the case of a null of type that is
- -- an access to protected subprogram. We represent such access values as a
- -- record, and so we must replace the occurrence of null by the equivalent
- -- record (with a null address and a null pointer in it), so that the
- -- backend creates the proper value.
+ -- The only replacement required is for the case of a null of a type that
+ -- is an access to protected subprogram, or a subtype thereof. We represent
+ -- such access values as a record, and so we must replace the occurrence of
+ -- null by the equivalent record (with a null address and a null pointer in
+ -- it), so that the backend creates the proper value.
procedure Expand_N_Null (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
+ Typ : constant Entity_Id := Base_Type (Etype (N));
Agg : Node_Id;
begin
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
- Adjust_Condition (Left_Opnd (N));
- Adjust_Condition (Right_Opnd (N));
- Set_Etype (N, Standard_Boolean);
- Adjust_Result_Type (N, Typ);
- end if;
- end Expand_N_Op_And;
+
+ -- 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;
+ end if;
+ end Expand_N_Op_And;
------------------------
-- Expand_N_Op_Concat --
Cnode := Left_Opnd (Cnode);
end loop;
- -- Now Opnd is the deepest Opnd, and its parents are the concatenation
- -- nodes above, so now we process bottom up, doing the operations. We
- -- gather a string that is as long as possible up to five operands
+ -- Now Cnode is the deepest concatenation, and its parents are the
+ -- concatenation nodes above, so now we process bottom up, doing the
+ -- operations. We gather a string that is as long as possible up to five
+ -- operands.
-- The outer loop runs more than once if more than one concatenation
-- type is involved.
and then Is_Power_Of_2_For_Shift (Ropnd)
-- We cannot do this transformation in configurable run time mode if we
- -- have 64-bit -- integers and long shifts are not available.
+ -- have 64-bit integers and long shifts are not available.
and then
(Esize (Ltyp) <= 32
-- En * En
else -- Expv = 4
- Temp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Temp := Make_Temporary (Loc, 'E', Base);
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
-- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
-- of the higher level node converts it into a shift.
+ -- Another case is 2 ** N in any other context. We simply convert
+ -- this to 1 * 2 ** N, and then the above transformation applies.
+
-- Note: this transformation is not applicable for a modular type with
-- a non-binary modulus in the multiplication case, since we get a wrong
-- result if the shift causes an overflow before the modular reduction.
and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
and then Is_Unsigned_Type (Exptyp)
and then not Ovflo
- and then Nkind (Parent (N)) in N_Binary_Op
then
- declare
- P : constant Node_Id := Parent (N);
- L : constant Node_Id := Left_Opnd (P);
- R : constant Node_Id := Right_Opnd (P);
+ -- First the multiply and divide cases
- begin
- if (Nkind (P) = N_Op_Multiply
- and then not Non_Binary_Modulus (Typ)
- and then
- ((Is_Integer_Type (Etype (L)) and then R = N)
- or else
- (Is_Integer_Type (Etype (R)) and then L = N))
- and then not Do_Overflow_Check (P))
-
- or else
- (Nkind (P) = N_Op_Divide
- and then Is_Integer_Type (Etype (L))
- and then Is_Unsigned_Type (Etype (L))
- and then R = N
- and then not Do_Overflow_Check (P))
- then
- Set_Is_Power_Of_2_For_Shift (N);
- return;
- end if;
- end;
+ if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
+ declare
+ P : constant Node_Id := Parent (N);
+ L : constant Node_Id := Left_Opnd (P);
+ R : constant Node_Id := Right_Opnd (P);
+
+ begin
+ if (Nkind (P) = N_Op_Multiply
+ and then not Non_Binary_Modulus (Typ)
+ and then
+ ((Is_Integer_Type (Etype (L)) and then R = N)
+ or else
+ (Is_Integer_Type (Etype (R)) and then L = N))
+ and then not Do_Overflow_Check (P))
+ or else
+ (Nkind (P) = N_Op_Divide
+ and then Is_Integer_Type (Etype (L))
+ and then Is_Unsigned_Type (Etype (L))
+ and then R = N
+ and then not Do_Overflow_Check (P))
+ then
+ Set_Is_Power_Of_2_For_Shift (N);
+ return;
+ end if;
+ end;
+
+ -- Now the other cases
+
+ elsif not Non_Binary_Modulus (Typ) then
+ Rewrite (N,
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Make_Integer_Literal (Loc, 1),
+ Right_Opnd => Relocate_Node (N)));
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
end if;
-- Fall through if exponentiation must be done using a runtime routine
begin
Binary_Op_Validity_Checks (N);
- Determine_Range (Right, ROK, Rlo, Rhi);
- Determine_Range (Left, LOK, Llo, Lhi);
+ Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
+ Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
-- Convert mod to rem if operands are known non-negative. We do this
-- since it is quite likely that this will improve the quality of code,
---------------------
-- If the argument is other than a Boolean array type, there is no special
- -- expansion required.
+ -- expansion required, except for VMS operations on signed integers.
-- For the packed case, we call the special routine in Exp_Pakd, except
-- that if the component size is greater than one, we use the standard
return;
end if;
+ -- For the VMS "not" on signed integer types, use conversion to and
+ -- from a predefined modular type.
+
+ if Is_VMS_Operator (Entity (N)) then
+ declare
+ Rtyp : Entity_Id;
+ Utyp : Entity_Id;
+
+ begin
+ -- If this is a derived type, retrieve original VMS type so that
+ -- the proper sized type is used for intermediate values.
+
+ if Is_Derived_Type (Typ) then
+ Rtyp := First_Subtype (Etype (Typ));
+ else
+ Rtyp := Typ;
+ end if;
+
+ -- The proper unsigned type must have a size compatible with the
+ -- operand, to prevent misalignment.
+
+ if RM_Size (Rtyp) <= 8 then
+ Utyp := RTE (RE_Unsigned_8);
+
+ elsif RM_Size (Rtyp) <= 16 then
+ Utyp := RTE (RE_Unsigned_16);
+
+ elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then
+ Utyp := RTE (RE_Unsigned_32);
+
+ else
+ Utyp := RTE (RE_Long_Long_Unsigned);
+ end if;
+
+ Rewrite (N,
+ Unchecked_Convert_To (Typ,
+ Make_Op_Not (Loc,
+ Unchecked_Convert_To (Utyp, Right_Opnd (N)))));
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end;
+ end if;
+
-- Only array types need any other processing
if not Is_Array_Type (Typ) then
begin
if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
- if N = Op1
- and then Nkind (Op2) = N_Op_Not
- then
- -- (not A) op (not B) can be reduced to a single call
+ -- (not A) op (not B) can be reduced to a single call
+
+ if N = Op1 and then Nkind (Op2) = N_Op_Not then
return;
- elsif N = Op2
- and then Nkind (Parent (N)) = N_Op_Xor
- then
- -- A xor (not B) can also be special-cased
+ elsif N = Op2 and then Nkind (Op1) = N_Op_Not then
+ return;
+
+ -- A xor (not B) can also be special-cased
+ elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
return;
end if;
end if;
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => J,
+ Defining_Identifier => J,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Chars (A)),
+ Prefix => Make_Identifier (Loc, Chars (A)),
Attribute_Name => Name_Range))),
Statements => New_List (
Name => B_J,
Expression => Make_Op_Not (Loc, A_J))));
- Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
+ Func_Name := Make_Temporary (Loc, 'N');
Set_Is_Inlined (Func_Name);
Insert_Action (N,
Statements => New_List (
Loop_Statement,
Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Identifier (Loc, Chars (B)))))));
+ Expression => Make_Identifier (Loc, Chars (B)))))));
Rewrite (N,
Make_Function_Call (Loc,
- Name => New_Reference_To (Func_Name, Loc),
+ Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => New_List (Opnd)));
Analyze_And_Resolve (N, Typ);
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
- Adjust_Condition (Left_Opnd (N));
- Adjust_Condition (Right_Opnd (N));
- Set_Etype (N, Standard_Boolean);
- Adjust_Result_Type (N, Typ);
+
+ -- 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;
end if;
end Expand_N_Op_Or;
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
- LLB : Uint;
- Llo : Uint;
- Lhi : Uint;
- LOK : Boolean;
- Rlo : Uint;
- Rhi : Uint;
- ROK : Boolean;
+ Lo : Uint;
+ Hi : Uint;
+ OK : Boolean;
- pragma Warnings (Off, Lhi);
+ Lneg : Boolean;
+ Rneg : Boolean;
+ -- Set if corresponding operand can be negative
+
+ pragma Unreferenced (Hi);
begin
Binary_Op_Validity_Checks (N);
-- the remainder is always 0, and we can just ignore the left operand
-- completely in this case.
- Determine_Range (Right, ROK, Rlo, Rhi);
- Determine_Range (Left, LOK, Llo, Lhi);
+ Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
+ Lneg := (not OK) or else Lo < 0;
- -- 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.
+ Determine_Range (Left, OK, Lo, Hi, Assume_Valid => True);
+ Rneg := (not OK) or else Lo < 0;
- LLB :=
- Expr_Value
- (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
+ -- We won't mess with trying to find out if the left operand can really
+ -- be the largest negative number (that's a pain in the case of private
+ -- types and this is really marginal). We will just assume that we need
+ -- the test if the left operand can be negative at all.
- -- Now perform the test, generating code only if needed
-
- if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
- and then
- ((not LOK) or else (Llo = LLB))
- then
+ if Lneg and Rneg then
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr (Right),
+ Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd =>
- Unchecked_Convert_To (Typ,
- Make_Integer_Literal (Loc, -1))),
+ Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
Unchecked_Convert_To (Typ,
Make_Integer_Literal (Loc, Uint_0)),
-- Arithmetic overflow checks for signed integer/fixed point types
if Is_Signed_Integer_Type (Typ)
- or else Is_Fixed_Point_Type (Typ)
+ or else
+ Is_Fixed_Point_Type (Typ)
then
Apply_Arithmetic_Overflow_Check (N);
- -- Vax floating-point types case
+ -- VAX floating-point types case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
-- Expand_N_Or_Else --
----------------------
- -- Expand into conditional expression if Actions present, and also
- -- deal with optimizing case of arguments being True or False.
-
- procedure Expand_N_Or_Else (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);
- Actlist : List_Id;
-
- begin
- -- Deal with non-standard booleans
-
- if Is_Boolean_Type (Typ) then
- Adjust_Condition (Left);
- Adjust_Condition (Right);
- Set_Etype (N, Standard_Boolean);
- end if;
-
- -- Check for cases where left argument is known to be True or False
-
- if Compile_Time_Known_Value (Left) then
-
- -- If left argument is False, change (False or else Right) to Right.
- -- Any actions associated with Right will be executed unconditionally
- -- and can thus be inserted into the tree unconditionally.
-
- if Expr_Value_E (Left) = Standard_False then
- if Present (Actions (N)) then
- Insert_Actions (N, Actions (N));
- end if;
-
- Rewrite (N, Right);
-
- -- If left argument is True, change (True and then Right) to True. In
- -- this case we can forget the actions associated with Right, since
- -- they will never be executed.
-
- else pragma Assert (Expr_Value_E (Left) = Standard_True);
- Kill_Dead_Code (Right);
- Kill_Dead_Code (Actions (N));
- Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
- end if;
-
- Adjust_Result_Type (N, Typ);
- return;
- end if;
-
- -- If Actions are present, we expand
-
- -- left or else right
-
- -- into
-
- -- if left then True else right end
-
- -- with the actions becoming the Else_Actions of the conditional
- -- expression. This conditional expression is then further expanded
- -- (and will eventually disappear)
-
- if Present (Actions (N)) then
- Actlist := Actions (N);
- Rewrite (N,
- Make_Conditional_Expression (Loc,
- Expressions => New_List (
- Left,
- New_Occurrence_Of (Standard_True, Loc),
- Right)));
-
- Set_Else_Actions (N, Actlist);
- Analyze_And_Resolve (N, Standard_Boolean);
- Adjust_Result_Type (N, Typ);
- return;
- end if;
-
- -- No actions present, check for cases of right argument True/False
-
- if Compile_Time_Known_Value (Right) then
-
- -- Change (Left or else False) to Left. Note that we know there are
- -- no actions associated with the True operand, since we just checked
- -- for this case above.
-
- if Expr_Value_E (Right) = Standard_False then
- Rewrite (N, Left);
-
- -- Change (Left or else True) to True, making sure to preserve any
- -- side effects associated with the Left operand.
-
- else pragma Assert (Expr_Value_E (Right) = Standard_True);
- Remove_Side_Effects (Left);
- Rewrite
- (N, New_Occurrence_Of (Standard_True, Loc));
- end if;
- end if;
-
- Adjust_Result_Type (N, Typ);
- end Expand_N_Or_Else;
+ procedure Expand_N_Or_Else (N : Node_Id)
+ renames Expand_Short_Circuit_Operator;
-----------------------------------
-- Expand_N_Qualified_Expression --
-- Apply possible constraint check
Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
+
+ if Do_Range_Check (Operand) then
+ Set_Do_Range_Check (Operand, False);
+ Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
+ end if;
end Expand_N_Qualified_Expression;
---------------------------------
Disc : Entity_Id;
New_N : Node_Id;
Dcon : Elmt_Id;
+ Dval : Node_Id;
function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
-- Gigi needs a temporary for prefixes that depend on a discriminant,
null;
-- Don't do this on the left hand of an assignment statement.
- -- Normally one would think that references like this would
- -- not occur, but they do in generated code, and mean that
- -- we really do want to assign the discriminant!
+ -- Normally one would think that references like this would not
+ -- occur, but they do in generated code, and mean that we really
+ -- do want to assign the discriminant!
elsif Nkind (Par) = N_Assignment_Statement
and then Name (Par) = N
null;
-- Don't do this optimization for the prefix of an attribute or
- -- the operand of an object renaming declaration since these are
+ -- the name of an object renaming declaration since these are
-- contexts where we do not want the value anyway.
elsif (Nkind (Par) = N_Attribute_Reference
Disc := First_Discriminant (Ptyp);
Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
+
Discr_Loop : while Present (Dcon) loop
+ Dval := Node (Dcon);
-- Check if this is the matching discriminant
-- constrained by an outer discriminant, which cannot
-- be optimized away.
- if
- Denotes_Discriminant
- (Node (Dcon), Check_Concurrent => True)
+ if Denotes_Discriminant
+ (Dval, Check_Concurrent => True)
+ then
+ exit Discr_Loop;
+
+ elsif Nkind (Original_Node (Dval)) = N_Selected_Component
+ and then
+ Denotes_Discriminant
+ (Selector_Name (Original_Node (Dval)), True)
+ then
+ exit Discr_Loop;
+
+ -- Do not retrieve value if constraint is not static. It
+ -- is generally not useful, and the constraint may be a
+ -- rewritten outer discriminant in which case it is in
+ -- fact incorrect.
+
+ elsif Is_Entity_Name (Dval)
+ and then Nkind (Parent (Entity (Dval)))
+ = N_Object_Declaration
+ and then Present (Expression (Parent (Entity (Dval))))
+ and then
+ not Is_Static_Expression
+ (Expression (Parent (Entity (Dval))))
then
exit Discr_Loop;
-- missing cases.
elsif Nkind (Parent (N)) = N_Case_Statement
- and then Etype (Node (Dcon)) /= Etype (Disc)
+ and then Etype (Dval) /= Etype (Disc)
then
Rewrite (N,
Make_Qualified_Expression (Loc,
Subtype_Mark =>
New_Occurrence_Of (Etype (Disc), Loc),
Expression =>
- New_Copy_Tree (Node (Dcon))));
+ New_Copy_Tree (Dval)));
Analyze_And_Resolve (N, Etype (Disc));
-- In case that comes out as a static expression,
-- yet, and this must be done now.
else
- Rewrite (N, New_Copy_Tree (Node (Dcon)));
+ Rewrite (N, New_Copy_Tree (Dval));
Analyze_And_Resolve (N);
Set_Is_Static_Expression (N, False);
return;
-- processing will still generate the appropriate copy in operation,
-- which will take care of the slice.
- procedure Make_Temporary;
+ procedure Make_Temporary_For_Slice;
-- Create a named variable for the value of the slice, in cases where
-- the back-end cannot handle it properly, e.g. when packed types or
-- unaligned slices are involved.
end loop;
end Is_Procedure_Actual;
- --------------------
- -- Make_Temporary --
- --------------------
+ ------------------------------
+ -- Make_Temporary_For_Slice --
+ ------------------------------
- procedure Make_Temporary is
+ procedure Make_Temporary_For_Slice is
Decl : Node_Id;
- Ent : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
+ Ent : constant Entity_Id := Make_Temporary (Loc, 'T', N);
+
begin
Decl :=
Make_Object_Declaration (Loc,
Rewrite (N, New_Occurrence_Of (Ent, Loc));
Analyze_And_Resolve (N, Typ);
- end Make_Temporary;
+ end Make_Temporary_For_Slice;
-- Start of processing for Expand_N_Slice
Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
end if;
- -- Range checks are potentially also needed for cases involving a slice
- -- indexed by a subtype indication, but Do_Range_Check can currently
- -- only be set for expressions ???
-
- if not Index_Checks_Suppressed (Ptp)
- and then (not Is_Entity_Name (Pfx)
- or else not Index_Checks_Suppressed (Entity (Pfx)))
- and then Nkind (Discrete_Range (N)) /= N_Subtype_Indication
-
- -- Do not enable range check to nodes associated with the frontend
- -- expansion of the dispatch table. We first check if Ada.Tags is
- -- already loaded to avoid the addition of an undesired dependence
- -- on such run-time unit.
-
- and then
- (VM_Target /= No_VM
- or else not
- (RTU_Loaded (Ada_Tags)
- and then Nkind (Prefix (N)) = N_Selected_Component
- and then Present (Entity (Selector_Name (Prefix (N))))
- and then Entity (Selector_Name (Prefix (N))) =
- RTE_Record_Component (RE_Prims_Ptr)))
- then
- Enable_Range_Check (Discrete_Range (N));
- end if;
-
-- The remaining case to be handled is packed slices. We can leave
-- packed slices as they are in the following situations:
if Nkind (Parent (N)) = N_Function_Call
and then Is_Possibly_Unaligned_Slice (N)
then
- Make_Temporary;
+ Make_Temporary_For_Slice;
end if;
elsif Nkind (Parent (N)) = N_Assignment_Statement
return;
else
- Make_Temporary;
+ Make_Temporary_For_Slice;
end if;
end Expand_N_Slice;
-- assignment to temporary. If there is no change of representation,
-- then the conversion node is unchanged.
+ procedure Raise_Accessibility_Error;
+ -- Called when we know that an accessibility check will fail. Rewrites
+ -- node N to an appropriate raise statement and outputs warning msgs.
+ -- The Etype of the raise node is set to Target_Type.
+
procedure Real_Range_Check;
-- Handles generation of range check for real target value
Constraints => Cons));
end if;
- Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
+ Temp := Make_Temporary (Loc, 'C');
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
end if;
end Handle_Changed_Representation;
+ -------------------------------
+ -- Raise_Accessibility_Error --
+ -------------------------------
+
+ procedure Raise_Accessibility_Error is
+ begin
+ Rewrite (N,
+ Make_Raise_Program_Error (Sloc (N),
+ Reason => PE_Accessibility_Check_Failed));
+ Set_Etype (N, Target_Type);
+
+ Error_Msg_N ("?accessibility check failure", N);
+ Error_Msg_NE
+ ("\?& will be raised at run time", N, Standard_Program_Error);
+ end Raise_Accessibility_Error;
+
----------------------
-- Real_Range_Check --
----------------------
-- Otherwise rewrite the conversion as described above
Conv := Relocate_Node (N);
- Rewrite
- (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
+ Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
Set_Etype (Conv, Btyp);
-- Enable overflow except for case of integer to float conversions,
Enable_Overflow_Check (Conv);
end if;
- Tnn :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ Tnn := Make_Temporary (Loc, 'T', Conv);
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Object_Definition => New_Occurrence_Of (Btyp, Loc),
- Expression => Conv),
+ Constant_Present => True,
+ Expression => Conv),
Make_Raise_Constraint_Error (Loc,
Condition =>
begin
-- Nothing at all to do if conversion is to the identical type so remove
- -- the conversion completely, it is useless.
+ -- the conversion completely, it is useless, except that it may carry
+ -- an Assignment_OK attribute, which must be propagated to the operand.
if Operand_Type = Target_Type then
+ if Assignment_OK (N) then
+ Set_Assignment_OK (Operand);
+ end if;
+
Rewrite (N, Relocate_Node (Operand));
return;
end if;
-- Here if we may need to expand conversion
+ -- If the operand of the type conversion is an arithmetic operation on
+ -- signed integers, and the based type of the signed integer type in
+ -- question is smaller than Standard.Integer, we promote both of the
+ -- operands to type Integer.
+
+ -- For example, if we have
+
+ -- target-type (opnd1 + opnd2)
+
+ -- and opnd1 and opnd2 are of type short integer, then we rewrite
+ -- this as:
+
+ -- target-type (integer(opnd1) + integer(opnd2))
+
+ -- We do this because we are always allowed to compute in a larger type
+ -- if we do the right thing with the result, and in this case we are
+ -- going to do a conversion which will do an appropriate check to make
+ -- sure that things are in range of the target type in any case. This
+ -- avoids some unnecessary intermediate overflows.
+
+ -- We might consider a similar transformation in the case where the
+ -- target is a real type or a 64-bit integer type, and the operand
+ -- is an arithmetic operation using a 32-bit integer type. However,
+ -- we do not bother with this case, because it could cause significant
+ -- ineffiencies on 32-bit machines. On a 64-bit machine it would be
+ -- much cheaper, but we don't want different behavior on 32-bit and
+ -- 64-bit machines. Note that the exclusion of the 64-bit case also
+ -- handles the configurable run-time cases where 64-bit arithmetic
+ -- may simply be unavailable.
+
+ -- Note: this circuit is partially redundant with respect to the circuit
+ -- in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
+ -- the processing here. Also we still need the Checks circuit, since we
+ -- have to be sure not to generate junk overflow checks in the first
+ -- place, since it would be trick to remove them here!
+
+ if Integer_Promotion_Possible (N) then
+
+ -- All conditions met, go ahead with transformation
+
+ declare
+ Opnd : Node_Id;
+ L, R : Node_Id;
+
+ begin
+ R :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
+ Expression => Relocate_Node (Right_Opnd (Operand)));
+
+ Opnd := New_Op_Node (Nkind (Operand), Loc);
+ Set_Right_Opnd (Opnd, R);
+
+ if Nkind (Operand) in N_Binary_Op then
+ L :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
+ Expression => Relocate_Node (Left_Opnd (Operand)));
+
+ Set_Left_Opnd (Opnd, L);
+ end if;
+
+ Rewrite (N,
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
+ Expression => Opnd));
+
+ Analyze_And_Resolve (N, Target_Type);
+ return;
+ end;
+ end if;
+
-- Do validity check if validity checking operands
if Validity_Checks_On
and then Type_Access_Level (Operand_Type) >
Type_Access_Level (Target_Type)
then
- Rewrite (N,
- Make_Raise_Program_Error (Sloc (N),
- Reason => PE_Accessibility_Check_Failed));
- Set_Etype (N, Target_Type);
+ Raise_Accessibility_Error;
-- When the operand is a selected access discriminant the check needs
-- to be made against the level of the object denoted by the prefix
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
then
- Rewrite (N,
- Make_Raise_Program_Error (Sloc (N),
- Reason => PE_Accessibility_Check_Failed));
- Set_Etype (N, Target_Type);
+ Raise_Accessibility_Error;
+ return;
end if;
end if;
-- renaming, since this is an error situation which will be caught by
-- Sem_Ch8, and the expansion can interfere with this error check.
- if Is_Access_Type (Target_Type)
- and then Is_Renamed_Object (N)
- then
+ if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
return;
end if;
-- Otherwise, proceed with processing tagged conversion
- declare
+ Tagged_Conversion : declare
Actual_Op_Typ : Entity_Id;
Actual_Targ_Typ : Entity_Id;
Make_Conversion : Boolean := False;
Reason => CE_Tag_Check_Failed));
end Make_Tag_Check;
- -- Start of processing
+ -- Start of processing for Tagged_Conversion
begin
if Is_Access_Type (Target_Type) then
- Actual_Op_Typ := Designated_Type (Operand_Type);
- Actual_Targ_Typ := Designated_Type (Target_Type);
+ -- Handle entities from the limited view
+
+ Actual_Op_Typ :=
+ Available_View (Designated_Type (Operand_Type));
+ Actual_Targ_Typ :=
+ Available_View (Designated_Type (Target_Type));
else
Actual_Op_Typ := Operand_Type;
Actual_Targ_Typ := Target_Type;
-- conversion.
if Is_Class_Wide_Type (Actual_Op_Typ)
+ and then Actual_Op_Typ /= Actual_Targ_Typ
and then Root_Op_Typ /= Actual_Targ_Typ
and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ)
then
end;
end if;
end if;
- end;
+ end Tagged_Conversion;
-- Case of other access type conversions
end if;
-- Otherwise do correct fixed-conversion, but skip these if the
- -- Conversion_OK flag is set, because from a semantic point of
- -- view these are simple integer conversions needing no further
- -- processing (the backend will simply treat them as integers)
+ -- Conversion_OK flag is set, because from a semantic point of view
+ -- these are simple integer conversions needing no further processing
+ -- (the backend will simply treat them as integers).
if not Conversion_OK (N) then
if Is_Fixed_Point_Type (Etype (N)) then
-- with the end-point. But that can lose precision in some cases, and
-- give a wrong result. Converting the operand to Universal_Real is
-- helpful, but still does not catch all cases with 64-bit integers
- -- on targets with only 64-bit floats
+ -- on targets with only 64-bit floats.
-- The above comment seems obsoleted by Apply_Float_Conversion_Check
-- Can this code be removed ???
elsif Is_Enumeration_Type (Target_Type) then
-- Special processing is required if there is a change of
- -- representation (from enumeration representation clauses)
+ -- representation (from enumeration representation clauses).
if not Same_Representation (Target_Type, Operand_Type) then
end if;
-- At this stage, either the conversion node has been transformed into
- -- some other equivalent expression, or left as a conversion that can
- -- be handled by Gigi. The conversions that Gigi can handle are the
- -- following:
+ -- some other equivalent expression, or left as a conversion that can be
+ -- handled by Gigi, in the following cases:
-- Conversions with no change of representation or type
end if;
-- Reset overflow flag, since the range check will include
- -- dealing with possible overflow, and generate the check If
+ -- dealing with possible overflow, and generate the check. If
-- Address is either a source type or target type, suppress
-- range check to avoid typing anomalies when it is a visible
-- integer type.
-- Expand_N_Unchecked_Expression --
-----------------------------------
- -- Remove the unchecked expression node from the tree. It's job was simply
+ -- Remove the unchecked expression node from the tree. Its job was simply
-- to make sure that its constituent expression was handled with checks
-- off, and now that that is done, we can remove it from the tree, and
- -- indeed must, since gigi does not expect to see these nodes.
+ -- indeed must, since Gigi does not expect to see these nodes.
procedure Expand_N_Unchecked_Expression (N : Node_Id) is
Exp : constant Node_Id := Expression (N);
-
begin
- Set_Assignment_OK (Exp, Assignment_OK (N) or Assignment_OK (Exp));
+ Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
Rewrite (N, Exp);
end Expand_N_Unchecked_Expression;
Operand_Type : constant Entity_Id := Etype (Operand);
begin
+ -- Nothing at all to do if conversion is to the identical type so remove
+ -- the conversion completely, it is useless, except that it may carry
+ -- an Assignment_OK indication which must be propagated to the operand.
+
+ if Operand_Type = Target_Type then
+
+ -- Code duplicates Expand_N_Unchecked_Expression above, factor???
+
+ if Assignment_OK (N) then
+ Set_Assignment_OK (Operand);
+ end if;
+
+ Rewrite (N, Relocate_Node (Operand));
+ return;
+ end if;
+
-- If we have a conversion of a compile time known value to a target
-- type and the value is in range of the target type, then we can simply
-- replace the construct by an integer literal of the correct type. We
Result := New_Reference_To (Standard_True, Loc);
C := Suitable_Element (First_Entity (Typ));
-
while Present (C) loop
declare
New_Lhs : Node_Id;
return Result;
end Expand_Record_Equality;
+ -----------------------------------
+ -- Expand_Short_Circuit_Operator --
+ -----------------------------------
+
+ -- Deal with special expansion if actions are present for the right operand
+ -- and deal with optimizing case of arguments being True or False. We also
+ -- deal with the special case of non-standard boolean values.
+
+ procedure Expand_Short_Circuit_Operator (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);
+ LocR : constant Source_Ptr := Sloc (Right);
+ Actlist : List_Id;
+
+ Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
+ Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
+ -- If Left = Shortcut_Value then Right need not be evaluated
+
+ function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
+ -- For Opnd a boolean expression, return a Boolean expression equivalent
+ -- to Opnd /= Shortcut_Value.
+
+ --------------------
+ -- Make_Test_Expr --
+ --------------------
+
+ function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
+ begin
+ if Shortcut_Value then
+ return Make_Op_Not (Sloc (Opnd), Opnd);
+ else
+ return Opnd;
+ end if;
+ end Make_Test_Expr;
+
+ Op_Var : Entity_Id;
+ -- Entity for a temporary variable holding the value of the operator,
+ -- used for expansion in the case where actions are present.
+
+ -- Start of processing for Expand_Short_Circuit_Operator
+
+ begin
+ -- Deal with non-standard booleans
+
+ if Is_Boolean_Type (Typ) then
+ Adjust_Condition (Left);
+ Adjust_Condition (Right);
+ Set_Etype (N, Standard_Boolean);
+ end if;
+
+ -- Check for cases where left argument is known to be True or False
+
+ if Compile_Time_Known_Value (Left) then
+
+ -- Mark SCO for left condition as compile time known
+
+ if Generate_SCO and then Comes_From_Source (Left) then
+ Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
+ end if;
+
+ -- Rewrite True AND THEN Right / False OR ELSE Right to Right.
+ -- Any actions associated with Right will be executed unconditionally
+ -- and can thus be inserted into the tree unconditionally.
+
+ if Expr_Value_E (Left) /= Shortcut_Ent then
+ if Present (Actions (N)) then
+ Insert_Actions (N, Actions (N));
+ end if;
+
+ Rewrite (N, Right);
+
+ -- Rewrite False AND THEN Right / True OR ELSE Right to Left.
+ -- In this case we can forget the actions associated with Right,
+ -- since they will never be executed.
+
+ else
+ Kill_Dead_Code (Right);
+ Kill_Dead_Code (Actions (N));
+ Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
+ end if;
+
+ Adjust_Result_Type (N, Typ);
+ return;
+ end if;
+
+ -- If Actions are present for the right operand, we have to do some
+ -- special processing. We can't just let these actions filter back into
+ -- code preceding the short circuit (which is what would have happened
+ -- if we had not trapped them in the short-circuit form), since they
+ -- must only be executed if the right operand of the short circuit is
+ -- executed and not otherwise.
+
+ -- the temporary variable C.
+
+ if Present (Actions (N)) then
+ Actlist := Actions (N);
+
+ -- The old approach is to expand:
+
+ -- left AND THEN right
+
+ -- into
+
+ -- C : Boolean := False;
+ -- IF left THEN
+ -- Actions;
+ -- IF right THEN
+ -- C := True;
+ -- END IF;
+ -- END IF;
+
+ -- and finally rewrite the operator into a reference to C. Similarly
+ -- for left OR ELSE right, with negated values. Note that this
+ -- rewrite causes some difficulties for coverage analysis because
+ -- of the introduction of the new variable C, which obscures the
+ -- structure of the test.
+
+ -- We use this "old approach" if use of N_Expression_With_Actions
+ -- is False (see description in Opt of when this is or is not set).
+
+ if not Use_Expression_With_Actions then
+ Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Op_Var,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression =>
+ New_Occurrence_Of (Shortcut_Ent, Loc)));
+
+ Append_To (Actlist,
+ Make_Implicit_If_Statement (Right,
+ Condition => Make_Test_Expr (Right),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (LocR,
+ Name => New_Occurrence_Of (Op_Var, LocR),
+ Expression =>
+ New_Occurrence_Of
+ (Boolean_Literals (not Shortcut_Value), LocR)))));
+
+ Insert_Action (N,
+ Make_Implicit_If_Statement (Left,
+ Condition => Make_Test_Expr (Left),
+ Then_Statements => Actlist));
+
+ Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ -- The new approach, activated for now by the use of debug flag
+ -- -gnatd.X is to use the new Expression_With_Actions node for the
+ -- right operand of the short-circuit form. This should solve the
+ -- traceability problems for coverage analysis.
+
+ else
+ Rewrite (Right,
+ Make_Expression_With_Actions (LocR,
+ Expression => Relocate_Node (Right),
+ Actions => Actlist));
+ Set_Actions (N, No_List);
+ Analyze_And_Resolve (Right, Standard_Boolean);
+ end if;
+
+ Adjust_Result_Type (N, Typ);
+ return;
+ end if;
+
+ -- No actions present, check for cases of right argument True/False
+
+ if Compile_Time_Known_Value (Right) then
+
+ -- Mark SCO for left condition as compile time known
+
+ if Generate_SCO and then Comes_From_Source (Right) then
+ Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
+ end if;
+
+ -- Change (Left and then True), (Left or else False) to Left.
+ -- Note that we know there are no actions associated with the right
+ -- operand, since we just checked for this case above.
+
+ if Expr_Value_E (Right) /= Shortcut_Ent then
+ Rewrite (N, Left);
+
+ -- Change (Left and then False), (Left or else True) to Right,
+ -- making sure to preserve any side effects associated with the Left
+ -- operand.
+
+ else
+ Remove_Side_Effects (Left);
+ Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
+ end if;
+ end if;
+
+ Adjust_Result_Type (N, Typ);
+ end Expand_Short_Circuit_Operator;
+
-------------------------------------
-- Fixup_Universal_Fixed_Operation --
-------------------------------------
PtrT /=
Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT)))
then
- Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J'));
+ Owner := Make_Temporary (Loc, 'J');
Insert_Action (N,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Owner,
then
Owner := Scope (Return_Applies_To (Scope (PtrT)));
- -- Case of an access discriminant, or (Ada 2005), of an anonymous
+ -- Case of an access discriminant, or (Ada 2005) of an anonymous
-- access component or anonymous access function result: find the
-- final list associated with the scope of the type. (In the
-- anonymous access component kind, a list controller will have
return;
end Insert_Dereference_Action;
+ --------------------------------
+ -- Integer_Promotion_Possible --
+ --------------------------------
+
+ function Integer_Promotion_Possible (N : Node_Id) return Boolean is
+ Operand : constant Node_Id := Expression (N);
+ Operand_Type : constant Entity_Id := Etype (Operand);
+ Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
+
+ begin
+ pragma Assert (Nkind (N) = N_Type_Conversion);
+
+ return
+
+ -- We only do the transformation for source constructs. We assume
+ -- that the expander knows what it is doing when it generates code.
+
+ Comes_From_Source (N)
+
+ -- If the operand type is Short_Integer or Short_Short_Integer,
+ -- then we will promote to Integer, which is available on all
+ -- targets, and is sufficient to ensure no intermediate overflow.
+ -- Furthermore it is likely to be as efficient or more efficient
+ -- than using the smaller type for the computation so we do this
+ -- unconditionally.
+
+ and then
+ (Root_Operand_Type = Base_Type (Standard_Short_Integer)
+ or else
+ Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
+
+ -- Test for interesting operation, which includes addition,
+ -- division, exponentiation, multiplication, subtraction, absolute
+ -- value and unary negation. Unary "+" is omitted since it is a
+ -- no-op and thus can't overflow.
+
+ and then Nkind_In (Operand, N_Op_Abs,
+ N_Op_Add,
+ N_Op_Divide,
+ N_Op_Expon,
+ N_Op_Minus,
+ N_Op_Multiply,
+ N_Op_Subtract);
+ end Integer_Promotion_Possible;
+
------------------------------
-- Make_Array_Comparison_Op --
------------------------------
-- if ... end if;
-- end Gnnn;
- Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
+ Func_Name := Make_Temporary (Loc, 'G');
Func_Body :=
Make_Subprogram_Body (Loc,
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Typ, Loc)));
- Func_Name :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
+ Func_Name := Make_Temporary (Loc, 'A');
Set_Is_Inlined (Func_Name);
Func_Body :=
-- in the call to Compile_Time_Compare. If this call results in a
-- clear result of always True or Always False, that's decisive and
-- we are done. Otherwise we repeat the processing with Assume_Valid
- -- set to True to generate additional warnings. We can stil that step
+ -- set to True to generate additional warnings. We can skip that step
-- if Constant_Condition_Warnings is False.
for AV in False .. True loop
end if;
-- If this is the second iteration (AV = True), and the original
- -- node comes from source and we are not in an instance, then
- -- give a warning if we know result would be True or False. Note
- -- we know Constant_Condition_Warnings is set if we get here.
+ -- node comes from source and we are not in an instance, then give
+ -- a warning if we know result would be True or False. Note: we
+ -- know Constant_Condition_Warnings is set if we get here.
elsif Comes_From_Source (Original_Node (N))
and then not In_Instance
end;
-- Skip second iteration if not warning on constant conditions or
- -- if the first iteration already generated a warning of some kind
- -- or if we are in any case assuming all values are valid (so that
- -- the first iteration took care of the valid case).
+ -- if the first iteration already generated a warning of some kind or
+ -- if we are in any case assuming all values are valid (so that the
+ -- first iteration took care of the valid case).
exit when not Constant_Condition_Warnings;
exit when Warning_Generated;
end if;
end Is_Safe_Operand;
- -- Start of processing for Is_Safe_In_Place_Array_Op
+ -- Start of processing for Is_Safe_In_Place_Array_Op
begin
-- Skip this processing if the component size is different from system
elsif not Is_Unaliased (Lhs) then
return False;
+
else
Target := Entity (Lhs);
-
- return
- Is_Safe_Operand (Op1)
- and then Is_Safe_Operand (Op2);
+ return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
end if;
end Safe_In_Place_Array_Op;
-- table of abstract interface types plus the ancestor table contained in
-- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
- function Tagged_Membership (N : Node_Id) return Node_Id is
+ procedure Tagged_Membership
+ (N : Node_Id;
+ SCIL_Node : out Node_Id;
+ Result : out Node_Id)
+ is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Loc : constant Source_Ptr := Sloc (N);
Left_Type : Entity_Id;
+ New_Node : Node_Id;
Right_Type : Entity_Id;
Obj_Tag : Node_Id;
begin
- Left_Type := Etype (Left);
- Right_Type := Etype (Right);
+ SCIL_Node := Empty;
+
+ -- Handle entities from the limited view
+
+ Left_Type := Available_View (Etype (Left));
+ Right_Type := Available_View (Etype (Right));
if Is_Class_Wide_Type (Left_Type) then
Left_Type := Root_Type (Left_Type);
(Typ => Left_Type,
Iface => Etype (Right_Type))))
then
- return New_Reference_To (Standard_True, Loc);
+ Result := New_Reference_To (Standard_True, Loc);
+ return;
end if;
-- Ada 2005 (AI-251): Class-wide applied to interfaces
if not RTE_Available (RE_IW_Membership) then
Error_Msg_CRT
("dynamic membership test on interface types", N);
- return Empty;
+ Result := Empty;
+ return;
end if;
- return
+ Result :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
Parameter_Associations => New_List (
-- Ada 95: Normal case
else
- return
- Build_CW_Membership (Loc,
- Obj_Tag_Node => Obj_Tag,
- Typ_Tag_Node =>
- New_Reference_To (
- Node (First_Elmt
- (Access_Disp_Table (Root_Type (Right_Type)))),
- Loc));
+ Build_CW_Membership (Loc,
+ Obj_Tag_Node => Obj_Tag,
+ Typ_Tag_Node =>
+ New_Reference_To (
+ Node (First_Elmt
+ (Access_Disp_Table (Root_Type (Right_Type)))),
+ Loc),
+ Related_Nod => N,
+ New_Node => New_Node);
+
+ -- Generate the SCIL node for this class-wide membership test.
+ -- Done here because the previous call to Build_CW_Membership
+ -- relocates Obj_Tag.
+
+ if Generate_SCIL then
+ SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
+ Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
+ Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
+ end if;
+
+ Result := New_Node;
end if;
-- Right_Type is not a class-wide type
-- No need to check the tag of the object if Right_Typ is abstract
if Is_Abstract_Type (Right_Type) then
- return New_Reference_To (Standard_False, Loc);
+ Result := New_Reference_To (Standard_False, Loc);
else
- return
+ Result :=
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>
projects / thirdparty / gcc.git / blobdiff