| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |