-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Atree; use Atree;
with Checks; use Checks;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
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 Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
+with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
-- 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.
if Nkind (Op1) = N_Op_Not then
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 => Op1,
+ 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', Node);
+
+ 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');
-- 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;
end if;
elsif Aggr_In_Place then
- Temp :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Temp := Make_Temporary (Loc, 'P');
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
else
- -- First check against the type of the qualified expression
- --
- -- NOTE: The commented call should be correct, but for some reason
- -- causes the compiler to bomb (sigsegv) on ACVC test c34007g, so for
- -- now we just perform the old (incorrect) test against the
- -- designated subtype with no sliding in the else part of the if
- -- statement below. ???
- --
- -- Apply_Constraint_Check (Exp, T, No_Sliding => True);
+ -- If we have:
+ -- type A is access T1;
+ -- X : A := new T2'(...);
+ -- T1 and T2 can be different subtypes, and we might need to check
+ -- both constraints. First check against the type of the qualified
+ -- expression.
+
+ 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
Apply_Constraint_Check
(Exp, DesigT, No_Sliding => False);
- -- The nonsliding check should really be performed (unconditionally)
- -- against the subtype of the qualified expression, but that causes a
- -- problem with c34007g (see above), so for now we retain this.
-
- else
- Apply_Constraint_Check
- (Exp, DesigT, 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;
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
Result : Node_Id;
-- 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.
+
Known_Non_Null_Operand_Seen : Boolean;
-- Set True during generation of the assignements of operands into
-- result once an operand known to be non-null has been seen.
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');
- Insert_Action (Cnode,
+ Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Var_Length (NN),
Constant_Present => True,
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr (Opnd, Name_Req => True),
- Attribute_Name => Name_Length)),
-
- Suppress => All_Checks);
+ Attribute_Name => Name_Length)));
end if;
end if;
Make_Integer_Literal (Loc,
Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
- -- All other cases, construct an addition node for the length and
- -- create an entity initialized to this length.
+ -- All other cases, construct an addition node for the length and
+ -- 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));
Clen := New_Reference_To (Var_Length (NN), Loc);
end if;
- Insert_Action (Cnode,
+ Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Constant_Present => True,
Expression =>
Make_Op_Add (Loc,
Left_Opnd => New_Copy (Aggr_Length (NN - 1)),
- Right_Opnd => Clen)),
-
- Suppress => All_Checks);
+ Right_Opnd => Clen)));
Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
end if;
end Get_Known_Bound;
begin
- Ent :=
- Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('L'));
+ Ent := Make_Temporary (Loc, 'L');
- Insert_Action (Cnode,
+ Append_To (Actions,
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Ityp, Loc),
- Expression => Get_Known_Bound (1)),
- Suppress => All_Checks);
+ Expression => Get_Known_Bound (1)));
Low_Bound := New_Reference_To (Ent, Loc);
end;
Right_Opnd => Make_Artyp_Literal (1))));
-- Note that calculation of the high bound may cause overflow in some
- -- very weird cases, so in the general case we need an overflow check
- -- on the high bound. We can avoid this for the common case of string
- -- types since we chose a wider range for the arithmetic type.
+ -- very weird cases, so in the general case we need an overflow check on
+ -- the high bound. We can avoid this for the common case of string types
+ -- and other types whose index is Positive, since we chose a wider range
+ -- for the arithmetic type.
if Istyp /= Standard_Positive then
Activate_Overflow_Check (High_Bound);
High_Bound));
end if;
+ -- Here is where we insert the saved up actions
+
+ Insert_Actions (Cnode, Actions, Suppress => All_Checks);
+
-- Now we construct an array object with appropriate bounds
- Ent :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ Ent := Make_Temporary (Loc, 'S');
-- 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
High_Bound => High_Bound))))),
Suppress => All_Checks);
+ -- If the result of the concatenation appears as the initializing
+ -- expression of an object declaration, we can just rename the
+ -- result, rather than copying it.
+
+ Set_OK_To_Rename (Ent);
+
-- Catch the static out of range case now
if Raises_Constraint_Error (High_Bound) then
-- Now we will generate the assignments to do the actual concatenation
+ -- There is one case in which we will not do this, namely when all the
+ -- following conditions are met:
+
+ -- The result type is Standard.String
+
+ -- There are nine or fewer retained (non-null) operands
+
+ -- The optimization level is -O0
+
+ -- The corresponding System.Concat_n.Str_Concat_n routine is
+ -- available in the run time.
+
+ -- The debug flag gnatd.c is not set
+
+ -- If all these conditions are met then we generate a call to the
+ -- relevant concatenation routine. The purpose of this is to avoid
+ -- undesirable code bloat at -O0.
+
+ if Atyp = Standard_String
+ and then NN in 2 .. 9
+ and then (Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC)
+ and then not Debug_Flag_Dot_C
+ then
+ declare
+ RR : constant array (Nat range 2 .. 9) of RE_Id :=
+ (RE_Str_Concat_2,
+ RE_Str_Concat_3,
+ RE_Str_Concat_4,
+ RE_Str_Concat_5,
+ RE_Str_Concat_6,
+ RE_Str_Concat_7,
+ RE_Str_Concat_8,
+ RE_Str_Concat_9);
+
+ begin
+ if RTE_Available (RR (NN)) then
+ declare
+ Opnds : constant List_Id :=
+ New_List (New_Occurrence_Of (Ent, Loc));
+
+ begin
+ for J in 1 .. NN loop
+ if Is_List_Member (Operands (J)) then
+ Remove (Operands (J));
+ end if;
+
+ if Base_Type (Etype (Operands (J))) = Ctyp then
+ Append_To (Opnds,
+ Make_Aggregate (Loc,
+ Component_Associations => New_List (
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, 1)),
+ Expression => Operands (J)))));
+
+ else
+ Append_To (Opnds, Operands (J));
+ end if;
+ end loop;
+
+ Insert_Action (Cnode,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Reference_To (RTE (RR (NN)), Loc),
+ Parameter_Associations => Opnds));
+
+ Result := New_Reference_To (Ent, Loc);
+ goto Done;
+ end;
+ end if;
+ end;
+ end if;
+
+ -- Not special case so generate the assignments
+
Known_Non_Null_Operand_Seen := False;
for J in 1 .. NN loop
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;
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 malfunctins for
+ -- This is done without using the attribute (which malfunctions for
-- large sizes ???)
---------------------------------------
-------------------------
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,
-- least at the moment we don't compute this attribute right, and
-- can silently give wrong results when the result gets large. Since
-- this is all about large results, that's bad, so instead we only
- -- applly the check for constrained arrays, and manually compute the
+ -- apply the check for constrained arrays, and manually compute the
-- value of the attribute ???
if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
end if;
-- Handle case of qualified expression (other than optimization above)
+ -- First apply constraint checks, because the bounds or discriminants
+ -- in the aggregate might not match the subtype mark in the allocator.
if Nkind (Expression (N)) = N_Qualified_Expression then
+ Apply_Constraint_Check
+ (Expression (Expression (N)), Etype (Expression (N)));
+
Expand_Allocator_Expression (N);
return;
end if;
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
-- 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) 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 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.
-
- if Expr_Value_E (Left) = Standard_True then
- if Present (Actions (N)) then
- Insert_Actions (N, Actions (N));
- 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
-
- -- if left then right else false end
-
- -- with the actions becoming the Then_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,
- Right,
- New_Occurrence_Of (Standard_False, Loc))));
-
- Set_Then_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 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;
-
- Adjust_Result_Type (N, Typ);
- end Expand_N_And_Then;
+ procedure Expand_N_And_Then (N : Node_Id)
+ renames Expand_Short_Circuit_Operator;
-------------------------------------
-- 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;
+ Decl : Node_Id;
New_If : Node_Id;
+ New_N : Node_Id;
+ P_Decl : Node_Id;
begin
- -- If either then or else actions are present, then given:
+ -- If the type is limited or unconstrained, we expand as follows to
+ -- avoid any possibility of improper copies.
- -- if cond then then-expr else else-expr end
+ -- Note: it may be possible to avoid this special processing if the
+ -- back end uses its own mechanisms for handling by-reference types ???
- -- we insert the following sequence of actions (using Insert_Actions):
-
- -- Cnn : typ;
+ -- 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)))));
- Set_Assignment_OK (Name (First (Then_Statements (New_If))));
- Set_Assignment_OK (Name (First (Else_Statements (New_If))));
+ New_N :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Cnn, Loc));
- if Present (Then_Actions (N)) then
- Insert_List_Before
- (First (Then_Statements (New_If)), Then_Actions (N));
- end if;
+ -- 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)));
+ Analyze_And_Resolve (Thenx, Typ);
+ end if;
+
+ if Present (Else_Actions (N)) then
+ Rewrite (Elsex,
+ Make_Expression_With_Actions (Sloc (Elsex),
+ Actions => Else_Actions (N),
+ Expression => Relocate_Node (Elsex)));
+ Analyze_And_Resolve (Elsex, Typ);
+ 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));
+
+ 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))));
- if Present (Else_Actions (N)) then
- Insert_List_Before
- (First (Else_Statements (New_If)), Else_Actions (N));
+ 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.
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 -- CODEFIX???
+ ("?range test optimized away", N);
+ Error_Msg_N -- CODEFIX???
+ ("\?value is known to be out of range", N);
end if;
Rewrite (N,
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 -- CODEFIX???
+ ("?range test optimized away", N);
+ Error_Msg_N -- CODEFIX???
+ ("\?value is known to be in range", N);
end if;
Rewrite (N,
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 -- CODEFIX???
+ ("?lower bound test optimized away", Lo);
+ Error_Msg_N -- CODEFIX???
+ ("\?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 -- CODEFIX???
+ ("?upper bound test optimized away", Hi);
+ Error_Msg_N -- CODEFIX???
+ ("\?value is known to be in range", Hi);
end if;
Rewrite (N,
-- Result is out of range for valid value
if Lcheck = LT or else Ucheck = GT then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX???
("?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
+ Error_Msg_N -- CODEFIX???
("?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
+ Error_Msg_N -- CODEFIX???
("?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
+ Error_Msg_N -- CODEFIX???
("?upper bound check only fails for invalid values", Hi);
end if;
end if;
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_Related_Node (SCIL_Node, N);
+ Insert_Action (N, SCIL_Node);
+ end if;
end if;
return;
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.
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_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 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;
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
+ LI : constant Entity_Id := RTE (RE_Unsigned_64);
+ begin
+ Rewrite (N,
+ Unchecked_Convert_To (Typ,
+ (Make_Op_Not (Loc,
+ Right_Opnd => Unchecked_Convert_To (LI, 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
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,
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 (
-- 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;
---------------------------------
-- 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
Cons : List_Id;
begin
+
-- Nothing else to do if no change of representation
if Same_Representation (Operand_Type, Target_Type) then
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,
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;
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
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 proprgated 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;
+
-- 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);
+ Kind : constant Node_Kind := Nkind (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));
+ Analyze_And_Resolve (Right, Standard_Boolean);
+ end if;
+
+ -- Special processing necessary for SCIL generation for AND THEN
+ -- with a function call as the right operand.
+
+ -- What is this about, and is it needed for both cases above???
+
+ if Generate_SCIL
+ and then Kind = N_And_Then
+ and then Nkind (Right) = N_Function_Call
+ then
+ Adjust_SCIL_Node (N, Right);
+ 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,
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 :=
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX???
("can never be greater than, could replace by ""'=""?", N);
Warning_Generated := True;
end if;
and then Is_Integer_Type (Etype (Left_Opnd (N)))
and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX???
("can never be less than, could replace by ""'=""?", N);
Warning_Generated := True;
end if;
and then not In_Instance
then
if True_Result then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX???
("condition can only be False if invalid values present?",
N);
elsif False_Result then
- Error_Msg_N
+ Error_Msg_N -- CODEFIX???
("condition can only be True if invalid values present?",
N);
end if;
-- 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 / platform / upstream / gcc.git / blobdiff