Google Git
Sign in
gnu / gcc / 82b61df521d17a96f60e56ede06a55a8894b1c2e / . / gcc / ada / exp_ch4.adb
blob: 111a17e967095571aea9dde73757163c2dd1f5e2 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 4 --
-- --
-- B o d y --
-- --
-- $Revision: 1.3 $
-- --
-- Copyright (C) 1992-2001, 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- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Fixd; use Exp_Fixd;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Validsw; use Validsw;
package body Exp_Ch4 is
------------------------
-- Local Subprograms --
------------------------
procedure Binary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Binary_Op_Validity_Checks);
-- Performs validity checks for a binary operator
procedure Expand_Array_Comparison (N : Node_Id);
-- This routine handles expansion of the comparison operators (N_Op_Lt,
-- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
-- code for these operators is similar, differing only in the details of
-- the actual comparison call that is made.
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id;
-- Expand an array equality into a call to a function implementing this
-- equality, and a call to it. Loc is the location for the generated
-- nodes. Typ is the type of the array, and Lhs, Rhs are the array
-- expressions to be compared. A_Typ is the type of the arguments,
-- which may be a private type, in which case Typ is its full view.
-- Bodies is a list on which to attach bodies of local functions that
-- are created in the process. This is the responsability of the
-- caller to insert those bodies at the right place. Nod provides
-- the Sloc value for the generated code.
procedure Expand_Boolean_Operator (N : Node_Id);
-- Common expansion processing for Boolean operators (And, Or, Xor)
-- for the case of array type arguments.
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id;
-- Local recursive function used to expand equality for nested
-- composite types. Used by Expand_Record/Array_Equality, Bodies
-- is a list on which to attach bodies of local functions that are
-- created in the process. This is the responsability of the caller
-- to insert those bodies at the right place. Nod provides the Sloc
-- value for generated code.
procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
-- This routine handles expansion of concatenation operations, where
-- N is the N_Op_Concat node being expanded and Operands is the list
-- of operands (at least two are present). The caller has dealt with
-- converting any singleton operands into singleton aggregates.
procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
-- Routine to expand concatenation of 2-5 operands (in the list Operands)
-- and replace node Cnode with the result of the contatenation. If there
-- are two operands, they can be string or character. If there are more
-- than two operands, then are always of type string (i.e. the caller has
-- already converted character operands to strings in this case).
procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
-- N is either an N_Op_Divide or N_Op_Multiply node whose result is
-- universal fixed. We do not have such a type at runtime, so the
-- purpose of this routine is to find the real type by looking up
-- the tree. We also determine if the operation must be rounded.
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type is derived
-- from Checked_Pool, expands a call to the primitive 'dereference'.
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id)
return Node_Id;
-- Comparisons between arrays are expanded in line. This function
-- produces the body of the implementation of (a > b), where a and b
-- are one-dimensional arrays of some discrete type. The original
-- node is then expanded into the appropriate call to this function.
-- Nod provides the Sloc value for the generated code.
function Make_Boolean_Array_Op
(Typ : Entity_Id;
N : Node_Id)
return Node_Id;
-- Boolean operations on boolean arrays are expanded in line. This
-- function produce the body for the node N, which is (a and b),
-- (a or b), or (a xor b). It is used only the normal case and not
-- the packed case. The type involved, Typ, is the Boolean array type,
-- and the logical operations in the body are simple boolean operations.
-- Note that Typ is always a constrained type (the caller has ensured
-- this by using Convert_To_Actual_Subtype if necessary).
procedure Rewrite_Comparison (N : Node_Id);
-- N is the node for a compile time comparison. If this outcome of this
-- comparison can be determined at compile time, then the node N can be
-- rewritten with True or False. If the outcome cannot be determined at
-- compile time, the call has no effect.
function Tagged_Membership (N : Node_Id) return Node_Id;
-- Construct the expression corresponding to the tagged membership test.
-- Deals with a second operand being (or not) a class-wide type.
procedure Unary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Unary_Op_Validity_Checks);
-- Performs validity checks for a unary operator
-------------------------------
-- Binary_Op_Validity_Checks --
-------------------------------
procedure Binary_Op_Validity_Checks (N : Node_Id) is
begin
if Validity_Checks_On and Validity_Check_Operands then
Ensure_Valid (Left_Opnd (N));
Ensure_Valid (Right_Opnd (N));
end if;
end Binary_Op_Validity_Checks;
-----------------------------
-- Expand_Array_Comparison --
-----------------------------
-- Expansion is only required in the case of array types. The form of
-- the expansion is:
-- [body for greater_nn; boolean_expression]
-- The body is built by Make_Array_Comparison_Op, and the form of the
-- Boolean expression depends on the operator involved.
procedure Expand_Array_Comparison (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Op1 : Node_Id := Left_Opnd (N);
Op2 : Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
Expr : Node_Id;
Func_Body : Node_Id;
Func_Name : Entity_Id;
begin
-- For (a <= b) we convert to not (a > b)
if Chars (N) = Name_Op_Le then
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => Op1,
Right_Opnd => Op2)));
Analyze_And_Resolve (N, Standard_Boolean);
return;
-- For < the Boolean expression is
-- greater__nn (op2, op1)
elsif Chars (N) = Name_Op_Lt then
Func_Body := Make_Array_Comparison_Op (Typ1, N);
-- Switch operands
Op1 := Right_Opnd (N);
Op2 := Left_Opnd (N);
-- For (a >= b) we convert to not (a < b)
elsif Chars (N) = Name_Op_Ge then
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd => Op1,
Right_Opnd => Op2)));
Analyze_And_Resolve (N, Standard_Boolean);
return;
-- For > the Boolean expression is
-- greater__nn (op1, op2)
else
pragma Assert (Chars (N) = Name_Op_Gt);
Func_Body := Make_Array_Comparison_Op (Typ1, N);
end if;
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Expr :=
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => New_List (Op1, Op2));
Insert_Action (N, Func_Body);
Rewrite (N, Expr);
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_Array_Comparison;
---------------------------
-- Expand_Array_Equality --
---------------------------
-- Expand an equality function for multi-dimensional arrays. Here is
-- an example of such a function for Nb_Dimension = 2
-- function Enn (A : arr; B : arr) return boolean is
-- J1 : integer;
-- J2 : integer;
--
-- begin
-- if A'length (1) /= B'length (1) then
-- return false;
-- else
-- J1 := B'first (1);
-- for I1 in A'first (1) .. A'last (1) loop
-- if A'length (2) /= B'length (2) then
-- return false;
-- else
-- J2 := B'first (2);
-- for I2 in A'first (2) .. A'last (2) loop
-- if A (I1, I2) /= B (J1, J2) then
-- return false;
-- end if;
-- J2 := Integer'succ (J2);
-- end loop;
-- end if;
-- J1 := Integer'succ (J1);
-- end loop;
-- end if;
-- return true;
-- end Enn;
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Actuals : List_Id;
Decls : List_Id := New_List;
Index_List1 : List_Id := New_List;
Index_List2 : List_Id := New_List;
Formals : List_Id;
Stats : Node_Id;
Func_Name : Entity_Id;
Func_Body : Node_Id;
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
function Component_Equality (Typ : Entity_Id) return Node_Id;
-- Create one statement to compare corresponding components, designated
-- by a full set of indices.
function Loop_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id;
-- Loop over the n'th dimension of the arrays. The single statement
-- in the body of the loop is a loop over the next dimension, or
-- the comparison of corresponding components.
------------------------
-- Component_Equality --
------------------------
function Component_Equality (Typ : Entity_Id) return Node_Id is
Test : Node_Id;
L, R : Node_Id;
begin
-- if a(i1...) /= b(j1...) then return false; end if;
L :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Chars (A)),
Expressions => Index_List1);
R :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Chars (B)),
Expressions => Index_List2);
Test := Expand_Composite_Equality
(Nod, Component_Type (Typ), L, R, Decls);
return
Make_Implicit_If_Statement (Nod,
Condition => Make_Op_Not (Loc, Right_Opnd => Test),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
end Component_Equality;
------------------------
-- Loop_One_Dimension --
------------------------
function Loop_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id
is
I : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('I'));
J : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('J'));
Index_Type : Entity_Id;
Stats : Node_Id;
begin
if N > Number_Dimensions (Typ) then
return Component_Equality (Typ);
else
-- Generate the following:
-- j: index_type;
-- ...
-- if a'length (n) /= b'length (n) then
-- return false;
-- else
-- j := b'first (n);
-- for i in a'range (n) loop
-- -- loop over remaining dimensions.
-- j := index_type'succ (j);
-- end loop;
-- end if;
-- retrieve index type for current dimension.
Index_Type := Base_Type (Etype (Index));
Append (New_Reference_To (I, Loc), Index_List1);
Append (New_Reference_To (J, Loc), Index_List2);
-- Declare index for j as a local variable to the function.
-- Index i is a loop variable.
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => J,
Object_Definition => New_Reference_To (Index_Type, Loc)));
Stats :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (A, Loc),
Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, N))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (B, Loc),
Attribute_Name => Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc, N)))),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))),
Else_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Reference_To (J, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (B, Loc),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, N)))),
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => I,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (A, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, N))))),
Statements => New_List (
Loop_One_Dimension (N + 1, Next_Index (Index)),
Make_Assignment_Statement (Loc,
Name => New_Reference_To (J, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index_Type, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
New_Reference_To (J, Loc))))))));
return Stats;
end if;
end Loop_One_Dimension;
-- Start of processing for Expand_Array_Equality
begin
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Typ, Loc)));
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Stats := Loop_One_Dimension (1, First_Index (Typ));
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Stats,
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)))));
Set_Has_Completion (Func_Name, True);
-- If the array type is distinct from the type of the arguments,
-- it is the full view of a private type. Apply an unchecked
-- conversion to insure that analysis of the call succeeds.
if Base_Type (A_Typ) /= Base_Type (Typ) then
Actuals := New_List (
OK_Convert_To (Typ, Lhs),
OK_Convert_To (Typ, Rhs));
else
Actuals := New_List (Lhs, Rhs);
end if;
Append_To (Bodies, Func_Body);
return
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => Actuals);
end Expand_Array_Equality;
-----------------------------
-- Expand_Boolean_Operator --
-----------------------------
-- Note that we first get the actual subtypes of the operands,
-- since we always want to deal with types that have bounds.
procedure Expand_Boolean_Operator (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
if Is_Bit_Packed_Array (Typ) then
Expand_Packed_Boolean_Operator (N);
else
-- For the normal non-packed case, the expansion is
-- to build a function for carrying out the comparison
-- (using Make_Boolean_Array_Op) and then inserting it
-- into the tree. The original operator node is then
-- rewritten as a call to this function.
declare
Loc : constant Source_Ptr := Sloc (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
R : constant Node_Id := Relocate_Node (Right_Opnd (N));
Func_Body : Node_Id;
Func_Name : Entity_Id;
begin
Convert_To_Actual_Subtype (L);
Convert_To_Actual_Subtype (R);
Ensure_Defined (Etype (L), N);
Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L));
Func_Body := Make_Boolean_Array_Op (Etype (L), N);
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Insert_Action (N, Func_Body);
-- Now rewrite the expression with a call
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations =>
New_List
(L, Make_Type_Conversion
(Loc, New_Reference_To (Etype (L), Loc), R))));
Analyze_And_Resolve (N, Typ);
end;
end if;
end Expand_Boolean_Operator;
-------------------------------
-- Expand_Composite_Equality --
-------------------------------
-- This function is only called for comparing internal fields of composite
-- types when these fields are themselves composites. This is a special
-- case because it is not possible to respect normal Ada visibility rules.
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Full_Type : Entity_Id;
Prim : Elmt_Id;
Eq_Op : Entity_Id;
begin
if Is_Private_Type (Typ) then
Full_Type := Underlying_Type (Typ);
else
Full_Type := Typ;
end if;
-- Defense against malformed private types with no completion
-- the error will be diagnosed later by check_completion
if No (Full_Type) then
return New_Reference_To (Standard_False, Loc);
end if;
Full_Type := Base_Type (Full_Type);
if Is_Array_Type (Full_Type) then
-- If the operand is an elementary type other than a floating-point
-- type, then we can simply use the built-in block bitwise equality,
-- since the predefined equality operators always apply and bitwise
-- equality is fine for all these cases.
if Is_Elementary_Type (Component_Type (Full_Type))
and then not Is_Floating_Point_Type (Component_Type (Full_Type))
then
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
-- For composite component types, and floating-point types, use
-- the expansion. This deals with tagged component types (where
-- we use the applicable equality routine) and floating-point,
-- (where we need to worry about negative zeroes), and also the
-- case of any composite type recursively containing such fields.
else
return Expand_Array_Equality
(Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
end if;
elsif Is_Tagged_Type (Full_Type) then
-- Call the primitive operation "=" of this type
if Is_Class_Wide_Type (Full_Type) then
Full_Type := Root_Type (Full_Type);
end if;
-- If this is derived from an untagged private type completed
-- with a tagged type, it does not have a full view, so we
-- use the primitive operations of the private type.
-- This check should no longer be necessary when these
-- types receive their full views ???
if Is_Private_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Controlled (Typ)
and then Is_Derived_Type (Typ)
and then No (Full_View (Typ))
then
Prim := First_Elmt (Collect_Primitive_Operations (Typ));
else
Prim := First_Elmt (Primitive_Operations (Full_Type));
end if;
loop
Eq_Op := Node (Prim);
exit when Chars (Eq_Op) = Name_Op_Eq
and then Etype (First_Formal (Eq_Op)) =
Etype (Next_Formal (First_Formal (Eq_Op)));
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
Eq_Op := Node (Prim);
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations =>
New_List
(Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
elsif Is_Record_Type (Full_Type) then
Eq_Op := TSS (Full_Type, Name_uEquality);
if Present (Eq_Op) then
if Etype (First_Formal (Eq_Op)) /= Full_Type then
-- Inherited equality from parent type. Convert the actuals
-- to match signature of operation.
declare
T : Entity_Id := Etype (First_Formal (Eq_Op));
begin
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations =>
New_List (OK_Convert_To (T, Lhs),
OK_Convert_To (T, Rhs)));
end;
else
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations => New_List (Lhs, Rhs));
end if;
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
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
end if;
end Expand_Composite_Equality;
------------------------------
-- Expand_Concatenate_Other --
------------------------------
-- Let n be the number of array operands to be concatenated, Base_Typ
-- their base type, Ind_Typ their index type, and Arr_Typ the original
-- array type to which the concatenantion operator applies, then the
-- following subprogram is constructed:
--
-- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
-- L : Ind_Typ;
-- begin
-- if S1'Length /= 0 then
-- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
-- XXX = Arr_Typ'First otherwise
-- elsif S2'Length /= 0 then
-- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
-- YYY = Arr_Typ'First otherwise
-- ...
-- elsif Sn-1'Length /= 0 then
-- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
-- ZZZ = Arr_Typ'First otherwise
-- else
-- return Sn;
-- end if;
--
-- declare
-- P : Ind_Typ;
-- H : Ind_Typ :=
-- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
-- + Ind_Typ'Pos (L));
-- R : Base_Typ (L .. H);
-- begin
-- if S1'Length /= 0 then
-- P := S1'First;
-- loop
-- R (L) := S1 (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = S1'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
--
-- if S2'Length /= 0 then
-- L := Ind_Typ'Succ (L);
-- loop
-- R (L) := S2 (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = S2'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
--
-- ...
--
-- if Sn'Length /= 0 then
-- P := Sn'First;
-- loop
-- R (L) := Sn (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = Sn'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
--
-- return R;
-- end;
-- end Cnn;]
procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
Loc : constant Source_Ptr := Sloc (Cnode);
Nb_Opnds : constant Nat := List_Length (Opnds);
Arr_Typ : constant Entity_Id := Etype (Entity (Cnode));
Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
Ind_Typ : constant Entity_Id := Etype (First_Index (Base_Typ));
Func_Id : Node_Id;
Func_Spec : Node_Id;
Param_Specs : List_Id;
Func_Body : Node_Id;
Func_Decls : List_Id;
Func_Stmts : List_Id;
L_Decl : Node_Id;
If_Stmt : Node_Id;
Elsif_List : List_Id;
Declare_Block : Node_Id;
Declare_Decls : List_Id;
Declare_Stmts : List_Id;
H_Decl : Node_Id;
H_Init : Node_Id;
P_Decl : Node_Id;
R_Decl : Node_Id;
R_Constr : Node_Id;
R_Range : Node_Id;
Params : List_Id;
Operand : Node_Id;
function Copy_Into_R_S (I : Nat) return List_Id;
-- Builds the sequence of statement:
-- P := Si'First;
-- loop
-- R (L) := Si (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = Si'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
--
-- where i is the input parameter I given.
function Init_L (I : Nat) return Node_Id;
-- Builds the statement:
-- L := Arr_Typ'First; If Arr_Typ is constrained
-- L := Si'First; otherwise (where I is the input param given)
function H return Node_Id;
-- Builds reference to identifier H.
function Ind_Val (E : Node_Id) return Node_Id;
-- Builds expression Ind_Typ'Val (E);
function L return Node_Id;
-- Builds reference to identifier L.
function L_Pos return Node_Id;
-- Builds expression Ind_Typ'Pos (L).
function L_Succ return Node_Id;
-- Builds expression Ind_Typ'Succ (L).
function One return Node_Id;
-- Builds integer literal one.
function P return Node_Id;
-- Builds reference to identifier P.
function P_Succ return Node_Id;
-- Builds expression Ind_Typ'Succ (P).
function R return Node_Id;
-- Builds reference to identifier R.
function S (I : Nat) return Node_Id;
-- Builds reference to identifier Si, where I is the value given.
function S_First (I : Nat) return Node_Id;
-- Builds expression Si'First, where I is the value given.
function S_Last (I : Nat) return Node_Id;
-- Builds expression Si'Last, where I is the value given.
function S_Length (I : Nat) return Node_Id;
-- Builds expression Si'Length, where I is the value given.
function S_Length_Test (I : Nat) return Node_Id;
-- Builds expression Si'Length /= 0, where I is the value given.
-------------------
-- Copy_Into_R_S --
-------------------
function Copy_Into_R_S (I : Nat) return List_Id is
Stmts : List_Id := New_List;
P_Start : Node_Id;
Loop_Stmt : Node_Id;
R_Copy : Node_Id;
Exit_Stmt : Node_Id;
L_Inc : Node_Id;
P_Inc : Node_Id;
begin
-- First construct the initializations
P_Start := Make_Assignment_Statement (Loc,
Name => P,
Expression => S_First (I));
Append_To (Stmts, P_Start);
-- Then build the loop
R_Copy := Make_Assignment_Statement (Loc,
Name => Make_Indexed_Component (Loc,
Prefix => R,
Expressions => New_List (L)),
Expression => Make_Indexed_Component (Loc,
Prefix => S (I),
Expressions => New_List (P)));
L_Inc := Make_Assignment_Statement (Loc,
Name => L,
Expression => L_Succ);
Exit_Stmt := Make_Exit_Statement (Loc,
Condition => Make_Op_Eq (Loc, P, S_Last (I)));
P_Inc := Make_Assignment_Statement (Loc,
Name => P,
Expression => P_Succ);
Loop_Stmt :=
Make_Implicit_Loop_Statement (Cnode,
Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
Append_To (Stmts, Loop_Stmt);
return Stmts;
end Copy_Into_R_S;
-------
-- H --
-------
function H return Node_Id is
begin
return Make_Identifier (Loc, Name_uH);
end H;
-------------
-- Ind_Val --
-------------
function Ind_Val (E : Node_Id) return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (E));
end Ind_Val;
------------
-- Init_L --
------------
function Init_L (I : Nat) return Node_Id is
E : Node_Id;
begin
if Is_Constrained (Arr_Typ) then
E := Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Arr_Typ, Loc),
Attribute_Name => Name_First);
else
E := S_First (I);
end if;
return Make_Assignment_Statement (Loc, Name => L, Expression => E);
end Init_L;
-------
-- L --
-------
function L return Node_Id is
begin
return Make_Identifier (Loc, Name_uL);
end L;
-----------
-- L_Pos --
-----------
function L_Pos return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (L));
end L_Pos;
------------
-- L_Succ --
------------
function L_Succ return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (L));
end L_Succ;
---------
-- One --
---------
function One return Node_Id is
begin
return Make_Integer_Literal (Loc, 1);
end One;
-------
-- P --
-------
function P return Node_Id is
begin
return Make_Identifier (Loc, Name_uP);
end P;
------------
-- P_Succ --
------------
function P_Succ return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (P));
end P_Succ;
-------
-- R --
-------
function R return Node_Id is
begin
return Make_Identifier (Loc, Name_uR);
end R;
-------
-- S --
-------
function S (I : Nat) return Node_Id is
begin
return Make_Identifier (Loc, New_External_Name ('S', I));
end S;
-------------
-- S_First --
-------------
function S_First (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_First);
end S_First;
------------
-- S_Last --
------------
function S_Last (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_Last);
end S_Last;
--------------
-- S_Length --
--------------
function S_Length (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_Length);
end S_Length;
-------------------
-- S_Length_Test --
-------------------
function S_Length_Test (I : Nat) return Node_Id is
begin
return
Make_Op_Ne (Loc,
Left_Opnd => S_Length (I),
Right_Opnd => Make_Integer_Literal (Loc, 0));
end S_Length_Test;
-- Start of processing for Expand_Concatenate_Other
begin
-- Construct the parameter specs and the overall function spec
Param_Specs := New_List;
for I in 1 .. Nb_Opnds loop
Append_To
(Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
Parameter_Type => New_Reference_To (Base_Typ, Loc)));
end loop;
Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
Parameter_Specifications => Param_Specs,
Subtype_Mark => New_Reference_To (Base_Typ, Loc));
-- Construct L's object declaration
L_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
Object_Definition => New_Reference_To (Ind_Typ, Loc));
Func_Decls := New_List (L_Decl);
-- Construct the if-then-elsif statements
Elsif_List := New_List;
for I in 2 .. Nb_Opnds - 1 loop
Append_To (Elsif_List, Make_Elsif_Part (Loc,
Condition => S_Length_Test (I),
Then_Statements => New_List (Init_L (I))));
end loop;
If_Stmt :=
Make_Implicit_If_Statement (Cnode,
Condition => S_Length_Test (1),
Then_Statements => New_List (Init_L (1)),
Elsif_Parts => Elsif_List,
Else_Statements => New_List (Make_Return_Statement (Loc,
Expression => S (Nb_Opnds))));
-- Construct the declaration for H
P_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
Object_Definition => New_Reference_To (Ind_Typ, Loc));
H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
for I in 2 .. Nb_Opnds loop
H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
end loop;
H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
H_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
Object_Definition => New_Reference_To (Ind_Typ, Loc),
Expression => H_Init);
-- Construct the declaration for R
R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
R_Constr :=
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (R_Range));
R_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Base_Typ, Loc),
Constraint => R_Constr));
-- Construct the declarations for the declare block
Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
-- Construct list of statements for the declare block
Declare_Stmts := New_List;
for I in 1 .. Nb_Opnds loop
Append_To (Declare_Stmts,
Make_Implicit_If_Statement (Cnode,
Condition => S_Length_Test (I),
Then_Statements => Copy_Into_R_S (I)));
end loop;
Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
-- Construct the declare block
Declare_Block := Make_Block_Statement (Loc,
Declarations => Declare_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
-- Construct the list of function statements
Func_Stmts := New_List (If_Stmt, Declare_Block);
-- Construct the function body
Func_Body :=
Make_Subprogram_Body (Loc,
Specification => Func_Spec,
Declarations => Func_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
-- Insert the newly generated function in the code. This is analyzed
-- with all checks off, since we have completed all the checks.
-- Note that this does *not* fix the array concatenation bug when the
-- low bound is Integer'first sibce that bug comes from the pointer
-- dereferencing an unconstrained array. An there we need a constraint
-- check to make sure the length of the concatenated array is ok. ???
Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
-- Construct list of arguments for the function call
Params := New_List;
Operand := First (Opnds);
for I in 1 .. Nb_Opnds loop
Append_To (Params, Relocate_Node (Operand));
Next (Operand);
end loop;
-- Insert the function call
Rewrite
(Cnode,
Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
Analyze_And_Resolve (Cnode, Base_Typ);
Set_Is_Inlined (Func_Id);
end Expand_Concatenate_Other;
-------------------------------
-- Expand_Concatenate_String --
-------------------------------
procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
Loc : constant Source_Ptr := Sloc (Cnode);
Opnd1 : constant Node_Id := First (Opnds);
Opnd2 : constant Node_Id := Next (Opnd1);
Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1));
Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2));
R : RE_Id;
-- RE_Id value for function to be called
begin
-- In all cases, we build a call to a routine giving the list of
-- arguments as the parameter list to the routine.
case List_Length (Opnds) is
when 2 =>
if Typ1 = Standard_Character then
if Typ2 = Standard_Character then
R := RE_Str_Concat_CC;
else
pragma Assert (Typ2 = Standard_String);
R := RE_Str_Concat_CS;
end if;
elsif Typ1 = Standard_String then
if Typ2 = Standard_Character then
R := RE_Str_Concat_SC;
else
pragma Assert (Typ2 = Standard_String);
R := RE_Str_Concat;
end if;
-- If we have anything other than Standard_Character or
-- Standard_String, then we must have had an error earlier.
-- So we just abandon the attempt at expansion.
else
pragma Assert (Errors_Detected > 0);
return;
end if;
when 3 =>
R := RE_Str_Concat_3;
when 4 =>
R := RE_Str_Concat_4;
when 5 =>
R := RE_Str_Concat_5;
when others =>
R := RE_Null;
raise Program_Error;
end case;
-- Now generate the appropriate call
Rewrite (Cnode,
Make_Function_Call (Sloc (Cnode),
Name => New_Occurrence_Of (RTE (R), Loc),
Parameter_Associations => Opnds));
Analyze_And_Resolve (Cnode, Standard_String);
end Expand_Concatenate_String;
------------------------
-- Expand_N_Allocator --
------------------------
procedure Expand_N_Allocator (N : Node_Id) is
PtrT : constant Entity_Id := Etype (N);
Desig : Entity_Id;
Loc : constant Source_Ptr := Sloc (N);
Temp : Entity_Id;
Node : Node_Id;
begin
-- RM E.2.3(22). We enforce that the expected type of an allocator
-- shall not be a remote access-to-class-wide-limited-private type
-- Why is this being done at expansion time, seems clearly wrong ???
Validate_Remote_Access_To_Class_Wide_Type (N);
-- Set the Storage Pool
Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
if Present (Storage_Pool (N)) then
if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
if not Java_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
else
Set_Procedure_To_Call (N,
Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
end if;
end if;
-- Under certain circumstances we can replace an allocator by an
-- access to statically allocated storage. The conditions, as noted
-- in AARM 3.10 (10c) are as follows:
-- Size and initial value is known at compile time
-- Access type is access-to-constant
if Is_Access_Constant (PtrT)
and then Nkind (Expression (N)) = N_Qualified_Expression
and then Compile_Time_Known_Value (Expression (Expression (N)))
and then Size_Known_At_Compile_Time (Etype (Expression
(Expression (N))))
then
-- Here we can do the optimization. For the allocator
-- new x'(y)
-- We insert an object declaration
-- Tnn : aliased x := y;
-- and replace the allocator by Tnn'Unrestricted_Access.
-- Tnn is marked as requiring static allocation.
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Desig := Subtype_Mark (Expression (N));
-- If context is constrained, use constrained subtype directly,
-- so that the constant is not labelled as having a nomimally
-- unconstrained subtype.
if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
end if;
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Aliased_Present => True,
Constant_Present => Is_Access_Constant (PtrT),
Object_Definition => Desig,
Expression => Expression (Expression (N))));
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc),
Attribute_Name => Name_Unrestricted_Access));
Analyze_And_Resolve (N, PtrT);
-- We set the variable as statically allocated, since we don't
-- want it going on the stack of the current procedure!
Set_Is_Statically_Allocated (Temp);
return;
end if;
-- If the allocator is for a type which requires initialization, and
-- there is no initial value (i.e. the operand is a subtype indication
-- rather than a qualifed expression), then we must generate a call to
-- the initialization routine. This is done using an expression actions
-- node:
--
-- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
--
-- Here ptr_T is the pointer type for the allocator, and T is the
-- subtype of the allocator. A special case arises if the designated
-- type of the access type is a task or contains tasks. In this case
-- the call to Init (Temp.all ...) is replaced by code that ensures
-- that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
-- for details). In addition, if the type T is a task T, then the first
-- argument to Init must be converted to the task record type.
if Nkind (Expression (N)) = N_Qualified_Expression then
declare
Indic : constant Node_Id := Subtype_Mark (Expression (N));
T : constant Entity_Id := Entity (Indic);
Exp : constant Node_Id := Expression (Expression (N));
Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
Tag_Assign : Node_Id;
Tmp_Node : Node_Id;
begin
if Is_Tagged_Type (T) or else Controlled_Type (T) then
-- Actions inserted before:
-- Temp : constant ptr_T := new T'(Expression);
-- <no CW> Temp._tag := T'tag;
-- <CTRL> Adjust (Finalizable (Temp.all));
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- We analyze by hand the new internal allocator to avoid
-- any recursion and inappropriate call to Initialize
if not Aggr_In_Place then
Remove_Side_Effects (Exp);
end if;
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-- For a class wide allocation generate the following code:
-- type Equiv_Record is record ... end record;
-- implicit subtype CW is <Class_Wide_Subytpe>;
-- temp : PtrT := new CW'(CW!(expr));
if Is_Class_Wide_Type (T) then
Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
Set_Expression (Expression (N),
Unchecked_Convert_To (Entity (Indic), Exp));
Analyze_And_Resolve (Expression (N), Entity (Indic));
end if;
if Aggr_In_Place then
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Make_Allocator (Loc,
New_Reference_To (Etype (Exp), Loc)));
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
Convert_Aggr_In_Allocator (Tmp_Node, Exp);
else
Node := Relocate_Node (N);
Set_Analyzed (Node);
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Node));
end if;
-- Suppress the tag assignment when Java_VM because JVM tags
-- are represented implicitly in objects.
if Is_Tagged_Type (T)
and then not Is_Class_Wide_Type (T)
and then not Java_VM
then
Tag_Assign :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Temp, Loc),
Selector_Name =>
New_Reference_To (Tag_Component (T), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (T), Loc)));
-- The previous assignment has to be done in any case
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
elsif Is_Private_Type (T)
and then Is_Tagged_Type (Underlying_Type (T))
and then not Java_VM
then
declare
Utyp : constant Entity_Id := Underlying_Type (T);
Ref : constant Node_Id :=
Unchecked_Convert_To (Utyp,
Make_Explicit_Dereference (Loc,
New_Reference_To (Temp, Loc)));
begin
Tag_Assign :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Ref,
Selector_Name =>
New_Reference_To (Tag_Component (Utyp), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
Access_Disp_Table (Utyp), Loc)));
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
end;
end if;
if Controlled_Type (Designated_Type (PtrT))
and then Controlled_Type (T)
then
declare
Flist : Node_Id;
Attach : Node_Id;
Apool : constant Entity_Id :=
Associated_Storage_Pool (PtrT);
begin
-- If it is an allocation on the secondary stack
-- (i.e. a value returned from a function), the object
-- is attached on the caller side as soon as the call
-- is completed (see Expand_Ctrl_Function_Call)
if Is_RTE (Apool, RE_SS_Pool) then
declare
F : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('F'));
begin
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => F,
Object_Definition => New_Reference_To (RTE
(RE_Finalizable_Ptr), Loc)));
Flist := New_Reference_To (F, Loc);
Attach := Make_Integer_Literal (Loc, 1);
end;
-- Normal case, not a secondary stack allocation
else
Flist := Find_Final_List (PtrT);
Attach := Make_Integer_Literal (Loc, 2);
end if;
if not Aggr_In_Place then
Insert_Actions (N,
Make_Adjust_Call (
Ref =>
-- An unchecked conversion is needed in the
-- classwide case because the designated type
-- can be an ancestor of the subtype mark of
-- the allocator.
Unchecked_Convert_To (T,
Make_Explicit_Dereference (Loc,
New_Reference_To (Temp, Loc))),
Typ => T,
Flist_Ref => Flist,
With_Attach => Attach));
end if;
end;
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
elsif Aggr_In_Place then
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Make_Allocator (Loc,
New_Reference_To (Etype (Exp), Loc)));
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
Convert_Aggr_In_Allocator (Tmp_Node, Exp);
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
elsif Is_Access_Type (Designated_Type (PtrT))
and then Nkind (Exp) = N_Allocator
and then Nkind (Expression (Exp)) /= N_Qualified_Expression
then
-- Apply constraint to designated subtype indication.
Apply_Constraint_Check (Expression (Exp),
Designated_Type (Designated_Type (PtrT)),
No_Sliding => True);
if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
-- Propagate constraint_error to enclosing allocator.
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);
-- 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 not allow sliding,
-- but this check does (a relaxation from Ada 83).
if Is_Constrained (Designated_Type (PtrT))
and then not Subtypes_Statically_Match
(T, Designated_Type (PtrT))
then
Apply_Constraint_Check
(Exp, Designated_Type (PtrT), 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, Designated_Type (PtrT), No_Sliding => True);
end if;
end if;
end;
-- Here if not qualified expression case.
-- In this case, an initialization routine may be required
else
declare
T : constant Entity_Id := Entity (Expression (N));
Init : Entity_Id;
Arg1 : Node_Id;
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Discr : Elmt_Id;
Flist : Node_Id;
Temp_Decl : Node_Id;
Temp_Type : Entity_Id;
begin
if No_Initialization (N) then
null;
-- Case of no initialization procedure present
elsif not Has_Non_Null_Base_Init_Proc (T) then
-- Case of simple initialization required
if Needs_Simple_Initialization (T) then
Rewrite (Expression (N),
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Expression => Get_Simple_Init_Val (T, Loc)));
Analyze_And_Resolve (Expression (Expression (N)), T);
Analyze_And_Resolve (Expression (N), T);
Set_Paren_Count (Expression (Expression (N)), 1);
Expand_N_Allocator (N);
-- No initialization required
else
null;
end if;
-- Case of initialization procedure present, must be called
else
Init := Base_Init_Proc (T);
Node := N;
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-- Construct argument list for the initialization routine call
-- The CPP constructor needs the address directly
if Is_CPP_Class (T) then
Arg1 := New_Reference_To (Temp, Loc);
Temp_Type := T;
else
Arg1 :=
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc));
Set_Assignment_OK (Arg1);
Temp_Type := PtrT;
-- The initialization procedure expects a specific type.
-- if the context is access to class wide, indicate that
-- the object being allocated has the right specific type.
if Is_Class_Wide_Type (Designated_Type (PtrT)) then
Arg1 := Unchecked_Convert_To (T, Arg1);
end if;
end if;
-- If designated type is a concurrent type or if it is a
-- private type whose definition is a concurrent type,
-- the first argument in the Init routine has to be
-- unchecked conversion to the corresponding record type.
-- If the designated type is a derived type, we also
-- convert the argument to its root type.
if Is_Concurrent_Type (T) then
Arg1 :=
Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Is_Concurrent_Type (Full_View (T))
then
Arg1 :=
Unchecked_Convert_To
(Corresponding_Record_Type (Full_View (T)), Arg1);
elsif Etype (First_Formal (Init)) /= Base_Type (T) then
declare
Ftyp : constant Entity_Id := Etype (First_Formal (Init));
begin
Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
Set_Etype (Arg1, Ftyp);
end;
end if;
Args := New_List (Arg1);
-- For the task case, pass the Master_Id of the access type
-- as the value of the _Master parameter, and _Chain as the
-- value of the _Chain parameter (_Chain will be defined as
-- part of the generated code for the allocator).
if Has_Task (T) then
if No (Master_Id (Base_Type (PtrT))) then
-- The designated type was an incomplete type, and
-- the access type did not get expanded. Salvage
-- it now.
Expand_N_Full_Type_Declaration
(Parent (Base_Type (PtrT)));
end if;
-- If the context of the allocator is a declaration or
-- an assignment, we can generate a meaningful image for
-- it, even though subsequent assignments might remove
-- the connection between task and entity. We build this
-- image when the left-hand side is a simple variable,
-- a simple indexed assignment or a simple selected
-- component.
if Nkind (Parent (N)) = N_Assignment_Statement then
declare
Nam : constant Node_Id := Name (Parent (N));
begin
if Is_Entity_Name (Nam) then
Decls :=
Build_Task_Image_Decls (
Loc,
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
elsif (Nkind (Nam) = N_Indexed_Component
or else Nkind (Nam) = N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam))
then
Decls :=
Build_Task_Image_Decls
(Loc, Nam, Etype (Prefix (Nam)));
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
end;
elsif Nkind (Parent (N)) = N_Object_Declaration then
Decls :=
Build_Task_Image_Decls (
Loc, Defining_Identifier (Parent (N)), T);
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
Append_To (Args,
New_Reference_To
(Master_Id (Base_Type (Root_Type (PtrT))), Loc));
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
else
Decls := No_List;
end if;
-- Add discriminants if discriminated type
if Has_Discriminants (T) then
Discr := First_Elmt (Discriminant_Constraint (T));
while Present (Discr) loop
Append (New_Copy (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Discr :=
First_Elmt (Discriminant_Constraint (Full_View (T)));
while Present (Discr) loop
Append (New_Copy (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
end if;
-- We set the allocator as analyzed so that when we analyze the
-- expression actions node, we do not get an unwanted recursive
-- expansion of the allocator expression.
Set_Analyzed (N, True);
Node := Relocate_Node (N);
-- Here is the transformation:
-- input: new T
-- output: Temp : constant ptr_T := new T;
-- Init (Temp.all, ...);
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- <CTRL> Initialize (Finalizable (Temp.all));
-- Here ptr_T is the pointer type for the allocator, and T
-- is the subtype of the allocator.
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Temp_Type, Loc),
Expression => Node);
Set_Assignment_OK (Temp_Decl);
if Is_CPP_Class (T) then
Set_Aliased_Present (Temp_Decl);
end if;
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
-- Case of designated type is task or contains task
-- Create block to activate created tasks, and insert
-- declaration for Task_Image variable ahead of call.
if Has_Task (T) then
declare
L : List_Id := New_List;
Blk : Node_Id;
begin
Build_Task_Allocate_Block (L, Node, Args);
Blk := Last (L);
Insert_List_Before (First (Declarations (Blk)), Decls);
Insert_Actions (N, L);
end;
else
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args));
end if;
if Controlled_Type (T) then
-- If the context is an access parameter, we need to create
-- a non-anonymous access type in order to have a usable
-- final list, because there is otherwise no pool to which
-- the allocated object can belong. We create both the type
-- and the finalization chain here, because freezing an
-- internal type does not create such a chain.
if Ekind (PtrT) = E_Anonymous_Access_Type then
declare
Acc : Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('I'));
begin
Insert_Action (N,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Acc,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (T, Loc))));
Build_Final_List (N, Acc);
Flist := Find_Final_List (Acc);
end;
else
Flist := Find_Final_List (PtrT);
end if;
Insert_Actions (N,
Make_Init_Call (
Ref => New_Copy_Tree (Arg1),
Typ => T,
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, 2)));
end if;
if Is_CPP_Class (T) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Temp, Loc),
Attribute_Name => Name_Unchecked_Access));
else
Rewrite (N, New_Reference_To (Temp, Loc));
end if;
Analyze_And_Resolve (N, PtrT);
end if;
end;
end if;
end Expand_N_Allocator;
-----------------------
-- 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 of left argument is True or False
if Nkind (Left) = N_Identifier 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 Entity (Left) = Standard_True then
if Present (Actions (N)) then
Insert_Actions (N, Actions (N));
end if;
Rewrite (N, Right);
Adjust_Result_Type (N, Typ);
return;
-- 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.
elsif Entity (Left) = Standard_False then
Kill_Dead_Code (Right);
Kill_Dead_Code (Actions (N));
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
Adjust_Result_Type (N, Typ);
return;
end if;
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 Nkind (Right) = N_Identifier 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 Entity (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.
elsif Entity (Right) = Standard_False then
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;
-------------------------------------
-- Expand_N_Conditional_Expression --
-------------------------------------
-- Expand into expression actions if then/else actions present
procedure Expand_N_Conditional_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := First (Expressions (N));
Thenx : constant Node_Id := Next (Cond);
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
Cnn : Entity_Id;
New_If : Node_Id;
begin
-- If either then or else actions are present, then given:
-- if cond then then-expr else else-expr end
-- 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.
if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
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 (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;
Rewrite (N, New_Occurrence_Of (Cnn, Loc));
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Cnn,
Object_Definition => New_Occurrence_Of (Typ, Loc)));
Insert_Action (N, New_If);
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Conditional_Expression;
-----------------------------------
-- Expand_N_Explicit_Dereference --
-----------------------------------
procedure Expand_N_Explicit_Dereference (N : Node_Id) is
begin
-- The only processing required is an insertion of an explicit
-- dereference call for the checked storage pool case.
Insert_Dereference_Action (Prefix (N));
end Expand_N_Explicit_Dereference;
-----------------
-- Expand_N_In --
-----------------
procedure Expand_N_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Rtyp : constant Entity_Id := Etype (N);
begin
-- No expansion is required if we have an explicit range
if Nkind (Right_Opnd (N)) = N_Range then
return;
-- Here right operand is a subtype mark
else
declare
Typ : Entity_Id := Etype (Right_Opnd (N));
Obj : Node_Id := Left_Opnd (N);
Cond : Node_Id := Empty;
Is_Acc : Boolean := Is_Access_Type (Typ);
begin
Remove_Side_Effects (Obj);
-- For tagged type, do tagged membership operation
if Is_Tagged_Type (Typ) then
-- No expansion will be performed when Java_VM, as the
-- JVM back end will handle the membership tests directly
-- (tags are not explicitly represented in Java objects,
-- so the normal tagged membership expansion is not what
-- we want).
if not Java_VM then
Rewrite (N, Tagged_Membership (N));
Analyze_And_Resolve (N, Rtyp);
end if;
return;
-- If type is scalar type, rewrite as x in t'first .. t'last
-- This reason we do this is that the bounds may have the wrong
-- type if they come from the original type definition.
elsif Is_Scalar_Type (Typ) then
Rewrite (Right_Opnd (N),
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Reference_To (Typ, Loc)),
High_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Reference_To (Typ, Loc))));
Analyze_And_Resolve (N, Rtyp);
return;
end if;
if Is_Acc then
Typ := Designated_Type (Typ);
end if;
if not Is_Constrained (Typ) then
Rewrite (N,
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
-- For the constrained array case, we have to check the
-- subscripts for an exact match if the lengths are
-- non-zero (the lengths must match in any case).
elsif Is_Array_Type (Typ) then
declare
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id;
-- Build attribute reference E'Nam(Dim)
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id
is
begin
return
Make_Attribute_Reference (Loc,
Prefix => E,
Attribute_Name => Nam,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim)));
end Construct_Attribute_Reference;
begin
for J in 1 .. Number_Dimensions (Typ) loop
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
(Duplicate_Subexpr (Obj), Name_First, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_First, J)));
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
(Duplicate_Subexpr (Obj), Name_Last, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_Last, J)));
end loop;
if Is_Acc then
Cond := Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
end;
-- These are the cases where constraint checks may be
-- required, e.g. records with possible discriminants
else
-- Expand the test into a series of discriminant comparisons.
-- The expression that is built is the negation of the one
-- that is used for checking discriminant constraints.
Obj := Relocate_Node (Left_Opnd (N));
if Has_Discriminants (Typ) then
Cond := Make_Op_Not (Loc,
Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
if Is_Acc then
Cond := Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
else
Cond := New_Occurrence_Of (Standard_True, Loc);
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
end if;
end;
end if;
end Expand_N_In;
--------------------------------
-- Expand_N_Indexed_Component --
--------------------------------
procedure Expand_N_Indexed_Component (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
begin
-- A special optimization, if we have an indexed component that
-- is selecting from a slice, then we can eliminate the slice,
-- since, for example, x (i .. j)(k) is identical to x(k). The
-- only difference is the range check required by the slice. The
-- range check for the slice itself has already been generated.
-- The range check for the subscripting operation is ensured
-- by converting the subject to the subtype of the slice.
-- This optimization not only generates better code, avoiding
-- slice messing especially in the packed case, but more importantly
-- bypasses some problems in handling this peculiar case, for
-- example, the issue of dealing specially with object renamings.
if Nkind (P) = N_Slice then
Rewrite (N,
Make_Indexed_Component (Loc,
Prefix => Prefix (P),
Expressions => New_List (
Convert_To
(Etype (First_Index (Etype (P))),
First (Expressions (N))))));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- If the prefix is an access type, then we unconditionally rewrite
-- if as an explicit deference. 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.
if Is_Access_Type (T) then
Rewrite (P,
Make_Explicit_Dereference (Sloc (N),
Prefix => Relocate_Node (P)));
Analyze_And_Resolve (P, Designated_Type (T));
end if;
if Validity_Checks_On and then Validity_Check_Subscripts then
Apply_Subscript_Validity_Checks (N);
end if;
-- All done for the non-packed case
if not Is_Packed (Etype (Prefix (N))) then
return;
end if;
-- For packed arrays that are not bit-packed (i.e. the case of an array
-- with one or more index types with a non-coniguous enumeration type),
-- we can always use the normal packed element get circuit.
if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
Expand_Packed_Element_Reference (N);
return;
end if;
-- For a reference to a component of a bit packed array, we have to
-- convert it to a reference to the corresponding Packed_Array_Type.
-- We only want to do this for simple references, and not for:
-- Left side of assignment (or prefix of left side of assignment)
-- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
-- Renaming objects in renaming associations
-- This case is handled when a use of the renamed variable occurs
-- Actual parameters for a procedure call
-- This case is handled in Exp_Ch6.Expand_Actuals
-- The second expression in a 'Read attribute reference
-- The prefix of an address or size attribute reference
-- The following circuit detects these exceptions
declare
Child : Node_Id := N;
Parnt : Node_Id := Parent (N);
begin
loop
if Nkind (Parnt) = N_Unchecked_Expression then
null;
elsif Nkind (Parnt) = N_Object_Renaming_Declaration
or else Nkind (Parnt) = N_Procedure_Call_Statement
or else (Nkind (Parnt) = N_Parameter_Association
and then
Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
then
return;
elsif Nkind (Parnt) = N_Attribute_Reference
and then (Attribute_Name (Parnt) = Name_Address
or else
Attribute_Name (Parnt) = Name_Size)
and then Prefix (Parnt) = Child
then
return;
elsif Nkind (Parnt) = N_Assignment_Statement
and then Name (Parnt) = Child
then
return;
elsif Nkind (Parnt) = N_Attribute_Reference
and then Attribute_Name (Parnt) = Name_Read
and then Next (First (Expressions (Parnt))) = Child
then
return;
elsif (Nkind (Parnt) = N_Indexed_Component
or else Nkind (Parnt) = N_Selected_Component)
and then Prefix (Parnt) = Child
then
null;
else
Expand_Packed_Element_Reference (N);
return;
end if;
-- Keep looking up tree for unchecked expression, or if we are
-- the prefix of a possible assignment left side.
Child := Parnt;
Parnt := Parent (Child);
end loop;
end;
end Expand_N_Indexed_Component;
---------------------
-- Expand_N_Not_In --
---------------------
-- Replace a not in b by not (a in b) so that the expansions for (a in b)
-- can be done. This avoids needing to duplicate this expansion code.
procedure Expand_N_Not_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_In (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N))));
Analyze_And_Resolve (N, Typ);
end Expand_N_Not_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.
procedure Expand_N_Null (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Agg : Node_Id;
begin
if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
Agg :=
Make_Aggregate (Loc,
Expressions => New_List (
New_Occurrence_Of (RTE (RE_Null_Address), Loc),
Make_Null (Loc)));
Rewrite (N, Agg);
Analyze_And_Resolve (N, Equivalent_Type (Typ));
-- For subsequent semantic analysis, the node must retain its
-- type. Gigi in any case replaces this type by the corresponding
-- record type before processing the node.
Set_Etype (N, Typ);
end if;
end Expand_N_Null;
---------------------
-- Expand_N_Op_Abs --
---------------------
procedure Expand_N_Op_Abs (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Expr : constant Node_Id := Right_Opnd (N);
begin
Unary_Op_Validity_Checks (N);
-- Deal with software overflow checking
if Software_Overflow_Checking
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
then
-- Software overflow checking expands abs (expr) into
-- (if expr >= 0 then expr else -expr)
-- with the usual Duplicate_Subexpr use coding for expr
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Ge (Loc,
Left_Opnd => Duplicate_Subexpr (Expr),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Duplicate_Subexpr (Expr),
Make_Op_Minus (Loc,
Right_Opnd => Duplicate_Subexpr (Expr)))));
Analyze_And_Resolve (N);
-- Vax floating-point types case
elsif Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Abs;
---------------------
-- Expand_N_Op_Add --
---------------------
procedure Expand_N_Op_Add (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
-- N + 0 = 0 + N = N for integer types
if Is_Integer_Type (Typ) then
if Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_0
then
Rewrite (N, Left_Opnd (N));
return;
elsif Compile_Time_Known_Value (Left_Opnd (N))
and then Expr_Value (Left_Opnd (N)) = Uint_0
then
Rewrite (N, Right_Opnd (N));
return;
end if;
end if;
-- Arithemtic overflow checks for signed integer/fixed point types
if Is_Signed_Integer_Type (Typ)
or else Is_Fixed_Point_Type (Typ)
then
Apply_Arithmetic_Overflow_Check (N);
return;
-- Vax floating-point types case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Add;
---------------------
-- Expand_N_Op_And --
---------------------
procedure Expand_N_Op_And (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Array_Type (Etype (N)) then
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;
------------------------
-- Expand_N_Op_Concat --
------------------------
procedure Expand_N_Op_Concat (N : Node_Id) is
Opnds : List_Id;
-- List of operands to be concatenated
Opnd : Node_Id;
-- Single operand for concatenation
Cnode : Node_Id;
-- Node which is to be replaced by the result of concatenating
-- the nodes in the list Opnds.
Atyp : Entity_Id;
-- Array type of concatenation result type
Ctyp : Entity_Id;
-- Component type of concatenation represented by Cnode
begin
Binary_Op_Validity_Checks (N);
-- If we are the left operand of a concatenation higher up the
-- tree, then do nothing for now, since we want to deal with a
-- series of concatenations as a unit.
if Nkind (Parent (N)) = N_Op_Concat
and then N = Left_Opnd (Parent (N))
then
return;
end if;
-- We get here with a concatenation whose left operand may be a
-- concatenation itself with a consistent type. We need to process
-- these concatenation operands from left to right, which means
-- from the deepest node in the tree to the highest node.
Cnode := N;
while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
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
-- The outer loop runs more than once if there are more than five
-- concatenations of type Standard.String, the most we handle for
-- this case, or if more than one concatenation type is involved.
Outer : loop
Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
Set_Parent (Opnds, N);
-- The inner loop gathers concatenation operands
Inner : while Cnode /= N
and then (Base_Type (Etype (Cnode)) /= Standard_String
or else
List_Length (Opnds) < 5)
and then Base_Type (Etype (Cnode)) =
Base_Type (Etype (Parent (Cnode)))
loop
Cnode := Parent (Cnode);
Append (Right_Opnd (Cnode), Opnds);
end loop Inner;
-- Here we process the collected operands. First we convert
-- singleton operands to singleton aggregates. This is skipped
-- however for the case of two operands of type String, since
-- we have special routines for these cases.
Atyp := Base_Type (Etype (Cnode));
Ctyp := Base_Type (Component_Type (Etype (Cnode)));
if List_Length (Opnds) > 2 or else Atyp /= Standard_String then
Opnd := First (Opnds);
loop
if Base_Type (Etype (Opnd)) = Ctyp then
Rewrite (Opnd,
Make_Aggregate (Sloc (Cnode),
Expressions => New_List (Relocate_Node (Opnd))));
Analyze_And_Resolve (Opnd, Atyp);
end if;
Next (Opnd);
exit when No (Opnd);
end loop;
end if;
-- Now call appropriate continuation routine
if Atyp = Standard_String then
Expand_Concatenate_String (Cnode, Opnds);
else
Expand_Concatenate_Other (Cnode, Opnds);
end if;
exit Outer when Cnode = N;
Cnode := Parent (Cnode);
end loop Outer;
end Expand_N_Op_Concat;
------------------------
-- Expand_N_Op_Divide --
------------------------
procedure Expand_N_Op_Divide (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ltyp : constant Entity_Id := Etype (Left_Opnd (N));
Rtyp : constant Entity_Id := Etype (Right_Opnd (N));
Typ : Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
-- Vax_Float is a special case
if Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if;
-- N / 1 = N for integer types
if Is_Integer_Type (Typ)
and then Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_1
then
Rewrite (N, Left_Opnd (N));
return;
end if;
-- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an unsigned integer, as required for this to work.
if Nkind (Right_Opnd (N)) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
then
Rewrite (N,
Make_Op_Shift_Right (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd =>
Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- Do required fixup of universal fixed operation
if Typ = Universal_Fixed then
Fixup_Universal_Fixed_Operation (N);
Typ := Etype (N);
end if;
-- Divisions with fixed-point results
if Is_Fixed_Point_Type (Typ) then
-- No special processing if Treat_Fixed_As_Integer is set,
-- since from a semantic point of view such operations are
-- simply integer operations and will be treated that way.
if not Treat_Fixed_As_Integer (N) then
if Is_Integer_Type (Rtyp) then
Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
else
Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
end if;
end if;
-- Other cases of division of fixed-point operands. Again we
-- exclude the case where Treat_Fixed_As_Integer is set.
elsif (Is_Fixed_Point_Type (Ltyp) or else
Is_Fixed_Point_Type (Rtyp))
and then not Treat_Fixed_As_Integer (N)
then
if Is_Integer_Type (Typ) then
Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
else
pragma Assert (Is_Floating_Point_Type (Typ));
Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
end if;
-- Mixed-mode operations can appear in a non-static universal
-- context, in which case the integer argument must be converted
-- explicitly.
elsif Typ = Universal_Real
and then Is_Integer_Type (Rtyp)
then
Rewrite (Right_Opnd (N),
Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
elsif Typ = Universal_Real
and then Is_Integer_Type (Ltyp)
then
Rewrite (Left_Opnd (N),
Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
-- Non-fixed point cases, do zero divide and overflow checks
elsif Is_Integer_Type (Typ) then
Apply_Divide_Check (N);
end if;
end Expand_N_Op_Divide;
--------------------
-- Expand_N_Op_Eq --
--------------------
procedure Expand_N_Op_Eq (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Lhs : constant Node_Id := Left_Opnd (N);
Rhs : constant Node_Id := Right_Opnd (N);
A_Typ : Entity_Id := Etype (Lhs);
Typl : Entity_Id := A_Typ;
Op_Name : Entity_Id;
Prim : Elmt_Id;
Bodies : List_Id := New_List;
procedure Build_Equality_Call (Eq : Entity_Id);
-- If a constructed equality exists for the type or for its parent,
-- build and analyze call, adding conversions if the operation is
-- inherited.
-------------------------
-- Build_Equality_Call --
-------------------------
procedure Build_Equality_Call (Eq : Entity_Id) is
Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
L_Exp : Node_Id := Relocate_Node (Lhs);
R_Exp : Node_Id := Relocate_Node (Rhs);
begin
if Base_Type (Op_Type) /= Base_Type (A_Typ)
and then not Is_Class_Wide_Type (A_Typ)
then
L_Exp := OK_Convert_To (Op_Type, L_Exp);
R_Exp := OK_Convert_To (Op_Type, R_Exp);
end if;
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Eq, Loc),
Parameter_Associations => New_List (L_Exp, R_Exp)));
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end Build_Equality_Call;
-- Start of processing for Expand_N_Op_Eq
begin
Binary_Op_Validity_Checks (N);
if Ekind (Typl) = E_Private_Type then
Typl := Underlying_Type (Typl);
elsif Ekind (Typl) = E_Private_Subtype then
Typl := Underlying_Type (Base_Type (Typl));
end if;
-- It may happen in error situations that the underlying type is not
-- set. The error will be detected later, here we just defend the
-- expander code.
if No (Typl) then
return;
end if;
Typl := Base_Type (Typl);
-- Vax float types
if Vax_Float (Typl) then
Expand_Vax_Comparison (N);
return;
-- Boolean types (requiring handling of non-standard case)
elsif Is_Boolean_Type (Typl) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
-- Array types
elsif Is_Array_Type (Typl) then
-- Packed case
if Is_Bit_Packed_Array (Typl) then
Expand_Packed_Eq (N);
-- For non-floating-point elementary types, the primitive equality
-- always applies, and block-bit comparison is fine. Floating-point
-- is an exception because of negative zeroes.
-- However, we never use block bit comparison in No_Run_Time mode,
-- since this may result in a call to a run time routine
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then not No_Run_Time
then
null;
-- For composite and floating-point cases, expand equality loop
-- to make sure of using proper comparisons for tagged types,
-- and correctly handling the floating-point case.
else
Rewrite (N,
Expand_Array_Equality (N, Typl, A_Typ,
Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
Insert_Actions (N, Bodies, Suppress => All_Checks);
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end if;
-- Record Types
elsif Is_Record_Type (Typl) then
-- For tagged types, use the primitive "="
if Is_Tagged_Type (Typl) then
-- If this is derived from an untagged private type completed
-- with a tagged type, it does not have a full view, so we
-- use the primitive operations of the private type.
-- This check should no longer be necessary when these
-- types receive their full views ???
if Is_Private_Type (A_Typ)
and then not Is_Tagged_Type (A_Typ)
and then Is_Derived_Type (A_Typ)
and then No (Full_View (A_Typ))
then
Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
while Chars (Node (Prim)) /= Name_Op_Eq loop
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
Op_Name := Node (Prim);
else
Op_Name := Find_Prim_Op (Typl, Name_Op_Eq);
end if;
Build_Equality_Call (Op_Name);
-- If a type support function is present (for complex cases), use it
elsif Present (TSS (Root_Type (Typl), Name_uEquality)) then
Build_Equality_Call (TSS (Root_Type (Typl), Name_uEquality));
-- Otherwise expand the component by component equality. Note that
-- we never use block-bit coparisons for records, because of the
-- problems with gaps. The backend will often be able to recombine
-- the separate comparisons that we generate here.
else
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
Rewrite (N,
Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
Insert_Actions (N, Bodies, Suppress => All_Checks);
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end if;
end if;
-- If we still have an equality comparison (i.e. it was not rewritten
-- in some way), then we can test if result is needed at compile time).
if Nkind (N) = N_Op_Eq then
Rewrite_Comparison (N);
end if;
end Expand_N_Op_Eq;
-----------------------
-- Expand_N_Op_Expon --
-----------------------
procedure Expand_N_Op_Expon (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Rtyp : constant Entity_Id := Root_Type (Typ);
Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
Exptyp : constant Entity_Id := Etype (Exp);
Ovflo : constant Boolean := Do_Overflow_Check (N);
Expv : Uint;
Xnode : Node_Id;
Temp : Node_Id;
Rent : RE_Id;
Ent : Entity_Id;
begin
Binary_Op_Validity_Checks (N);
-- At this point the exponentiation must be dynamic since the static
-- case has already been folded after Resolve by Eval_Op_Expon.
-- Test for case of literal right argument
if Compile_Time_Known_Value (Exp) then
Expv := Expr_Value (Exp);
-- We only fold small non-negative exponents. You might think we
-- could fold small negative exponents for the real case, but we
-- can't because we are required to raise Constraint_Error for
-- the case of 0.0 ** (negative) even if Machine_Overflows = False.
-- See ACVC test C4A012B.
if Expv >= 0 and then Expv <= 4 then
-- X ** 0 = 1 (or 1.0)
if Expv = 0 then
if Ekind (Typ) in Integer_Kind then
Xnode := Make_Integer_Literal (Loc, Intval => 1);
else
Xnode := Make_Real_Literal (Loc, Ureal_1);
end if;
-- X ** 1 = X
elsif Expv = 1 then
Xnode := Base;
-- X ** 2 = X * X
elsif Expv = 2 then
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr (Base));
-- X ** 3 = X * X * X
elsif Expv = 3 then
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr (Base)),
Right_Opnd => Duplicate_Subexpr (Base));
-- X ** 4 ->
-- En : constant base'type := base * base;
-- ...
-- En * En
else -- Expv = 4
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Typ, Loc),
Expression =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr (Base)))));
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd => New_Reference_To (Temp, Loc),
Right_Opnd => New_Reference_To (Temp, Loc));
end if;
Rewrite (N, Xnode);
Analyze_And_Resolve (N, Typ);
return;
end if;
end if;
-- Case of (2 ** expression) appearing as an argument of an integer
-- multiplication, or as the right argument of a division of a non-
-- negative integer. In such cases we lave the node untouched, setting
-- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
-- of the higher level node converts it into a shift.
if Nkind (Base) = N_Integer_Literal
and then Intval (Base) = 2
and then Is_Integer_Type (Root_Type (Exptyp))
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);
begin
if (Nkind (P) = N_Op_Multiply
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;
end if;
-- Fall through if exponentiation must be done using a runtime routine.
-- First deal with modular case.
if Is_Modular_Integer_Type (Rtyp) then
-- Non-binary case, we call the special exponentiation routine for
-- the non-binary case, converting the argument to Long_Long_Integer
-- and passing the modulus value. Then the result is converted back
-- to the base type.
if Non_Binary_Modulus (Rtyp) then
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
Parameter_Associations => New_List (
Convert_To (Standard_Integer, Base),
Make_Integer_Literal (Loc, Modulus (Rtyp)),
Exp))));
-- Binary case, in this case, we call one of two routines, either
-- the unsigned integer case, or the unsigned long long integer
-- case, with a final "and" operation to do the required mod.
else
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
Ent := RTE (RE_Exp_Unsigned);
else
Ent := RTE (RE_Exp_Long_Long_Unsigned);
end if;
Rewrite (N,
Convert_To (Typ,
Make_Op_And (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name => New_Reference_To (Ent, Loc),
Parameter_Associations => New_List (
Convert_To (Etype (First_Formal (Ent)), Base),
Exp)),
Right_Opnd =>
Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
end if;
-- Common exit point for modular type case
Analyze_And_Resolve (N, Typ);
return;
-- Signed integer cases
elsif Rtyp = Base_Type (Standard_Integer) then
if Ovflo then
Rent := RE_Exp_Integer;
else
Rent := RE_Exn_Integer;
end if;
elsif Rtyp = Base_Type (Standard_Short_Integer) then
if Ovflo then
Rent := RE_Exp_Short_Integer;
else
Rent := RE_Exn_Short_Integer;
end if;
elsif Rtyp = Base_Type (Standard_Short_Short_Integer) then
if Ovflo then
Rent := RE_Exp_Short_Short_Integer;
else
Rent := RE_Exn_Short_Short_Integer;
end if;
elsif Rtyp = Base_Type (Standard_Long_Integer) then
if Ovflo then
Rent := RE_Exp_Long_Integer;
else
Rent := RE_Exn_Long_Integer;
end if;
elsif (Rtyp = Base_Type (Standard_Long_Long_Integer)
or else Rtyp = Universal_Integer)
then
if Ovflo then
Rent := RE_Exp_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Integer;
end if;
-- Floating-point cases
elsif Rtyp = Standard_Float then
if Ovflo then
Rent := RE_Exp_Float;
else
Rent := RE_Exn_Float;
end if;
elsif Rtyp = Standard_Short_Float then
if Ovflo then
Rent := RE_Exp_Short_Float;
else
Rent := RE_Exn_Short_Float;
end if;
elsif Rtyp = Standard_Long_Float then
if Ovflo then
Rent := RE_Exp_Long_Float;
else
Rent := RE_Exn_Long_Float;
end if;
else
pragma Assert
(Rtyp = Standard_Long_Long_Float or else Rtyp = Universal_Real);
if Ovflo then
Rent := RE_Exp_Long_Long_Float;
else
Rent := RE_Exn_Long_Long_Float;
end if;
end if;
-- Common processing for integer cases and floating-point cases.
-- If we are in the base type, we can call runtime routine directly
if Typ = Rtyp
and then Rtyp /= Universal_Integer
and then Rtyp /= Universal_Real
then
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Rent), Loc),
Parameter_Associations => New_List (Base, Exp)));
-- Otherwise we have to introduce conversions (conversions are also
-- required in the universal cases, since the runtime routine was
-- typed using the largest integer or real case.
else
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Rent), Loc),
Parameter_Associations => New_List (
Convert_To (Rtyp, Base),
Exp))));
end if;
Analyze_And_Resolve (N, Typ);
return;
end Expand_N_Op_Expon;
--------------------
-- Expand_N_Op_Ge --
--------------------
procedure Expand_N_Op_Ge (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Ge;
--------------------
-- Expand_N_Op_Gt --
--------------------
procedure Expand_N_Op_Gt (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Gt;
--------------------
-- Expand_N_Op_Le --
--------------------
procedure Expand_N_Op_Le (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Le;
--------------------
-- Expand_N_Op_Lt --
--------------------
procedure Expand_N_Op_Lt (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Lt;
-----------------------
-- Expand_N_Op_Minus --
-----------------------
procedure Expand_N_Op_Minus (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Unary_Op_Validity_Checks (N);
if Software_Overflow_Checking
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
then
-- Software overflow checking expands -expr into (0 - expr)
Rewrite (N,
Make_Op_Subtract (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 0),
Right_Opnd => Right_Opnd (N)));
Analyze_And_Resolve (N, Typ);
-- Vax floating-point types case
elsif Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Minus;
---------------------
-- Expand_N_Op_Mod --
---------------------
procedure Expand_N_Op_Mod (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
T : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
DOC : constant Boolean := Do_Overflow_Check (N);
DDC : constant Boolean := Do_Division_Check (N);
LLB : Uint;
Llo : Uint;
Lhi : Uint;
LOK : Boolean;
Rlo : Uint;
Rhi : Uint;
ROK : Boolean;
begin
Binary_Op_Validity_Checks (N);
Determine_Range (Right, ROK, Rlo, Rhi);
Determine_Range (Left, LOK, Llo, Lhi);
-- 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,
-- (the operation now corresponds to the hardware remainder), and it
-- does not seem likely that it could be harmful.
if LOK and then Llo >= 0
and then
ROK and then Rlo >= 0
then
Rewrite (N,
Make_Op_Rem (Sloc (N),
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N)));
-- Instead of reanalyzing the node we do the analysis manually.
-- This avoids anomalies when the replacement is done in an
-- instance and is epsilon more efficient.
Set_Entity (N, Standard_Entity (S_Op_Rem));
Set_Etype (N, T);
Set_Do_Overflow_Check (N, DOC);
Set_Do_Division_Check (N, DDC);
Expand_N_Op_Rem (N);
Set_Analyzed (N);
-- Otherwise, normal mod processing
else
if Is_Integer_Type (Etype (N)) then
Apply_Divide_Check (N);
end if;
-- Deal with annoying case of largest negative number remainder
-- minus one. Gigi does not handle this case correctly, because
-- it generates a divide instruction which may trap in this case.
-- In fact the check is quite easy, if the right operand is -1,
-- then the mod value is always 0, and we can just ignore the
-- left operand completely in this case.
LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then
((not LOK) or else (Llo = LLB))
then
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd =>
Make_Integer_Literal (Loc, -1)),
Make_Integer_Literal (Loc, Uint_0),
Relocate_Node (N))));
Set_Analyzed (Next (Next (First (Expressions (N)))));
Analyze_And_Resolve (N, T);
end if;
end if;
end Expand_N_Op_Mod;
--------------------------
-- Expand_N_Op_Multiply --
--------------------------
procedure Expand_N_Op_Multiply (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Lop : constant Node_Id := Left_Opnd (N);
Rop : constant Node_Id := Right_Opnd (N);
Ltyp : constant Entity_Id := Etype (Lop);
Rtyp : constant Entity_Id := Etype (Rop);
Typ : Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
-- Special optimizations for integer types
if Is_Integer_Type (Typ) then
-- N * 0 = 0 * N = 0 for integer types
if (Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_0)
or else
(Compile_Time_Known_Value (Left_Opnd (N))
and then Expr_Value (Left_Opnd (N)) = Uint_0)
then
Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- N * 1 = 1 * N = N for integer types
if Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_1
then
Rewrite (N, Left_Opnd (N));
return;
elsif Compile_Time_Known_Value (Left_Opnd (N))
and then Expr_Value (Left_Opnd (N)) = Uint_1
then
Rewrite (N, Right_Opnd (N));
return;
end if;
end if;
-- Deal with VAX float case
if Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if;
-- Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an integer, as required for this to work.
if Nkind (Rop) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Rop)
then
if Nkind (Lop) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Lop)
then
-- convert 2 ** A * 2 ** B into 2 ** (A + B)
Rewrite (N,
Make_Op_Expon (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 2),
Right_Opnd =>
Make_Op_Add (Loc,
Left_Opnd => Right_Opnd (Lop),
Right_Opnd => Right_Opnd (Rop))));
Analyze_And_Resolve (N, Typ);
return;
else
Rewrite (N,
Make_Op_Shift_Left (Loc,
Left_Opnd => Lop,
Right_Opnd =>
Convert_To (Standard_Natural, Right_Opnd (Rop))));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- Same processing for the operands the other way round
elsif Nkind (Lop) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Lop)
then
Rewrite (N,
Make_Op_Shift_Left (Loc,
Left_Opnd => Rop,
Right_Opnd =>
Convert_To (Standard_Natural, Right_Opnd (Lop))));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- Do required fixup of universal fixed operation
if Typ = Universal_Fixed then
Fixup_Universal_Fixed_Operation (N);
Typ := Etype (N);
end if;
-- Multiplications with fixed-point results
if Is_Fixed_Point_Type (Typ) then
-- No special processing if Treat_Fixed_As_Integer is set,
-- since from a semantic point of view such operations are
-- simply integer operations and will be treated that way.
if not Treat_Fixed_As_Integer (N) then
-- Case of fixed * integer => fixed
if Is_Integer_Type (Rtyp) then
Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
-- Case of integer * fixed => fixed
elsif Is_Integer_Type (Ltyp) then
Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
-- Case of fixed * fixed => fixed
else
Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
end if;
end if;
-- Other cases of multiplication of fixed-point operands. Again
-- we exclude the cases where Treat_Fixed_As_Integer flag is set.
elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
and then not Treat_Fixed_As_Integer (N)
then
if Is_Integer_Type (Typ) then
Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
else
pragma Assert (Is_Floating_Point_Type (Typ));
Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
end if;
-- Mixed-mode operations can appear in a non-static universal
-- context, in which case the integer argument must be converted
-- explicitly.
elsif Typ = Universal_Real
and then Is_Integer_Type (Rtyp)
then
Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
Analyze_And_Resolve (Rop, Universal_Real);
elsif Typ = Universal_Real
and then Is_Integer_Type (Ltyp)
then
Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
Analyze_And_Resolve (Lop, Universal_Real);
-- Non-fixed point cases, check software overflow checking required
elsif Is_Signed_Integer_Type (Etype (N)) then
Apply_Arithmetic_Overflow_Check (N);
end if;
end Expand_N_Op_Multiply;
--------------------
-- Expand_N_Op_Ne --
--------------------
-- Rewrite node as the negation of an equality operation, and reanalyze.
-- The equality to be used is defined in the same scope and has the same
-- signature. It must be set explicitly because in an instance it may not
-- have the same visibility as in the generic unit.
procedure Expand_N_Op_Ne (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Neg : Node_Id;
Ne : constant Entity_Id := Entity (N);
begin
Binary_Op_Validity_Checks (N);
Neg :=
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N)));
Set_Paren_Count (Right_Opnd (Neg), 1);
if Scope (Ne) /= Standard_Standard then
Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
end if;
Rewrite (N, Neg);
Analyze_And_Resolve (N, Standard_Boolean);
end Expand_N_Op_Ne;
---------------------
-- Expand_N_Op_Not --
---------------------
-- If the argument is other than a Boolean array type, there is no
-- special expansion required.
-- 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
-- routine generating a gruesome loop (it is so peculiar to have packed
-- arrays with non-standard Boolean representations anyway, so it does
-- not matter that we do not handle this case efficiently).
-- For the unpacked case (and for the special packed case where we have
-- non standard Booleans, as discussed above), we generate and insert
-- into the tree the following function definition:
-- function Nnnn (A : arr) is
-- B : arr;
-- begin
-- for J in a'range loop
-- B (J) := not A (J);
-- end loop;
-- return B;
-- end Nnnn;
-- Here arr is the actual subtype of the parameter (and hence always
-- constrained). Then we replace the not with a call to this function.
procedure Expand_N_Op_Not (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Opnd : Node_Id;
Arr : Entity_Id;
A : Entity_Id;
B : Entity_Id;
J : Entity_Id;
A_J : Node_Id;
B_J : Node_Id;
Func_Name : Entity_Id;
Loop_Statement : Node_Id;
begin
Unary_Op_Validity_Checks (N);
-- For boolean operand, deal with non-standard booleans
if Is_Boolean_Type (Typ) then
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
return;
end if;
-- Only array types need any other processing
if not Is_Array_Type (Typ) then
return;
end if;
-- Case of array operand. If bit packed, handle it in Exp_Pakd
if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
Expand_Packed_Not (N);
return;
end if;
-- Case of array operand which is not bit-packed
Opnd := Relocate_Node (Right_Opnd (N));
Convert_To_Actual_Subtype (Opnd);
Arr := Etype (Opnd);
Ensure_Defined (Arr, N);
A := Make_Defining_Identifier (Loc, Name_uA);
B := Make_Defining_Identifier (Loc, Name_uB);
J := Make_Defining_Identifier (Loc, Name_uJ);
A_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (A, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
B_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (B, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
Loop_Statement :=
Make_Implicit_Loop_Statement (N,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => J,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Chars (A)),
Attribute_Name => Name_Range))),
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => B_J,
Expression => Make_Op_Not (Loc, A_J))));
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
Set_Is_Inlined (Func_Name);
Insert_Action (N,
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc))),
Subtype_Mark => New_Reference_To (Typ, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => B,
Object_Definition => New_Reference_To (Arr, Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Loop_Statement,
Make_Return_Statement (Loc,
Expression =>
Make_Identifier (Loc, Chars (B)))))));
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => New_List (Opnd)));
Analyze_And_Resolve (N, Typ);
end Expand_N_Op_Not;
--------------------
-- Expand_N_Op_Or --
--------------------
procedure Expand_N_Op_Or (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Array_Type (Etype (N)) then
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_Or;
----------------------
-- Expand_N_Op_Plus --
----------------------
procedure Expand_N_Op_Plus (N : Node_Id) is
begin
Unary_Op_Validity_Checks (N);
end Expand_N_Op_Plus;
---------------------
-- Expand_N_Op_Rem --
---------------------
procedure Expand_N_Op_Rem (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
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;
Typ : Entity_Id;
begin
Binary_Op_Validity_Checks (N);
if Is_Integer_Type (Etype (N)) then
Apply_Divide_Check (N);
end if;
-- Deal with annoying case of largest negative number remainder
-- minus one. Gigi does not handle this case correctly, because
-- it generates a divide instruction which may trap in this case.
-- In fact the check is quite easy, if the right operand is -1,
-- then the remainder is always 0, and we can just ignore the
-- left operand completely in this case.
Determine_Range (Right, ROK, Rlo, Rhi);
Determine_Range (Left, LOK, Llo, Lhi);
LLB := Expr_Value (Type_Low_Bound (Base_Type (Etype (Left))));
Typ := Etype (N);
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then
((not LOK) or else (Llo = LLB))
then
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd =>
Make_Integer_Literal (Loc, -1)),
Make_Integer_Literal (Loc, Uint_0),
Relocate_Node (N))));
Set_Analyzed (Next (Next (First (Expressions (N)))));
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Op_Rem;
-----------------------------
-- Expand_N_Op_Rotate_Left --
-----------------------------
procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Rotate_Left;
------------------------------
-- Expand_N_Op_Rotate_Right --
------------------------------
procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Rotate_Right;
----------------------------
-- Expand_N_Op_Shift_Left --
----------------------------
procedure Expand_N_Op_Shift_Left (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Shift_Left;
-----------------------------
-- Expand_N_Op_Shift_Right --
-----------------------------
procedure Expand_N_Op_Shift_Right (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Shift_Right;
----------------------------------------
-- Expand_N_Op_Shift_Right_Arithmetic --
----------------------------------------
procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
begin
Binary_Op_Validity_Checks (N);
end Expand_N_Op_Shift_Right_Arithmetic;
--------------------------
-- Expand_N_Op_Subtract --
--------------------------
procedure Expand_N_Op_Subtract (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
-- N - 0 = N for integer types
if Is_Integer_Type (Typ)
and then Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = 0
then
Rewrite (N, Left_Opnd (N));
return;
end if;
-- Arithemtic overflow checks for signed integer/fixed point types
if Is_Signed_Integer_Type (Typ)
or else Is_Fixed_Point_Type (Typ)
then
Apply_Arithmetic_Overflow_Check (N);
-- Vax floating-point types case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Subtract;
---------------------
-- Expand_N_Op_Xor --
---------------------
procedure Expand_N_Op_Xor (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Array_Type (Etype (N)) then
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_Xor;
----------------------
-- 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);
-- Check for cases of left argument is True or False
elsif Nkind (Left) = N_Identifier 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 Entity (Left) = Standard_False then
if Present (Actions (N)) then
Insert_Actions (N, Actions (N));
end if;
Rewrite (N, Right);
Adjust_Result_Type (N, Typ);
return;
-- 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.
elsif Entity (Left) = Standard_True then
Kill_Dead_Code (Right);
Kill_Dead_Code (Actions (N));
Rewrite (N, New_Occurrence_Of (Standard_True, Loc));
Adjust_Result_Type (N, Typ);
return;
end if;
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 Nkind (Right) = N_Identifier 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 Entity (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.
elsif Entity (Right) = Standard_True then
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;
-----------------------------------
-- Expand_N_Qualified_Expression --
-----------------------------------
procedure Expand_N_Qualified_Expression (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
begin
Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
end Expand_N_Qualified_Expression;
---------------------------------
-- Expand_N_Selected_Component --
---------------------------------
-- If the selector is a discriminant of a concurrent object, rewrite the
-- prefix to denote the corresponding record type.
procedure Expand_N_Selected_Component (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Par : constant Node_Id := Parent (N);
P : constant Node_Id := Prefix (N);
Disc : Entity_Id;
Ptyp : Entity_Id := Underlying_Type (Etype (P));
New_N : Node_Id;
function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
-- Gigi needs a temporary for prefixes that depend on a discriminant,
-- unless the context of an assignment can provide size information.
function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
begin
return
(Nkind (Parent (Comp)) = N_Assignment_Statement
and then Comp = Name (Parent (Comp)))
or else
(Present (Parent (Comp))
and then Nkind (Parent (Comp)) in N_Subexpr
and then In_Left_Hand_Side (Parent (Comp)));
end In_Left_Hand_Side;
begin
if Do_Discriminant_Check (N) then
-- Present the discrminant checking function to the backend,
-- so that it can inline the call to the function.
Add_Inlined_Body
(Discriminant_Checking_Func
(Original_Record_Component (Entity (Selector_Name (N)))));
end if;
-- Insert explicit dereference call for the checked storage pool case
if Is_Access_Type (Ptyp) then
Insert_Dereference_Action (P);
return;
end if;
-- Gigi cannot handle unchecked conversions that are the prefix of
-- a selected component with discriminants. This must be checked
-- during expansion, because during analysis the type of the selector
-- is not known at the point the prefix is analyzed. If the conversion
-- is the target of an assignment, we cannot force the evaluation, of
-- course.
if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
and then Has_Discriminants (Etype (N))
and then not In_Left_Hand_Side (N)
then
Force_Evaluation (Prefix (N));
end if;
-- Remaining processing applies only if selector is a discriminant
if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
-- If the selector is a discriminant of a constrained record type,
-- rewrite the expression with the actual value of the discriminant.
-- Don't do this on the left hand of an assignment statement (this
-- happens in generated code, and means we really want to set it!)
-- We also only do this optimization for discrete types, and not
-- for access types (access discriminants get us into trouble!)
-- We also do not expand the prefix of an attribute or the
-- operand of an object renaming declaration.
if Is_Record_Type (Ptyp)
and then Has_Discriminants (Ptyp)
and then Is_Constrained (Ptyp)
and then Is_Discrete_Type (Etype (N))
and then (Nkind (Par) /= N_Assignment_Statement
or else Name (Par) /= N)
and then (Nkind (Par) /= N_Attribute_Reference
or else Prefix (Par) /= N)
and then not Is_Renamed_Object (N)
then
declare
D : Entity_Id;
E : Elmt_Id;
begin
D := First_Discriminant (Ptyp);
E := First_Elmt (Discriminant_Constraint (Ptyp));
while Present (E) loop
if D = Entity (Selector_Name (N)) then
-- In the context of a case statement, the expression
-- may have the base type of the discriminant, and we
-- need to preserve the constraint to avoid spurious
-- errors on missing cases.
if Nkind (Parent (N)) = N_Case_Statement
and then Etype (Node (E)) /= Etype (D)
then
Rewrite (N,
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (Etype (D), Loc),
Expression => New_Copy (Node (E))));
Analyze (N);
else
Rewrite (N, New_Copy (Node (E)));
end if;
Set_Is_Static_Expression (N, False);
return;
end if;
Next_Elmt (E);
Next_Discriminant (D);
end loop;
-- Note: the above loop should always terminate, but if
-- it does not, we just missed an optimization due to
-- some glitch (perhaps a previous error), so ignore!
end;
end if;
-- The only remaining processing is in the case of a discriminant of
-- a concurrent object, where we rewrite the prefix to denote the
-- corresponding record type. If the type is derived and has renamed
-- discriminants, use corresponding discriminant, which is the one
-- that appears in the corresponding record.
if not Is_Concurrent_Type (Ptyp) then
return;
end if;
Disc := Entity (Selector_Name (N));
if Is_Derived_Type (Ptyp)
and then Present (Corresponding_Discriminant (Disc))
then
Disc := Corresponding_Discriminant (Disc);
end if;
New_N :=
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
New_Copy_Tree (P)),
Selector_Name => Make_Identifier (Loc, Chars (Disc)));
Rewrite (N, New_N);
Analyze (N);
end if;
end Expand_N_Selected_Component;
--------------------
-- Expand_N_Slice --
--------------------
procedure Expand_N_Slice (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pfx : constant Node_Id := Prefix (N);
Ptp : Entity_Id := Etype (Pfx);
Ent : Entity_Id;
Decl : Node_Id;
begin
-- Special handling for access types
if Is_Access_Type (Ptp) then
-- Check for explicit dereference required for checked pool
Insert_Dereference_Action (Pfx);
-- If we have an access to a packed array type, then put in an
-- explicit dereference. We do this in case the slice must be
-- expanded, and we want to make sure we get an access check.
Ptp := Designated_Type (Ptp);
if Is_Array_Type (Ptp) and then Is_Packed (Ptp) then
Rewrite (Pfx,
Make_Explicit_Dereference (Sloc (N),
Prefix => Relocate_Node (Pfx)));
Analyze_And_Resolve (Pfx, Ptp);
-- The prefix will now carry the Access_Check flag for the back
-- end, remove it from slice itself.
Set_Do_Access_Check (N, False);
end if;
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
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:
-- 1. Right or left side of an assignment (we can handle this
-- situation correctly in the assignment statement expansion).
-- 2. Prefix of indexed component (the slide is optimized away
-- in this case, see the start of Expand_N_Slice.
-- 3. Object renaming declaration, since we want the name of
-- the slice, not the value.
-- 4. Argument to procedure call, since copy-in/copy-out handling
-- may be required, and this is handled in the expansion of
-- call itself.
-- 5. Prefix of an address attribute (this is an error which
-- is caught elsewhere, and the expansion would intefere
-- with generating the error message).
if Is_Packed (Typ)
and then Nkind (Parent (N)) /= N_Assignment_Statement
and then Nkind (Parent (N)) /= N_Indexed_Component
and then not Is_Renamed_Object (N)
and then Nkind (Parent (N)) /= N_Procedure_Call_Statement
and then (Nkind (Parent (N)) /= N_Attribute_Reference
or else
Attribute_Name (Parent (N)) /= Name_Address)
then
Ent :=
Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Ent,
Object_Definition => New_Occurrence_Of (Typ, Loc));
Set_No_Initialization (Decl);
Insert_Actions (N, New_List (
Decl,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Ent, Loc),
Expression => Relocate_Node (N))));
Rewrite (N, New_Occurrence_Of (Ent, Loc));
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Slice;
------------------------------
-- Expand_N_Type_Conversion --
------------------------------
procedure Expand_N_Type_Conversion (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Operand : constant Node_Id := Expression (N);
Target_Type : constant Entity_Id := Etype (N);
Operand_Type : Entity_Id := Etype (Operand);
procedure Handle_Changed_Representation;
-- This is called in the case of record and array type conversions
-- to see if there is a change of representation to be handled.
-- Change of representation is actually handled at the assignment
-- statement level, and what this procedure does is rewrite node N
-- conversion as an assignment to temporary. If there is no change
-- of representation, then the conversion node is unchanged.
procedure Real_Range_Check;
-- Handles generation of range check for real target value
-----------------------------------
-- Handle_Changed_Representation --
-----------------------------------
procedure Handle_Changed_Representation is
Temp : Entity_Id;
Decl : Node_Id;
Odef : Node_Id;
Disc : Node_Id;
N_Ix : Node_Id;
Cons : List_Id;
begin
-- Nothing to do if no change of representation
if Same_Representation (Operand_Type, Target_Type) then
return;
-- The real change of representation work is done by the assignment
-- statement processing. So if this type conversion is appearing as
-- the expression of an assignment statement, nothing needs to be
-- done to the conversion.
elsif Nkind (Parent (N)) = N_Assignment_Statement then
return;
-- Otherwise we need to generate a temporary variable, and do the
-- change of representation assignment into that temporary variable.
-- The conversion is then replaced by a reference to this variable.
else
Cons := No_List;
-- If type is unconstrained we have to add a constraint,
-- copied from the actual value of the left hand side.
if not Is_Constrained (Target_Type) then
if Has_Discriminants (Operand_Type) then
Disc := First_Discriminant (Operand_Type);
Cons := New_List;
while Present (Disc) loop
Append_To (Cons,
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Operand),
Selector_Name =>
Make_Identifier (Loc, Chars (Disc))));
Next_Discriminant (Disc);
end loop;
elsif Is_Array_Type (Operand_Type) then
N_Ix := First_Index (Target_Type);
Cons := New_List;
for J in 1 .. Number_Dimensions (Operand_Type) loop
-- We convert the bounds explicitly. We use an unchecked
-- conversion because bounds checks are done elsewhere.
Append_To (Cons,
Make_Range (Loc,
Low_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr
(Operand, Name_Req => True),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))),
High_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
Duplicate_Subexpr
(Operand, Name_Req => True),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J))))));
Next_Index (N_Ix);
end loop;
end if;
end if;
Odef := New_Occurrence_Of (Target_Type, Loc);
if Present (Cons) then
Odef :=
Make_Subtype_Indication (Loc,
Subtype_Mark => Odef,
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Cons));
end if;
Temp := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => Odef);
Set_No_Initialization (Decl, True);
-- Insert required actions. It is essential to suppress checks
-- since we have suppressed default initialization, which means
-- that the variable we create may have no discriminants.
Insert_Actions (N,
New_List (
Decl,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Temp, Loc),
Expression => Relocate_Node (N))),
Suppress => All_Checks);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
return;
end if;
end Handle_Changed_Representation;
----------------------
-- Real_Range_Check --
----------------------
-- Case of conversions to floating-point or fixed-point. If range
-- checks are enabled and the target type has a range constraint,
-- we convert:
-- typ (x)
-- to
-- Tnn : typ'Base := typ'Base (x);
-- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
-- Tnn
procedure Real_Range_Check is
Btyp : constant Entity_Id := Base_Type (Target_Type);
Lo : constant Node_Id := Type_Low_Bound (Target_Type);
Hi : constant Node_Id := Type_High_Bound (Target_Type);
Conv : Node_Id;
Tnn : Entity_Id;
begin
-- Nothing to do if conversion was rewritten
if Nkind (N) /= N_Type_Conversion then
return;
end if;
-- Nothing to do if range checks suppressed, or target has the
-- same range as the base type (or is the base type).
if Range_Checks_Suppressed (Target_Type)
or else (Lo = Type_Low_Bound (Btyp)
and then
Hi = Type_High_Bound (Btyp))
then
return;
end if;
-- Nothing to do if expression is an entity on which checks
-- have been suppressed.
if Is_Entity_Name (Expression (N))
and then Range_Checks_Suppressed (Entity (Expression (N)))
then
return;
end if;
-- Here we rewrite the conversion as described above
Conv := Relocate_Node (N);
Rewrite
(Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
Set_Etype (Conv, Btyp);
-- Skip overflow check for integer to float conversions,
-- since it is not needed, and in any case gigi generates
-- incorrect code for such overflow checks ???
if not Is_Integer_Type (Etype (Expression (N))) then
Set_Do_Overflow_Check (Conv, True);
end if;
Tnn :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Tnn,
Object_Definition => New_Occurrence_Of (Btyp, Loc),
Expression => Conv),
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd => New_Occurrence_Of (Tnn, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix =>
New_Occurrence_Of (Target_Type, Loc))),
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => New_Occurrence_Of (Tnn, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix =>
New_Occurrence_Of (Target_Type, Loc)))))));
Rewrite (N, New_Occurrence_Of (Tnn, Loc));
Analyze_And_Resolve (N, Btyp);
end Real_Range_Check;
-- Start of processing for Expand_N_Type_Conversion
begin
-- Nothing at all to do if conversion is to the identical type
-- so remove the conversion completely, it is useless.
if Operand_Type = Target_Type then
Rewrite (N, Relocate_Node (Expression (N)));
return;
end if;
-- Deal with Vax floating-point cases
if Vax_Float (Operand_Type) or else Vax_Float (Target_Type) then
Expand_Vax_Conversion (N);
return;
end if;
-- Nothing to do if this is the second argument of read. This
-- is a "backwards" conversion that will be handled by the
-- specialized code in attribute processing.
if Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Read
and then Next (First (Expressions (Parent (N)))) = N
then
return;
end if;
-- Here if we may need to expand conversion
-- Special case of converting from non-standard boolean type
if Is_Boolean_Type (Operand_Type)
and then (Nonzero_Is_True (Operand_Type))
then
Adjust_Condition (Operand);
Set_Etype (Operand, Standard_Boolean);
Operand_Type := Standard_Boolean;
end if;
-- Case of converting to an access type
if Is_Access_Type (Target_Type) then
-- Apply an accessibility check if the operand is an
-- access parameter. Note that other checks may still
-- need to be applied below (such as tagged type checks).
if Is_Entity_Name (Operand)
and then Ekind (Entity (Operand)) in Formal_Kind
and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
then
Apply_Accessibility_Check (Operand, Target_Type);
-- If the level of the operand type is statically deeper
-- then the level of the target type, then force Program_Error.
-- Note that this can only occur for cases where the attribute
-- is within the body of an instantiation (otherwise the
-- conversion will already have been rejected as illegal).
-- Note: warnings are issued by the analyzer for the instance
-- cases.
elsif In_Instance_Body
and then Type_Access_Level (Operand_Type)
> Type_Access_Level (Target_Type)
then
Rewrite (N, Make_Raise_Program_Error (Sloc (N)));
Set_Etype (N, Target_Type);
-- When the operand is a selected access discriminant
-- the check needs to be made against the level of the
-- object denoted by the prefix of the selected name.
-- Force Program_Error for this case as well (this
-- accessibility violation can only happen if within
-- the body of an instantiation).
elsif In_Instance_Body
and then Ekind (Operand_Type) = E_Anonymous_Access_Type
and then Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type)
then
Rewrite (N, Make_Raise_Program_Error (Sloc (N)));
Set_Etype (N, Target_Type);
end if;
end if;
-- Case of conversions of tagged types and access to tagged types
-- When needed, that is to say when the expression is class-wide,
-- Add runtime a tag check for (strict) downward conversion by using
-- the membership test, generating:
-- [constraint_error when Operand not in Target_Type'Class]
-- or in the access type case
-- [constraint_error
-- when Operand /= null
-- and then Operand.all not in
-- Designated_Type (Target_Type)'Class]
if (Is_Access_Type (Target_Type)
and then Is_Tagged_Type (Designated_Type (Target_Type)))
or else Is_Tagged_Type (Target_Type)
then
-- Do not do any expansion in the access type case if the
-- parent is a renaming, since this is an error situation
-- which will be caught by Sem_Ch8, and the expansion can
-- intefere with this error check.
if Is_Access_Type (Target_Type)
and then Is_Renamed_Object (N)
then
return;
end if;
-- Oherwise, proceed with processing tagged conversion
declare
Actual_Operand_Type : Entity_Id;
Actual_Target_Type : Entity_Id;
Cond : Node_Id;
begin
if Is_Access_Type (Target_Type) then
Actual_Operand_Type := Designated_Type (Operand_Type);
Actual_Target_Type := Designated_Type (Target_Type);
else
Actual_Operand_Type := Operand_Type;
Actual_Target_Type := Target_Type;
end if;
if Is_Class_Wide_Type (Actual_Operand_Type)
and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type
and then Is_Ancestor
(Root_Type (Actual_Operand_Type),
Actual_Target_Type)
and then not Tag_Checks_Suppressed (Actual_Target_Type)
then
-- The conversion is valid for any descendant of the
-- target type
Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
if Is_Access_Type (Target_Type) then
Cond :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
Left_Opnd => Duplicate_Subexpr (Operand),
Right_Opnd => Make_Null (Loc)),
Right_Opnd =>
Make_Not_In (Loc,
Left_Opnd =>
Make_Explicit_Dereference (Loc,
Prefix => Duplicate_Subexpr (Operand)),
Right_Opnd =>
New_Reference_To (Actual_Target_Type, Loc)));
else
Cond :=
Make_Not_In (Loc,
Left_Opnd => Duplicate_Subexpr (Operand),
Right_Opnd =>
New_Reference_To (Actual_Target_Type, Loc));
end if;
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition => Cond));
Change_Conversion_To_Unchecked (N);
Analyze_And_Resolve (N, Target_Type);
end if;
end;
-- Case of other access type conversions
elsif Is_Access_Type (Target_Type) then
Apply_Constraint_Check (Operand, Target_Type);
-- Case of conversions from a fixed-point type
-- These conversions require special expansion and processing, found
-- in the Exp_Fixd package. We ignore cases where Conversion_OK is
-- set, since from a semantic point of view, these are simple integer
-- conversions, which do not need further processing.
elsif Is_Fixed_Point_Type (Operand_Type)
and then not Conversion_OK (N)
then
-- We should never see universal fixed at this case, since the
-- expansion of the constituent divide or multiply should have
-- eliminated the explicit mention of universal fixed.
pragma Assert (Operand_Type /= Universal_Fixed);
-- Check for special case of the conversion to universal real
-- that occurs as a result of the use of a round attribute.
-- In this case, the real type for the conversion is taken
-- from the target type of the Round attribute and the
-- result must be marked as rounded.
if Target_Type = Universal_Real
and then Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Round
then
Set_Rounded_Result (N);
Set_Etype (N, Etype (Parent (N)));
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)
if not Conversion_OK (N) then
if Is_Fixed_Point_Type (Etype (N)) then
Expand_Convert_Fixed_To_Fixed (N);
Real_Range_Check;
elsif Is_Integer_Type (Etype (N)) then
Expand_Convert_Fixed_To_Integer (N);
else
pragma Assert (Is_Floating_Point_Type (Etype (N)));
Expand_Convert_Fixed_To_Float (N);
Real_Range_Check;
end if;
end if;
-- Case of conversions to a fixed-point type
-- These conversions require special expansion and processing, found
-- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
-- is set, since from a semantic point of view, these are simple
-- integer conversions, which do not need further processing.
elsif Is_Fixed_Point_Type (Target_Type)
and then not Conversion_OK (N)
then
if Is_Integer_Type (Operand_Type) then
Expand_Convert_Integer_To_Fixed (N);
Real_Range_Check;
else
pragma Assert (Is_Floating_Point_Type (Operand_Type));
Expand_Convert_Float_To_Fixed (N);
Real_Range_Check;
end if;
-- Case of float-to-integer conversions
-- We also handle float-to-fixed conversions with Conversion_OK set
-- since semantically the fixed-point target is treated as though it
-- were an integer in such cases.
elsif Is_Floating_Point_Type (Operand_Type)
and then
(Is_Integer_Type (Target_Type)
or else
(Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
then
-- Special processing required if the conversion is the expression
-- of a Truncation attribute reference. In this case we replace:
-- ityp (ftyp'Truncation (x))
-- by
-- ityp (x)
-- with the Float_Truncate flag set. This is clearly more efficient.
if Nkind (Operand) = N_Attribute_Reference
and then Attribute_Name (Operand) = Name_Truncation
then
Rewrite (Operand,
Relocate_Node (First (Expressions (Operand))));
Set_Float_Truncate (N, True);
end if;
-- One more check here, gcc is still not able to do conversions of
-- this type with proper overflow checking, and so gigi is doing an
-- approximation of what is required by doing floating-point compares
-- with the end-point. But that can lose precision in some cases, and
-- give a wrong result. Converting the operand to Long_Long_Float is
-- helpful, but still does not catch all cases with 64-bit integers
-- on targets with only 64-bit floats ???
if Do_Range_Check (Expression (N)) then
Rewrite (Expression (N),
Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Standard_Long_Long_Float, Loc),
Expression =>
Relocate_Node (Expression (N))));
Set_Etype (Expression (N), Standard_Long_Long_Float);
Enable_Range_Check (Expression (N));
Set_Do_Range_Check (Expression (Expression (N)), False);
end if;
-- Case of array conversions
-- Expansion of array conversions, add required length/range checks
-- but only do this if there is no change of representation. For
-- handling of this case, see Handle_Changed_Representation.
elsif Is_Array_Type (Target_Type) then
if Is_Constrained (Target_Type) then
Apply_Length_Check (Operand, Target_Type);
else
Apply_Range_Check (Operand, Target_Type);
end if;
Handle_Changed_Representation;
-- Case of conversions of discriminated types
-- Add required discriminant checks if target is constrained. Again
-- this change is skipped if we have a change of representation.
elsif Has_Discriminants (Target_Type)
and then Is_Constrained (Target_Type)
then
Apply_Discriminant_Check (Operand, Target_Type);
Handle_Changed_Representation;
-- Case of all other record conversions. The only processing required
-- is to check for a change of representation requiring the special
-- assignment processing.
elsif Is_Record_Type (Target_Type) then
Handle_Changed_Representation;
-- Case of conversions of enumeration types
elsif Is_Enumeration_Type (Target_Type) then
-- Special processing is required if there is a change of
-- representation (from enumeration representation clauses)
if not Same_Representation (Target_Type, Operand_Type) then
-- Convert: x(y) to x'val (ytyp'val (y))
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Target_Type, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Operand_Type, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (Operand)))));
Analyze_And_Resolve (N, Target_Type);
end if;
-- Case of conversions to floating-point
elsif Is_Floating_Point_Type (Target_Type) then
Real_Range_Check;
-- The remaining cases require no front end processing
else
null;
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:
-- Conversions with no change of representation or type
-- Numeric conversions involving integer values, floating-point
-- values, and fixed-point values. Fixed-point values are allowed
-- only if Conversion_OK is set, i.e. if the fixed-point values
-- are to be treated as integers.
-- No other conversions should be passed to Gigi.
end Expand_N_Type_Conversion;
-----------------------------------
-- Expand_N_Unchecked_Expression --
-----------------------------------
-- Remove the unchecked expression node from the tree. It's 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.
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));
Rewrite (N, Exp);
end Expand_N_Unchecked_Expression;
----------------------------------------
-- Expand_N_Unchecked_Type_Conversion --
----------------------------------------
-- If this cannot be handled by Gigi and we haven't already made
-- a temporary for it, do it now.
procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
Target_Type : constant Entity_Id := Etype (N);
Operand : constant Node_Id := Expression (N);
Operand_Type : constant Entity_Id := Etype (Operand);
begin
-- 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
-- only apply this to integer types being converted. Possibly it may
-- apply in other cases, but it is too much trouble to worry about.
-- Note that we do not do this transformation if the Kill_Range_Check
-- flag is set, since then the value may be outside the expected range.
-- This happens in the Normalize_Scalars case.
if Is_Integer_Type (Target_Type)
and then Is_Integer_Type (Operand_Type)
and then Compile_Time_Known_Value (Operand)
and then not Kill_Range_Check (N)
then
declare
Val : constant Uint := Expr_Value (Operand);
begin
if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
and then
Compile_Time_Known_Value (Type_High_Bound (Target_Type))
and then
Val >= Expr_Value (Type_Low_Bound (Target_Type))
and then
Val <= Expr_Value (Type_High_Bound (Target_Type))
then
Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
Analyze_And_Resolve (N, Target_Type);
return;
end if;
end;
end if;
-- Nothing to do if conversion is safe
if Safe_Unchecked_Type_Conversion (N) then
return;
end if;
-- Otherwise force evaluation unless Assignment_OK flag is set (this
-- flag indicates ??? -- more comments needed here)
if Assignment_OK (N) then
null;
else
Force_Evaluation (N);
end if;
end Expand_N_Unchecked_Type_Conversion;
----------------------------
-- Expand_Record_Equality --
----------------------------
-- For non-variant records, Equality is expanded when needed into:
-- and then Lhs.Discr1 = Rhs.Discr1
-- and then ...
-- and then Lhs.Discrn = Rhs.Discrn
-- and then Lhs.Cmp1 = Rhs.Cmp1
-- and then ...
-- and then Lhs.Cmpn = Rhs.Cmpn
-- The expression is folded by the back-end for adjacent fields. This
-- function is called for tagged record in only one occasion: for imple-
-- menting predefined primitive equality (see Predefined_Primitives_Bodies)
-- otherwise the primitive "=" is used directly.
function Expand_Record_Equality
(Nod : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
function Suitable_Element (C : Entity_Id) return Entity_Id;
-- Return the first field to compare beginning with C, skipping the
-- inherited components
function Suitable_Element (C : Entity_Id) return Entity_Id is
begin
if No (C) then
return Empty;
elsif Ekind (C) /= E_Discriminant
and then Ekind (C) /= E_Component
then
return Suitable_Element (Next_Entity (C));
elsif Is_Tagged_Type (Typ)
and then C /= Original_Record_Component (C)
then
return Suitable_Element (Next_Entity (C));
elsif Chars (C) = Name_uController
or else Chars (C) = Name_uTag
then
return Suitable_Element (Next_Entity (C));
else
return C;
end if;
end Suitable_Element;
Result : Node_Id;
C : Entity_Id;
First_Time : Boolean := True;
-- Start of processing for Expand_Record_Equality
begin
-- Special processing for the unchecked union case, which will occur
-- only in the context of tagged types and dynamic dispatching, since
-- other cases are handled statically. We return True, but insert a
-- raise Program_Error statement.
if Is_Unchecked_Union (Typ) then
-- If this is a component of an enclosing record, return the Raise
-- statement directly.
if No (Parent (Lhs)) then
Result := Make_Raise_Program_Error (Loc);
Set_Etype (Result, Standard_Boolean);
return Result;
else
Insert_Action (Lhs,
Make_Raise_Program_Error (Loc));
return New_Occurrence_Of (Standard_True, Loc);
end if;
end if;
-- Generates the following code: (assuming that Typ has one Discr and
-- component C2 is also a record)
-- True
-- and then Lhs.Discr1 = Rhs.Discr1
-- and then Lhs.C1 = Rhs.C1
-- and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
-- and then ...
-- and then Lhs.Cmpn = Rhs.Cmpn
Result := New_Reference_To (Standard_True, Loc);
C := Suitable_Element (First_Entity (Typ));
while Present (C) loop
declare
New_Lhs : Node_Id;
New_Rhs : Node_Id;
begin
if First_Time then
First_Time := False;
New_Lhs := Lhs;
New_Rhs := Rhs;
else
New_Lhs := New_Copy_Tree (Lhs);
New_Rhs := New_Copy_Tree (Rhs);
end if;
Result :=
Make_And_Then (Loc,
Left_Opnd => Result,
Right_Opnd =>
Expand_Composite_Equality (Nod, Etype (C),
Lhs =>
Make_Selected_Component (Loc,
Prefix => New_Lhs,
Selector_Name => New_Reference_To (C, Loc)),
Rhs =>
Make_Selected_Component (Loc,
Prefix => New_Rhs,
Selector_Name => New_Reference_To (C, Loc)),
Bodies => Bodies));
end;
C := Suitable_Element (Next_Entity (C));
end loop;
return Result;
end Expand_Record_Equality;
-------------------------------------
-- Fixup_Universal_Fixed_Operation --
-------------------------------------
procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
Conv : constant Node_Id := Parent (N);
begin
-- We must have a type conversion immediately above us
pragma Assert (Nkind (Conv) = N_Type_Conversion);
-- Normally the type conversion gives our target type. The exception
-- occurs in the case of the Round attribute, where the conversion
-- will be to universal real, and our real type comes from the Round
-- attribute (as well as an indication that we must round the result)
if Nkind (Parent (Conv)) = N_Attribute_Reference
and then Attribute_Name (Parent (Conv)) = Name_Round
then
Set_Etype (N, Etype (Parent (Conv)));
Set_Rounded_Result (N);
-- Normal case where type comes from conversion above us
else
Set_Etype (N, Etype (Conv));
end if;
end Fixup_Universal_Fixed_Operation;
-------------------------------
-- Insert_Dereference_Action --
-------------------------------
procedure Insert_Dereference_Action (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Pool : constant Entity_Id := Associated_Storage_Pool (Typ);
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
-- return true if type of P is derived from Checked_Pool;
function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
T : Entity_Id;
begin
if No (P) then
return False;
end if;
T := Etype (P);
while T /= Etype (T) loop
if Is_RTE (T, RE_Checked_Pool) then
return True;
else
T := Etype (T);
end if;
end loop;
return False;
end Is_Checked_Storage_Pool;
-- Start of processing for Insert_Dereference_Action
begin
if not Comes_From_Source (Parent (N)) then
return;
elsif not Is_Checked_Storage_Pool (Pool) then
return;
end if;
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (
Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
Parameter_Associations => New_List (
-- Pool
New_Reference_To (Pool, Loc),
-- Storage_Address
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
Attribute_Name => Name_Address),
-- Size_In_Storage_Elements
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
Attribute_Name => Name_Size),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit)),
-- Alignment
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc, Duplicate_Subexpr (N)),
Attribute_Name => Name_Alignment))));
end Insert_Dereference_Action;
------------------------------
-- Make_Array_Comparison_Op --
------------------------------
-- This is a hand-coded expansion of the following generic function:
-- generic
-- type elem is (<>);
-- type index is (<>);
-- type a is array (index range <>) of elem;
--
-- function Gnnn (X : a; Y: a) return boolean is
-- J : index := Y'first;
--
-- begin
-- if X'length = 0 then
-- return false;
--
-- elsif Y'length = 0 then
-- return true;
--
-- else
-- for I in X'range loop
-- if X (I) = Y (J) then
-- if J = Y'last then
-- exit;
-- else
-- J := index'succ (J);
-- end if;
--
-- else
-- return X (I) > Y (J);
-- end if;
-- end loop;
--
-- return X'length > Y'length;
-- end if;
-- end Gnnn;
-- Note that since we are essentially doing this expansion by hand, we
-- do not need to generate an actual or formal generic part, just the
-- instantiated function itself.
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
Loop_Statement : Node_Id;
Loop_Body : Node_Id;
If_Stat : Node_Id;
Inner_If : Node_Id;
Final_Expr : Node_Id;
Func_Body : Node_Id;
Func_Name : Entity_Id;
Formals : List_Id;
Length1 : Node_Id;
Length2 : Node_Id;
begin
-- if J = Y'last then
-- exit;
-- else
-- J := index'succ (J);
-- end if;
Inner_If :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Reference_To (J, Loc),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_Last)),
Then_Statements => New_List (
Make_Exit_Statement (Loc)),
Else_Statements =>
New_List (
Make_Assignment_Statement (Loc,
Name => New_Reference_To (J, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Index, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (New_Reference_To (J, Loc))))));
-- if X (I) = Y (J) then
-- if ... end if;
-- else
-- return X (I) > Y (J);
-- end if;
Loop_Body :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (X, Loc),
Expressions => New_List (New_Reference_To (I, Loc))),
Right_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (Y, Loc),
Expressions => New_List (New_Reference_To (J, Loc)))),
Then_Statements => New_List (Inner_If),
Else_Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Op_Gt (Loc,
Left_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (X, Loc),
Expressions => New_List (New_Reference_To (I, Loc))),
Right_Opnd =>
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (Y, Loc),
Expressions => New_List (
New_Reference_To (J, Loc)))))));
-- for I in X'range loop
-- if ... end if;
-- end loop;
Loop_Statement :=
Make_Implicit_Loop_Statement (Nod,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => I,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (X, Loc),
Attribute_Name => Name_Range))),
Statements => New_List (Loop_Body));
-- if X'length = 0 then
-- return false;
-- elsif Y'length = 0 then
-- return true;
-- else
-- for ... loop ... end loop;
-- return X'length > Y'length;
-- end if;
Length1 :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (X, Loc),
Attribute_Name => Name_Length);
Length2 :=
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_Length);
Final_Expr :=
Make_Op_Gt (Loc,
Left_Opnd => Length1,
Right_Opnd => Length2);
If_Stat :=
Make_Implicit_If_Statement (Nod,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (X, Loc),
Attribute_Name => Name_Length),
Right_Opnd =>
Make_Integer_Literal (Loc, 0)),
Then_Statements =>
New_List (
Make_Return_Statement (Loc,
Expression => New_Reference_To (Standard_False, Loc))),
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_Length),
Right_Opnd =>
Make_Integer_Literal (Loc, 0)),
Then_Statements =>
New_List (
Make_Return_Statement (Loc,
Expression => New_Reference_To (Standard_True, Loc))))),
Else_Statements => New_List (
Loop_Statement,
Make_Return_Statement (Loc,
Expression => Final_Expr)));
-- (X : a; Y: a)
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => X,
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Y,
Parameter_Type => New_Reference_To (Typ, Loc)));
-- function Gnnn (...) return boolean is
-- J : index := Y'first;
-- begin
-- if ... end if;
-- end Gnnn;
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => J,
Object_Definition => New_Reference_To (Index, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Y, Loc),
Attribute_Name => Name_First))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (If_Stat)));
return Func_Body;
end Make_Array_Comparison_Op;
---------------------------
-- Make_Boolean_Array_Op --
---------------------------
-- For logical operations on boolean arrays, expand in line the
-- following, replacing 'and' with 'or' or 'xor' where needed:
-- function Annn (A : typ; B: typ) return typ is
-- C : typ;
-- begin
-- for J in A'range loop
-- C (J) := A (J) op B (J);
-- end loop;
-- return C;
-- end Annn;
-- Here typ is the boolean array type
function Make_Boolean_Array_Op
(Typ : Entity_Id;
N : Node_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
A_J : Node_Id;
B_J : Node_Id;
C_J : Node_Id;
Op : Node_Id;
Formals : List_Id;
Func_Name : Entity_Id;
Func_Body : Node_Id;
Loop_Statement : Node_Id;
begin
A_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (A, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
B_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (B, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
C_J :=
Make_Indexed_Component (Loc,
Prefix => New_Reference_To (C, Loc),
Expressions => New_List (New_Reference_To (J, Loc)));
if Nkind (N) = N_Op_And then
Op :=
Make_Op_And (Loc,
Left_Opnd => A_J,
Right_Opnd => B_J);
elsif Nkind (N) = N_Op_Or then
Op :=
Make_Op_Or (Loc,
Left_Opnd => A_J,
Right_Opnd => B_J);
else
Op :=
Make_Op_Xor (Loc,
Left_Opnd => A_J,
Right_Opnd => B_J);
end if;
Loop_Statement :=
Make_Implicit_Loop_Statement (N,
Identifier => Empty,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => J,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (A, Loc),
Attribute_Name => Name_Range))),
Statements => New_List (
Make_Assignment_Statement (Loc,
Name => C_J,
Expression => Op)));
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Typ, Loc)));
Func_Name :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Set_Is_Inlined (Func_Name);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Typ, Loc)),
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => C,
Object_Definition => New_Reference_To (Typ, Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Loop_Statement,
Make_Return_Statement (Loc,
Expression => New_Reference_To (C, Loc)))));
return Func_Body;
end Make_Boolean_Array_Op;
------------------------
-- Rewrite_Comparison --
------------------------
procedure Rewrite_Comparison (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2);
-- Res indicates if compare outcome can be determined at compile time
True_Result : Boolean;
False_Result : Boolean;
begin
case N_Op_Compare (Nkind (N)) is
when N_Op_Eq =>
True_Result := Res = EQ;
False_Result := Res = LT or else Res = GT or else Res = NE;
when N_Op_Ge =>
True_Result := Res in Compare_GE;
False_Result := Res = LT;
when N_Op_Gt =>
True_Result := Res = GT;
False_Result := Res in Compare_LE;
when N_Op_Lt =>
True_Result := Res = LT;
False_Result := Res in Compare_GE;
when N_Op_Le =>
True_Result := Res in Compare_LE;
False_Result := Res = GT;
when N_Op_Ne =>
True_Result := Res = NE;
False_Result := Res = LT or else Res = GT or else Res = EQ;
end case;
if True_Result then
Rewrite (N,
Convert_To (Typ, New_Occurrence_Of (Standard_True, Sloc (N))));
Analyze_And_Resolve (N, Typ);
elsif False_Result then
Rewrite (N,
Convert_To (Typ, New_Occurrence_Of (Standard_False, Sloc (N))));
Analyze_And_Resolve (N, Typ);
end if;
end Rewrite_Comparison;
-----------------------
-- Tagged_Membership --
-----------------------
-- There are two different cases to consider depending on whether
-- the right operand is a class-wide type or not. If not we just
-- compare the actual tag of the left expr to the target type tag:
--
-- Left_Expr.Tag = Right_Type'Tag;
--
-- If it is a class-wide type we use the RT function CW_Membership which
-- is usually implemented by looking in the ancestor tables contained in
-- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
function Tagged_Membership (N : Node_Id) return 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;
Right_Type : Entity_Id;
Obj_Tag : Node_Id;
begin
Left_Type := Etype (Left);
Right_Type := Etype (Right);
if Is_Class_Wide_Type (Left_Type) then
Left_Type := Root_Type (Left_Type);
end if;
Obj_Tag :=
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Left),
Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
if Is_Class_Wide_Type (Right_Type) then
return
Make_DT_Access_Action (Left_Type,
Action => CW_Membership,
Args => New_List (
Obj_Tag,
New_Reference_To (
Access_Disp_Table (Root_Type (Right_Type)), Loc)));
else
return
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>
New_Reference_To (Access_Disp_Table (Right_Type), Loc));
end if;
end Tagged_Membership;
------------------------------
-- Unary_Op_Validity_Checks --
------------------------------
procedure Unary_Op_Validity_Checks (N : Node_Id) is
begin
if Validity_Checks_On and Validity_Check_Operands then
Ensure_Valid (Right_Opnd (N));
end if;
end Unary_Op_Validity_Checks;
end Exp_Ch4;