| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- E X P _ C H 4 -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2006, 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, 51 Franklin Street, Fifth Floor, -- |
| -- Boston, MA 02110-1301, USA. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| 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_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 Freeze; use Freeze; |
| 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_Ch3; use Sem_Ch3; |
| 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 Sem_Warn; use Sem_Warn; |
| with Sinfo; use Sinfo; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Targparm; use Targparm; |
| 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 Build_Boolean_Array_Proc_Call |
| (N : Node_Id; |
| Op1 : Node_Id; |
| Op2 : Node_Id); |
| -- If an boolean array assignment can be done in place, build call to |
| -- corresponding library procedure. |
| |
| procedure Expand_Allocator_Expression (N : Node_Id); |
| -- Subsidiary to Expand_N_Allocator, for the case when the expression |
| -- is a qualified expression or an aggregate. |
| |
| 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. Special processing (call a |
| -- run-time routine) |
| |
| function Expand_Array_Equality |
| (Nod : Node_Id; |
| Lhs : Node_Id; |
| Rhs : Node_Id; |
| Bodies : List_Id; |
| Typ : Entity_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. Lhs and Rhs are the array expressions to be compared. |
| -- Bodies is a list on which to attach bodies of local functions that |
| -- are created in the process. It is the responsibility of the |
| -- caller to insert those bodies at the right place. Nod provides |
| -- the Sloc value for the generated code. Normally the types used |
| -- for the generated equality routine are taken from Lhs and Rhs. |
| -- However, in some situations of generated code, the Etype fields |
| -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the |
| -- type to be used for the formal parameters. |
| |
| 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. Lhs and Rhs are the left and right sides |
| -- for the comparison, and Typ is the type of the arrays to compare. |
| |
| 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. |
| |
| function Get_Allocator_Final_List |
| (N : Node_Id; |
| T : Entity_Id; |
| PtrT : Entity_Id) return Entity_Id; |
| -- If the designated type is controlled, build final_list expression |
| -- for created object. If context is an access parameter, create a |
| -- local access type to have a usable finalization list. |
| |
| function Has_Inferable_Discriminants (N : Node_Id) return Boolean; |
| -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable |
| -- discriminants if it has a constrained nominal type, unless the object |
| -- is a component of an enclosing Unchecked_Union object that is subject |
| -- to a per-object constraint and the enclosing object lacks inferable |
| -- discriminants. |
| -- |
| -- An expression of an Unchecked_Union type has inferable discriminants |
| -- if it is either a name of an object with inferable discriminants or a |
| -- qualified expression whose subtype mark denotes a constrained subtype. |
| |
| procedure Insert_Dereference_Action (N : Node_Id); |
| -- N is an expression whose type is an access. When the type of the |
| -- associated storage pool is derived from Checked_Pool, generate a |
| -- call to the 'Dereference' primitive operation. |
| |
| 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); |
| -- if N is the node for a comparison whose outcome 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. If N is a type conversion, then this processing is applied to |
| -- its expression. If N is neither comparison nor a type conversion, the |
| -- call has no effect. |
| |
| function Tagged_Membership (N : Node_Id) return Node_Id; |
| -- Construct the expression corresponding to the tagged membership test. |
| -- Deals with a second operand being (or not) a class-wide type. |
| |
| function Safe_In_Place_Array_Op |
| (Lhs : Node_Id; |
| Op1 : Node_Id; |
| Op2 : Node_Id) return Boolean; |
| -- In the context of an assignment, where the right-hand side is a |
| -- boolean operation on arrays, check whether operation can be performed |
| -- in place. |
| |
| 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; |
| |
| ------------------------------------ |
| -- Build_Boolean_Array_Proc_Call -- |
| ------------------------------------ |
| |
| procedure Build_Boolean_Array_Proc_Call |
| (N : Node_Id; |
| Op1 : Node_Id; |
| Op2 : Node_Id) |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| Kind : constant Node_Kind := Nkind (Expression (N)); |
| Target : constant Node_Id := |
| Make_Attribute_Reference (Loc, |
| Prefix => Name (N), |
| Attribute_Name => Name_Address); |
| |
| Arg1 : constant Node_Id := Op1; |
| Arg2 : Node_Id := Op2; |
| Call_Node : Node_Id; |
| Proc_Name : Entity_Id; |
| |
| begin |
| if Kind = N_Op_Not then |
| if Nkind (Op1) in N_Binary_Op then |
| |
| -- Use negated version of the binary operators |
| |
| if Nkind (Op1) = N_Op_And then |
| Proc_Name := RTE (RE_Vector_Nand); |
| |
| elsif Nkind (Op1) = N_Op_Or then |
| Proc_Name := RTE (RE_Vector_Nor); |
| |
| else pragma Assert (Nkind (Op1) = N_Op_Xor); |
| Proc_Name := RTE (RE_Vector_Xor); |
| end if; |
| |
| Call_Node := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc_Name, Loc), |
| |
| Parameter_Associations => New_List ( |
| Target, |
| Make_Attribute_Reference (Loc, |
| Prefix => Left_Opnd (Op1), |
| Attribute_Name => Name_Address), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Right_Opnd (Op1), |
| Attribute_Name => Name_Address), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Left_Opnd (Op1), |
| Attribute_Name => Name_Length))); |
| |
| else |
| Proc_Name := RTE (RE_Vector_Not); |
| |
| Call_Node := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc_Name, Loc), |
| Parameter_Associations => New_List ( |
| Target, |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Op1, |
| Attribute_Name => Name_Address), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Op1, |
| Attribute_Name => Name_Length))); |
| end if; |
| |
| else |
| -- We use the following equivalences: |
| |
| -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) |
| -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) |
| -- (not X) xor (not Y) = X xor Y |
| -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) |
| |
| if Nkind (Op1) = N_Op_Not then |
| if Kind = N_Op_And then |
| Proc_Name := RTE (RE_Vector_Nor); |
| |
| elsif Kind = N_Op_Or then |
| Proc_Name := RTE (RE_Vector_Nand); |
| |
| else |
| Proc_Name := RTE (RE_Vector_Xor); |
| end if; |
| |
| else |
| if Kind = N_Op_And then |
| Proc_Name := RTE (RE_Vector_And); |
| |
| elsif Kind = N_Op_Or then |
| Proc_Name := RTE (RE_Vector_Or); |
| |
| elsif Nkind (Op2) = N_Op_Not then |
| Proc_Name := RTE (RE_Vector_Nxor); |
| Arg2 := Right_Opnd (Op2); |
| |
| else |
| Proc_Name := RTE (RE_Vector_Xor); |
| end if; |
| end if; |
| |
| Call_Node := |
| Make_Procedure_Call_Statement (Loc, |
| Name => New_Occurrence_Of (Proc_Name, Loc), |
| Parameter_Associations => New_List ( |
| Target, |
| Make_Attribute_Reference (Loc, |
| Prefix => Arg1, |
| Attribute_Name => Name_Address), |
| Make_Attribute_Reference (Loc, |
| Prefix => Arg2, |
| Attribute_Name => Name_Address), |
| Make_Attribute_Reference (Loc, |
| Prefix => Op1, |
| Attribute_Name => Name_Length))); |
| end if; |
| |
| Rewrite (N, Call_Node); |
| Analyze (N); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Build_Boolean_Array_Proc_Call; |
| |
| --------------------------------- |
| -- Expand_Allocator_Expression -- |
| --------------------------------- |
| |
| procedure Expand_Allocator_Expression (N : Node_Id) is |
| Loc : constant Source_Ptr := Sloc (N); |
| Exp : constant Node_Id := Expression (Expression (N)); |
| Indic : constant Node_Id := Subtype_Mark (Expression (N)); |
| PtrT : constant Entity_Id := Etype (N); |
| DesigT : constant Entity_Id := Designated_Type (PtrT); |
| T : constant Entity_Id := Entity (Indic); |
| Flist : Node_Id; |
| Node : Node_Id; |
| Temp : Entity_Id; |
| |
| TagT : Entity_Id := Empty; |
| -- Type used as source for tag assignment |
| |
| TagR : Node_Id := Empty; |
| -- Target reference for tag assignment |
| |
| 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_Comes_From_Source |
| (Expression (Tmp_Node), Comes_From_Source (N)); |
| |
| Set_No_Initialization (Expression (Tmp_Node)); |
| Insert_Action (N, Tmp_Node); |
| |
| if Controlled_Type (T) |
| and then Ekind (PtrT) = E_Anonymous_Access_Type |
| then |
| -- Create local finalization list for access parameter |
| |
| Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); |
| end if; |
| |
| 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; |
| |
| -- Ada 2005 (AI-344): For an allocator with a class-wide designated |
| -- type, generate an accessibility check to verify that the level of |
| -- the type of the created object is not deeper than the level of the |
| -- access type. If the type of the qualified expression is class- |
| -- wide, then always generate the check. Otherwise, only generate the |
| -- check if the level of the qualified expression type is statically |
| -- deeper than the access type. Although the static accessibility |
| -- will generally have been performed as a legality check, it won't |
| -- have been done in cases where the allocator appears in generic |
| -- body, so a run-time check is needed in general. |
| |
| if Ada_Version >= Ada_05 |
| and then Is_Class_Wide_Type (DesigT) |
| and then not Scope_Suppress (Accessibility_Check) |
| and then |
| (Is_Class_Wide_Type (Etype (Exp)) |
| or else |
| Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)) |
| then |
| Insert_Action (N, |
| Make_Raise_Program_Error (Loc, |
| Condition => |
| Make_Op_Gt (Loc, |
| Left_Opnd => |
| Make_Function_Call (Loc, |
| Name => |
| New_Reference_To (RTE (RE_Get_Access_Level), Loc), |
| Parameter_Associations => |
| New_List (Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Reference_To (Temp, Loc), |
| Attribute_Name => |
| Name_Tag))), |
| Right_Opnd => |
| Make_Integer_Literal (Loc, Type_Access_Level (PtrT))), |
| Reason => PE_Accessibility_Check_Failed)); |
| end if; |
| |
| if Java_VM then |
| |
| -- Suppress the tag assignment when Java_VM because JVM tags are |
| -- represented implicitly in objects. |
| |
| null; |
| |
| elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then |
| TagT := T; |
| TagR := New_Reference_To (Temp, Loc); |
| |
| elsif Is_Private_Type (T) |
| and then Is_Tagged_Type (Underlying_Type (T)) |
| then |
| TagT := Underlying_Type (T); |
| TagR := |
| Unchecked_Convert_To (Underlying_Type (T), |
| Make_Explicit_Dereference (Loc, |
| Prefix => New_Reference_To (Temp, Loc))); |
| end if; |
| |
| if Present (TagT) then |
| Tag_Assign := |
| Make_Assignment_Statement (Loc, |
| Name => |
| Make_Selected_Component (Loc, |
| Prefix => TagR, |
| Selector_Name => |
| New_Reference_To (First_Tag_Component (TagT), Loc)), |
| |
| Expression => |
| Unchecked_Convert_To (RTE (RE_Tag), |
| New_Reference_To |
| (Elists.Node (First_Elmt (Access_Disp_Table (TagT))), |
| Loc))); |
| |
| -- The previous assignment has to be done in any case |
| |
| Set_Assignment_OK (Name (Tag_Assign)); |
| Insert_Action (N, Tag_Assign); |
| end if; |
| |
| if Controlled_Type (DesigT) |
| and then Controlled_Type (T) |
| then |
| declare |
| 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 |
| if Controlled_Type (T) |
| and then Ekind (PtrT) = E_Anonymous_Access_Type |
| then |
| -- Create local finalization list for access parameter |
| |
| Flist := |
| Get_Allocator_Final_List (N, Base_Type (T), PtrT); |
| else |
| Flist := Find_Final_List (PtrT); |
| end if; |
| |
| 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, |
| Prefix => New_Reference_To (Temp, Loc))), |
| |
| Typ => T, |
| Flist_Ref => Flist, |
| With_Attach => Attach, |
| Allocator => True)); |
| 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_Comes_From_Source |
| (Expression (Tmp_Node), Comes_From_Source (N)); |
| |
| 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 (DesigT) |
| 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 (DesigT), |
| 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 (DesigT) |
| and then not Subtypes_Statically_Match |
| (T, DesigT) |
| then |
| Apply_Constraint_Check |
| (Exp, DesigT, No_Sliding => False); |
| |
| -- The nonsliding check should really be performed |
| -- (unconditionally) against the subtype of the |
| -- qualified expression, but that causes a problem |
| -- with c34007g (see above), so for now we retain this. |
| |
| else |
| Apply_Constraint_Check |
| (Exp, DesigT, No_Sliding => True); |
| end if; |
| |
| -- For an access to unconstrained packed array, GIGI needs |
| -- to see an expression with a constrained subtype in order |
| -- to compute the proper size for the allocator. |
| |
| if Is_Array_Type (T) |
| and then not Is_Constrained (T) |
| and then Is_Packed (T) |
| then |
| declare |
| ConstrT : constant Entity_Id := |
| Make_Defining_Identifier (Loc, |
| Chars => New_Internal_Name ('A')); |
| Internal_Exp : constant Node_Id := Relocate_Node (Exp); |
| begin |
| Insert_Action (Exp, |
| Make_Subtype_Declaration (Loc, |
| Defining_Identifier => ConstrT, |
| Subtype_Indication => |
| Make_Subtype_From_Expr (Exp, T))); |
| Freeze_Itype (ConstrT, Exp); |
| Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp)); |
| end; |
| end if; |
| |
| end if; |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_Allocator_Expression; |
| |
| ----------------------------- |
| -- Expand_Array_Comparison -- |
| ----------------------------- |
| |
| -- Expansion is only required in the case of array types. For the |
| -- unpacked case, an appropriate runtime routine is called. For |
| -- packed cases, and also in some other cases where a runtime |
| -- routine cannot be called, 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)); |
| Ctyp : constant Entity_Id := Component_Type (Typ1); |
| |
| Expr : Node_Id; |
| Func_Body : Node_Id; |
| Func_Name : Entity_Id; |
| |
| Comp : RE_Id; |
| |
| Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size; |
| -- True for byte addressable target |
| |
| function Length_Less_Than_4 (Opnd : Node_Id) return Boolean; |
| -- Returns True if the length of the given operand is known to be |
| -- less than 4. Returns False if this length is known to be four |
| -- or greater or is not known at compile time. |
| |
| ------------------------ |
| -- Length_Less_Than_4 -- |
| ------------------------ |
| |
| function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is |
| Otyp : constant Entity_Id := Etype (Opnd); |
| |
| begin |
| if Ekind (Otyp) = E_String_Literal_Subtype then |
| return String_Literal_Length (Otyp) < 4; |
| |
| else |
| declare |
| Ityp : constant Entity_Id := Etype (First_Index (Otyp)); |
| Lo : constant Node_Id := Type_Low_Bound (Ityp); |
| Hi : constant Node_Id := Type_High_Bound (Ityp); |
| Lov : Uint; |
| Hiv : Uint; |
| |
| begin |
| if Compile_Time_Known_Value (Lo) then |
| Lov := Expr_Value (Lo); |
| else |
| return False; |
| end if; |
| |
| if Compile_Time_Known_Value (Hi) then |
| Hiv := Expr_Value (Hi); |
| else |
| return False; |
| end if; |
| |
| return Hiv < Lov + 3; |
| end; |
| end if; |
| end Length_Less_Than_4; |
| |
| -- Start of processing for Expand_Array_Comparison |
| |
| begin |
| -- Deal first with unpacked case, where we can call a runtime routine |
| -- except that we avoid this for targets for which are not addressable |
| -- by bytes, and for the JVM, since the JVM does not support direct |
| -- addressing of array components. |
| |
| if not Is_Bit_Packed_Array (Typ1) |
| and then Byte_Addressable |
| and then not Java_VM |
| then |
| -- The call we generate is: |
| |
| -- Compare_Array_xn[_Unaligned] |
| -- (left'address, right'address, left'length, right'length) <op> 0 |
| |
| -- x = U for unsigned, S for signed |
| -- n = 8,16,32,64 for component size |
| -- Add _Unaligned if length < 4 and component size is 8. |
| -- <op> is the standard comparison operator |
| |
| if Component_Size (Typ1) = 8 then |
| if Length_Less_Than_4 (Op1) |
| or else |
| Length_Less_Than_4 (Op2) |
| then |
| if Is_Unsigned_Type (Ctyp) then |
| Comp := RE_Compare_Array_U8_Unaligned; |
| else |
| Comp := RE_Compare_Array_S8_Unaligned; |
| end if; |
| |
| else |
| if Is_Unsigned_Type (Ctyp) then |
| Comp := RE_Compare_Array_U8; |
| else |
| Comp := RE_Compare_Array_S8; |
| end if; |
| end if; |
| |
| elsif Component_Size (Typ1) = 16 then |
| if Is_Unsigned_Type (Ctyp) then |
| Comp := RE_Compare_Array_U16; |
| else |
| Comp := RE_Compare_Array_S16; |
| end if; |
| |
| elsif Component_Size (Typ1) = 32 then |
| if Is_Unsigned_Type (Ctyp) then |
| Comp := RE_Compare_Array_U32; |
| else |
| Comp := RE_Compare_Array_S32; |
| end if; |
| |
| else pragma Assert (Component_Size (Typ1) = 64); |
| if Is_Unsigned_Type (Ctyp) then |
| Comp := RE_Compare_Array_U64; |
| else |
| Comp := RE_Compare_Array_S64; |
| end if; |
| end if; |
| |
| Remove_Side_Effects (Op1, Name_Req => True); |
| Remove_Side_Effects (Op2, Name_Req => True); |
| |
| Rewrite (Op1, |
| Make_Function_Call (Sloc (Op1), |
| Name => New_Occurrence_Of (RTE (Comp), Loc), |
| |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Op1), |
| Attribute_Name => Name_Address), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Op2), |
| Attribute_Name => Name_Address), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Op1), |
| Attribute_Name => Name_Length), |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Op2), |
| Attribute_Name => Name_Length)))); |
| |
| Rewrite (Op2, |
| Make_Integer_Literal (Sloc (Op2), |
| Intval => Uint_0)); |
| |
| Analyze_And_Resolve (Op1, Standard_Integer); |
| Analyze_And_Resolve (Op2, Standard_Integer); |
| return; |
| end if; |
| |
| -- Cases where we cannot make runtime call |
| |
| -- 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); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| 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 : atyp; B : btyp) return boolean is |
| -- begin |
| -- if (A'length (1) = 0 or else A'length (2) = 0) |
| -- and then |
| -- (B'length (1) = 0 or else B'length (2) = 0) |
| -- then |
| -- return True; -- RM 4.5.2(22) |
| -- end if; |
| |
| -- if A'length (1) /= B'length (1) |
| -- or else |
| -- A'length (2) /= B'length (2) |
| -- then |
| -- return False; -- RM 4.5.2(23) |
| -- end if; |
| |
| -- declare |
| -- A1 : Index_T1 := A'first (1); |
| -- B1 : Index_T1 := B'first (1); |
| -- begin |
| -- loop |
| -- declare |
| -- A2 : Index_T2 := A'first (2); |
| -- B2 : Index_T2 := B'first (2); |
| -- begin |
| -- loop |
| -- if A (A1, A2) /= B (B1, B2) then |
| -- return False; |
| -- end if; |
| |
| -- exit when A2 = A'last (2); |
| -- A2 := Index_T2'succ (A2); |
| -- B2 := Index_T2'succ (B2); |
| -- end loop; |
| -- end; |
| |
| -- exit when A1 = A'last (1); |
| -- A1 := Index_T1'succ (A1); |
| -- B1 := Index_T1'succ (B1); |
| -- end loop; |
| -- end; |
| |
| -- return true; |
| -- end Enn; |
| |
| -- Note on the formal types used (atyp and btyp). If either of the |
| -- arrays is of a private type, we use the underlying type, and |
| -- do an unchecked conversion of the actual. If either of the arrays |
| -- has a bound depending on a discriminant, then we use the base type |
| -- since otherwise we have an escaped discriminant in the function. |
| |
| -- If both arrays are constrained and have the same bounds, we can |
| -- generate a loop with an explicit iteration scheme using a 'Range |
| -- attribute over the first array. |
| |
| function Expand_Array_Equality |
| (Nod : Node_Id; |
| Lhs : Node_Id; |
| Rhs : Node_Id; |
| Bodies : List_Id; |
| Typ : Entity_Id) return Node_Id |
| is |
| Loc : constant Source_Ptr := Sloc (Nod); |
| Decls : constant List_Id := New_List; |
| Index_List1 : constant List_Id := New_List; |
| Index_List2 : constant List_Id := New_List; |
| |
| Actuals : List_Id; |
| Formals : List_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); |
| |
| Ltyp : Entity_Id; |
| Rtyp : Entity_Id; |
| -- The parameter types to be used for the formals |
| |
| function Arr_Attr |
| (Arr : Entity_Id; |
| Nam : Name_Id; |
| Num : Int) return Node_Id; |
| -- This builds the attribute reference Arr'Nam (Expr) |
| |
| function Component_Equality (Typ : Entity_Id) return Node_Id; |
| -- Create one statement to compare corresponding components, |
| -- designated by a full set of indices. |
| |
| function Get_Arg_Type (N : Node_Id) return Entity_Id; |
| -- Given one of the arguments, computes the appropriate type to |
| -- be used for that argument in the corresponding function formal |
| |
| function Handle_One_Dimension |
| (N : Int; |
| Index : Node_Id) return Node_Id; |
| -- This procedure returns the following code |
| -- |
| -- declare |
| -- Bn : Index_T := B'First (N); |
| -- begin |
| -- loop |
| -- xxx |
| -- exit when An = A'Last (N); |
| -- An := Index_T'Succ (An) |
| -- Bn := Index_T'Succ (Bn) |
| -- end loop; |
| -- end; |
| -- |
| -- If both indices are constrained and identical, the procedure |
| -- returns a simpler loop: |
| -- |
| -- for An in A'Range (N) loop |
| -- xxx |
| -- end loop |
| -- |
| -- N is the dimension for which we are generating a loop. Index is the |
| -- N'th index node, whose Etype is Index_Type_n in the above code. |
| -- The xxx statement is either the loop or declare for the next |
| -- dimension or if this is the last dimension the comparison |
| -- of corresponding components of the arrays. |
| -- |
| -- The actual way the code works is to return the comparison |
| -- of corresponding components for the N+1 call. That's neater! |
| |
| function Test_Empty_Arrays return Node_Id; |
| -- This function constructs the test for both arrays being empty |
| -- (A'length (1) = 0 or else A'length (2) = 0 or else ...) |
| -- and then |
| -- (B'length (1) = 0 or else B'length (2) = 0 or else ...) |
| |
| function Test_Lengths_Correspond return Node_Id; |
| -- This function constructs the test for arrays having different |
| -- lengths in at least one index position, in which case resull |
| |
| -- A'length (1) /= B'length (1) |
| -- or else |
| -- A'length (2) /= B'length (2) |
| -- or else |
| -- ... |
| |
| -------------- |
| -- Arr_Attr -- |
| -------------- |
| |
| function Arr_Attr |
| (Arr : Entity_Id; |
| Nam : Name_Id; |
| Num : Int) return Node_Id |
| is |
| begin |
| return |
| Make_Attribute_Reference (Loc, |
| Attribute_Name => Nam, |
| Prefix => New_Reference_To (Arr, Loc), |
| Expressions => New_List (Make_Integer_Literal (Loc, Num))); |
| end Arr_Attr; |
| |
| ------------------------ |
| -- 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); |
| |
| -- If some (sub)component is an unchecked_union, the whole operation |
| -- will raise program error. |
| |
| if Nkind (Test) = N_Raise_Program_Error then |
| |
| -- This node is going to be inserted at a location where a |
| -- statement is expected: clear its Etype so analysis will |
| -- set it to the expected Standard_Void_Type. |
| |
| Set_Etype (Test, Empty); |
| return Test; |
| |
| else |
| 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 if; |
| end Component_Equality; |
| |
| ------------------ |
| -- Get_Arg_Type -- |
| ------------------ |
| |
| function Get_Arg_Type (N : Node_Id) return Entity_Id is |
| T : Entity_Id; |
| X : Node_Id; |
| |
| begin |
| T := Etype (N); |
| |
| if No (T) then |
| return Typ; |
| |
| else |
| T := Underlying_Type (T); |
| |
| X := First_Index (T); |
| while Present (X) loop |
| if Denotes_Discriminant (Type_Low_Bound (Etype (X))) |
| or else |
| Denotes_Discriminant (Type_High_Bound (Etype (X))) |
| then |
| T := Base_Type (T); |
| exit; |
| end if; |
| |
| Next_Index (X); |
| end loop; |
| |
| return T; |
| end if; |
| end Get_Arg_Type; |
| |
| -------------------------- |
| -- Handle_One_Dimension -- |
| --------------------------- |
| |
| function Handle_One_Dimension |
| (N : Int; |
| Index : Node_Id) return Node_Id |
| is |
| Need_Separate_Indexes : constant Boolean := |
| Ltyp /= Rtyp |
| or else not Is_Constrained (Ltyp); |
| -- If the index types are identical, and we are working with |
| -- constrained types, then we can use the same index for both of |
| -- the arrays. |
| |
| An : constant Entity_Id := Make_Defining_Identifier (Loc, |
| Chars => New_Internal_Name ('A')); |
| |
| Bn : Entity_Id; |
| Index_T : Entity_Id; |
| Stm_List : List_Id; |
| Loop_Stm : Node_Id; |
| |
| begin |
| if N > Number_Dimensions (Ltyp) then |
| return Component_Equality (Ltyp); |
| end if; |
| |
| -- Case where we generate a loop |
| |
| Index_T := Base_Type (Etype (Index)); |
| |
| if Need_Separate_Indexes then |
| Bn := |
| Make_Defining_Identifier (Loc, |
| Chars => New_Internal_Name ('B')); |
| else |
| Bn := An; |
| end if; |
| |
| Append (New_Reference_To (An, Loc), Index_List1); |
| Append (New_Reference_To (Bn, Loc), Index_List2); |
| |
| Stm_List := New_List ( |
| Handle_One_Dimension (N + 1, Next_Index (Index))); |
| |
| if Need_Separate_Indexes then |
| |
| -- Generate guard for loop, followed by increments of indices |
| |
| Append_To (Stm_List, |
| Make_Exit_Statement (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => New_Reference_To (An, Loc), |
| Right_Opnd => Arr_Attr (A, Name_Last, N)))); |
| |
| Append_To (Stm_List, |
| Make_Assignment_Statement (Loc, |
| Name => New_Reference_To (An, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Index_T, Loc), |
| Attribute_Name => Name_Succ, |
| Expressions => New_List (New_Reference_To (An, Loc))))); |
| |
| Append_To (Stm_List, |
| Make_Assignment_Statement (Loc, |
| Name => New_Reference_To (Bn, Loc), |
| Expression => |
| Make_Attribute_Reference (Loc, |
| Prefix => New_Reference_To (Index_T, Loc), |
| Attribute_Name => Name_Succ, |
| Expressions => New_List (New_Reference_To (Bn, Loc))))); |
| end if; |
| |
| -- If separate indexes, we need a declare block for An and Bn, and a |
| -- loop without an iteration scheme. |
| |
| if Need_Separate_Indexes then |
| Loop_Stm := |
| Make_Implicit_Loop_Statement (Nod, Statements => Stm_List); |
| |
| return |
| Make_Block_Statement (Loc, |
| Declarations => New_List ( |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => An, |
| Object_Definition => New_Reference_To (Index_T, Loc), |
| Expression => Arr_Attr (A, Name_First, N)), |
| |
| Make_Object_Declaration (Loc, |
| Defining_Identifier => Bn, |
| Object_Definition => New_Reference_To (Index_T, Loc), |
| Expression => Arr_Attr (B, Name_First, N))), |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List (Loop_Stm))); |
| |
| -- If no separate indexes, return loop statement with explicit |
| -- iteration scheme on its own |
| |
| else |
| Loop_Stm := |
| Make_Implicit_Loop_Statement (Nod, |
| Statements => Stm_List, |
| Iteration_Scheme => |
| Make_Iteration_Scheme (Loc, |
| Loop_Parameter_Specification => |
| Make_Loop_Parameter_Specification (Loc, |
| Defining_Identifier => An, |
| Discrete_Subtype_Definition => |
| Arr_Attr (A, Name_Range, N)))); |
| return Loop_Stm; |
| end if; |
| end Handle_One_Dimension; |
| |
| ----------------------- |
| -- Test_Empty_Arrays -- |
| ----------------------- |
| |
| function Test_Empty_Arrays return Node_Id is |
| Alist : Node_Id; |
| Blist : Node_Id; |
| |
| Atest : Node_Id; |
| Btest : Node_Id; |
| |
| begin |
| Alist := Empty; |
| Blist := Empty; |
| for J in 1 .. Number_Dimensions (Ltyp) loop |
| Atest := |
| Make_Op_Eq (Loc, |
| Left_Opnd => Arr_Attr (A, Name_Length, J), |
| Right_Opnd => Make_Integer_Literal (Loc, 0)); |
| |
| Btest := |
| Make_Op_Eq (Loc, |
| Left_Opnd => Arr_Attr (B, Name_Length, J), |
| Right_Opnd => Make_Integer_Literal (Loc, 0)); |
| |
| if No (Alist) then |
| Alist := Atest; |
| Blist := Btest; |
| |
| else |
| Alist := |
| Make_Or_Else (Loc, |
| Left_Opnd => Relocate_Node (Alist), |
| Right_Opnd => Atest); |
| |
| Blist := |
| Make_Or_Else (Loc, |
| Left_Opnd => Relocate_Node (Blist), |
| Right_Opnd => Btest); |
| end if; |
| end loop; |
| |
| return |
| Make_And_Then (Loc, |
| Left_Opnd => Alist, |
| Right_Opnd => Blist); |
| end Test_Empty_Arrays; |
| |
| ----------------------------- |
| -- Test_Lengths_Correspond -- |
| ----------------------------- |
| |
| function Test_Lengths_Correspond return Node_Id is |
| Result : Node_Id; |
| Rtest : Node_Id; |
| |
| begin |
| Result := Empty; |
| for J in 1 .. Number_Dimensions (Ltyp) loop |
| Rtest := |
| Make_Op_Ne (Loc, |
| Left_Opnd => Arr_Attr (A, Name_Length, J), |
| Right_Opnd => Arr_Attr (B, Name_Length, J)); |
| |
| if No (Result) then |
| Result := Rtest; |
| else |
| Result := |
| Make_Or_Else (Loc, |
| Left_Opnd => Relocate_Node (Result), |
| Right_Opnd => Rtest); |
| end if; |
| end loop; |
| |
| return Result; |
| end Test_Lengths_Correspond; |
| |
| -- Start of processing for Expand_Array_Equality |
| |
| begin |
| Ltyp := Get_Arg_Type (Lhs); |
| Rtyp := Get_Arg_Type (Rhs); |
| |
| -- For now, if the argument types are not the same, go to the |
| -- base type, since the code assumes that the formals have the |
| -- same type. This is fixable in future ??? |
| |
| if Ltyp /= Rtyp then |
| Ltyp := Base_Type (Ltyp); |
| Rtyp := Base_Type (Rtyp); |
| pragma Assert (Ltyp = Rtyp); |
| end if; |
| |
| -- Build list of formals for function |
| |
| Formals := New_List ( |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => A, |
| Parameter_Type => New_Reference_To (Ltyp, Loc)), |
| |
| Make_Parameter_Specification (Loc, |
| Defining_Identifier => B, |
| Parameter_Type => New_Reference_To (Rtyp, Loc))); |
| |
| Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E')); |
| |
| -- Build statement sequence for function |
| |
| Func_Body := |
| Make_Subprogram_Body (Loc, |
| Specification => |
| Make_Function_Specification (Loc, |
| Defining_Unit_Name => Func_Name, |
| Parameter_Specifications => Formals, |
| Result_Definition => New_Reference_To (Standard_Boolean, Loc)), |
| |
| Declarations => Decls, |
| |
| Handled_Statement_Sequence => |
| Make_Handled_Sequence_Of_Statements (Loc, |
| Statements => New_List ( |
| |
| Make_Implicit_If_Statement (Nod, |
| Condition => Test_Empty_Arrays, |
| Then_Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Expression => |
| New_Occurrence_Of (Standard_True, Loc)))), |
| |
| Make_Implicit_If_Statement (Nod, |
| Condition => Test_Lengths_Correspond, |
| Then_Statements => New_List ( |
| Make_Return_Statement (Loc, |
| Expression => |
| New_Occurrence_Of (Standard_False, Loc)))), |
| |
| Handle_One_Dimension (1, First_Index (Ltyp)), |
| |
| Make_Return_Statement (Loc, |
| Expression => New_Occurrence_Of (Standard_True, Loc))))); |
| |
| Set_Has_Completion (Func_Name, True); |
| Set_Is_Inlined (Func_Name); |
| |
| -- 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. |
| |
| declare |
| L, R : Node_Id; |
| |
| begin |
| L := Lhs; |
| R := Rhs; |
| |
| if No (Etype (Lhs)) |
| or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp) |
| then |
| L := OK_Convert_To (Ltyp, Lhs); |
| end if; |
| |
| if No (Etype (Rhs)) |
| or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp) |
| then |
| R := OK_Convert_To (Rtyp, Rhs); |
| end if; |
| |
| Actuals := New_List (L, R); |
| end; |
| |
| 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 |
| -- Special case of bit packed array where both operands are known |
| -- to be properly aligned. In this case we use an efficient run time |
| -- routine to carry out the operation (see System.Bit_Ops). |
| |
| if Is_Bit_Packed_Array (Typ) |
| and then not Is_Possibly_Unaligned_Object (Left_Opnd (N)) |
| and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) |
| then |
| Expand_Packed_Boolean_Operator (N); |
| return; |
| end if; |
| |
| -- For the normal non-packed case, the general expansion is to build |
| -- function for carrying out the comparison (use Make_Boolean_Array_Op) |
| -- and then inserting it into the tree. The original operator node is |
| -- then rewritten as a call to this function. We also use this in the |
| -- packed case if either operand is a possibly unaligned object. |
| |
| 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)); |
| |
| if Nkind (Parent (N)) = N_Assignment_Statement |
| and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R) |
| then |
| Build_Boolean_Array_Proc_Call (Parent (N), L, R); |
| |
| elsif Nkind (Parent (N)) = N_Op_Not |
| and then Nkind (N) = N_Op_And |
| and then |
| Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R) |
| then |
| return; |
| else |
| |
| 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 if; |
| end; |
| 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, Lhs, Rhs, Bodies, Full_Type); |
| 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))) |
| and then Base_Type (Etype (Eq_Op)) = Standard_Boolean; |
| 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, TSS_Composite_Equality); |
| |
| 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 : constant 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 |
| -- Comparison between Unchecked_Union components |
| |
| if Is_Unchecked_Union (Full_Type) then |
| declare |
| Lhs_Type : Node_Id := Full_Type; |
| Rhs_Type : Node_Id := Full_Type; |
| Lhs_Discr_Val : Node_Id; |
| Rhs_Discr_Val : Node_Id; |
| |
| begin |
| -- Lhs subtype |
| |
| if Nkind (Lhs) = N_Selected_Component then |
| Lhs_Type := Etype (Entity (Selector_Name (Lhs))); |
| end if; |
| |
| -- Rhs subtype |
| |
| if Nkind (Rhs) = N_Selected_Component then |
| Rhs_Type := Etype (Entity (Selector_Name (Rhs))); |
| end if; |
| |
| -- Lhs of the composite equality |
| |
| if Is_Constrained (Lhs_Type) then |
| |
| -- Since the enclosing record can never be an |
| -- Unchecked_Union (this code is executed for records |
| -- that do not have variants), we may reference its |
| -- discriminant(s). |
| |
| if Nkind (Lhs) = N_Selected_Component |
| and then Has_Per_Object_Constraint ( |
| Entity (Selector_Name (Lhs))) |
| then |
| Lhs_Discr_Val := |
| Make_Selected_Component (Loc, |
| Prefix => Prefix (Lhs), |
| Selector_Name => |
| New_Copy ( |
| Get_Discriminant_Value ( |
| First_Discriminant (Lhs_Type), |
| Lhs_Type, |
| Stored_Constraint (Lhs_Type)))); |
| |
| else |
| Lhs_Discr_Val := New_Copy ( |
| Get_Discriminant_Value ( |
| First_Discriminant (Lhs_Type), |
| Lhs_Type, |
| Stored_Constraint (Lhs_Type))); |
| |
| end if; |
| else |
| -- It is not possible to infer the discriminant since |
| -- the subtype is not constrained. |
| |
| return |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Unchecked_Union_Restriction); |
| end if; |
| |
| -- Rhs of the composite equality |
| |
| if Is_Constrained (Rhs_Type) then |
| if Nkind (Rhs) = N_Selected_Component |
| and then Has_Per_Object_Constraint ( |
| Entity (Selector_Name (Rhs))) |
| then |
| Rhs_Discr_Val := |
| Make_Selected_Component (Loc, |
| Prefix => Prefix (Rhs), |
| Selector_Name => |
| New_Copy ( |
| Get_Discriminant_Value ( |
| First_Discriminant (Rhs_Type), |
| Rhs_Type, |
| Stored_Constraint (Rhs_Type)))); |
| |
| else |
| Rhs_Discr_Val := New_Copy ( |
| Get_Discriminant_Value ( |
| First_Discriminant (Rhs_Type), |
| Rhs_Type, |
| Stored_Constraint (Rhs_Type))); |
| |
| end if; |
| else |
| return |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Unchecked_Union_Restriction); |
| end if; |
| |
| -- Call the TSS equality function with the inferred |
| -- discriminant values. |
| |
| return |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Eq_Op, Loc), |
| Parameter_Associations => New_List ( |
| Lhs, |
| Rhs, |
| Lhs_Discr_Val, |
| Rhs_Discr_Val)); |
| end; |
| end if; |
| |
| -- Shouldn't this be an else, we can't fall through |
| -- the above IF, right??? |
| |
| 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; Last : Boolean) 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. |
| -- If the flag Last is true, the exit statement is emitted before |
| -- incrementing the lower bound, to prevent the creation out of |
| -- bound values. |
| |
| 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 Integer_Type'(Ind_Typ'Pos (L)). We qualify the |
| -- expression to avoid universal_integer computations whenever possible, |
| -- in the expression for the upper bound H. |
| |
| 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; Last : Boolean) return List_Id is |
| Stmts : constant 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); |
| |
| if Last then |
| Loop_Stmt := |
| Make_Implicit_Loop_Statement (Cnode, |
| Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc)); |
| else |
| Loop_Stmt := |
| Make_Implicit_Loop_Statement (Cnode, |
| Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc)); |
| end if; |
| |
| 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 |
| Target_Type : Entity_Id; |
| |
| begin |
| -- If the index type is an enumeration type, the computation |
| -- can be done in standard integer. Otherwise, choose a large |
| -- enough integer type. |
| |
| if Is_Enumeration_Type (Ind_Typ) |
| or else Root_Type (Ind_Typ) = Standard_Integer |
| or else Root_Type (Ind_Typ) = Standard_Short_Integer |
| or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer |
| then |
| Target_Type := Standard_Integer; |
| else |
| Target_Type := Root_Type (Ind_Typ); |
| end if; |
| |
| return |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => New_Reference_To (Target_Type, Loc), |
| Expression => |
| 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, |
| Result_Definition => 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, I = Nb_Opnds))); |
| 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 a serious error |
| -- earlier, so we just abandon the attempt at expansion. |
| |
| else |
| pragma Assert (Serious_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); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| end Expand_Concatenate_String; |
| |
| ------------------------ |
| -- Expand_N_Allocator -- |
| ------------------------ |
| |
| procedure Expand_N_Allocator (N : Node_Id) is |
| PtrT : constant Entity_Id := Etype (N); |
| Dtyp : constant Entity_Id := Designated_Type (PtrT); |
| Etyp : constant Entity_Id := Etype (Expression (N)); |
| Loc : constant Source_Ptr := Sloc (N); |
| Desig : Entity_Id; |
| 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; |
| |
| elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then |
| Set_Procedure_To_Call (N, RTE (RE_Allocate_Any)); |
| |
| 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 |
| |
| -- The allocator is not part of a constraint on a record component, |
| -- because in that case the inserted actions are delayed until the |
| -- record declaration is fully analyzed, which is too late for the |
| -- analysis of the rewritten allocator. |
| |
| 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)))) |
| and then not Is_Record_Type (Current_Scope) |
| 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 (Dtyp) then |
| Desig := New_Occurrence_Of (Dtyp, 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; |
| |
| -- Handle case of qualified expression (other than optimization above) |
| |
| if Nkind (Expression (N)) = N_Qualified_Expression then |
| Expand_Allocator_Expression (N); |
| |
| -- If the allocator is for a type which requires initialization, and |
| -- there is no initial value (i.e. 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 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. |
| |
| 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; |
| Attach_Level : Uint; |
| |
| 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 (Dtyp) 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_Tree (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_Tree (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); |
| |
| -- If the designated type is task type or contains tasks, |
| -- Create block to activate created tasks, and insert |
| -- declaration for Task_Image variable ahead of call. |
| |
| if Has_Task (T) then |
| declare |
| L : constant 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 |
| Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); |
| if Ekind (PtrT) = E_Anonymous_Access_Type then |
| Attach_Level := Uint_1; |
| else |
| Attach_Level := Uint_2; |
| end if; |
| Insert_Actions (N, |
| Make_Init_Call ( |
| Ref => New_Copy_Tree (Arg1), |
| Typ => T, |
| Flist_Ref => Flist, |
| With_Attach => Make_Integer_Literal (Loc, |
| Attach_Level))); |
| 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; |
| |
| -- Ada 2005 (AI-251): If the allocated object is accessed through an |
| -- access to class-wide interface we force the displacement of the |
| -- pointer to the allocated object to reference the corresponding |
| -- secondary dispatch table. |
| |
| if Is_Class_Wide_Type (Dtyp) |
| and then Is_Interface (Dtyp) |
| then |
| declare |
| Saved_Typ : constant Entity_Id := Etype (N); |
| |
| begin |
| -- 1) Get access to the allocated object |
| |
| Rewrite (N, |
| Make_Explicit_Dereference (Loc, |
| Relocate_Node (N))); |
| Set_Etype (N, Etyp); |
| Set_Analyzed (N); |
| |
| -- 2) Add the conversion to displace the pointer to reference |
| -- the secondary dispatch table. |
| |
| Rewrite (N, Convert_To (Dtyp, Relocate_Node (N))); |
| Analyze_And_Resolve (N, Dtyp); |
| |
| -- 3) The 'access to the secondary dispatch table will be used as |
| -- the value returned by the allocator. |
| |
| Rewrite (N, |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (N), |
| Attribute_Name => Name_Access)); |
| Set_Etype (N, Saved_Typ); |
| Set_Analyzed (N); |
| end; |
| end if; |
| |
| exception |
| when RE_Not_Available => |
| return; |
| 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)))); |
| |
| Set_Assignment_OK (Name (First (Then_Statements (New_If)))); |
| Set_Assignment_OK (Name (First (Else_Statements (New_If)))); |
| |
| 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 |
| -- Insert 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); |
| Lop : constant Node_Id := Left_Opnd (N); |
| Rop : constant Node_Id := Right_Opnd (N); |
| Static : constant Boolean := Is_OK_Static_Expression (N); |
| |
| procedure Substitute_Valid_Check; |
| -- Replaces node N by Lop'Valid. This is done when we have an explicit |
| -- test for the left operand being in range of its subtype. |
| |
| ---------------------------- |
| -- Substitute_Valid_Check -- |
| ---------------------------- |
| |
| procedure Substitute_Valid_Check is |
| begin |
| Rewrite (N, |
| Make_Attribute_Reference (Loc, |
| Prefix => Relocate_Node (Lop), |
| Attribute_Name => Name_Valid)); |
| |
| Analyze_And_Resolve (N, Rtyp); |
| |
| Error_Msg_N ("?explicit membership test may be optimized away", N); |
| Error_Msg_N ("\?use ''Valid attribute instead", N); |
| return; |
| end Substitute_Valid_Check; |
| |
| -- Start of processing for Expand_N_In |
| |
| begin |
| -- Check case of explicit test for an expression in range of its |
| -- subtype. This is suspicious usage and we replace it with a 'Valid |
| -- test and give a warning. |
| |
| if Is_Scalar_Type (Etype (Lop)) |
| and then Nkind (Rop) in N_Has_Entity |
| and then Etype (Lop) = Entity (Rop) |
| and then Comes_From_Source (N) |
| then |
| Substitute_Valid_Check; |
| return; |
| end if; |
| |
| -- Case of explicit range |
| |
| if Nkind (Rop) = N_Range then |
| declare |
| Lo : constant Node_Id := Low_Bound (Rop); |
| Hi : constant Node_Id := High_Bound (Rop); |
| |
| Lo_Orig : constant Node_Id := Original_Node (Lo); |
| Hi_Orig : constant Node_Id := Original_Node (Hi); |
| |
| Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo); |
| Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi); |
| |
| begin |
| -- If test is explicit x'first .. x'last, replace by valid check |
| |
| if Is_Scalar_Type (Etype (Lop)) |
| and then Nkind (Lo_Orig) = N_Attribute_Reference |
| and then Attribute_Name (Lo_Orig) = Name_First |
| and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity |
| and then Entity (Prefix (Lo_Orig)) = Etype (Lop) |
| and then Nkind (Hi_Orig) = N_Attribute_Reference |
| and then Attribute_Name (Hi_Orig) = Name_Last |
| and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity |
| and then Entity (Prefix (Hi_Orig)) = Etype (Lop) |
| and then Comes_From_Source (N) |
| then |
| Substitute_Valid_Check; |
| return; |
| end if; |
| |
| -- If we have an explicit range, do a bit of optimization based |
| -- on range analysis (we may be able to kill one or both checks). |
| |
| -- If either check is known to fail, replace result by False since |
| -- the other check does not matter. Preserve the static flag for |
| -- legality checks, because we are constant-folding beyond RM 4.9. |
| |
| if Lcheck = LT or else Ucheck = GT then |
| Rewrite (N, |
| New_Reference_To (Standard_False, Loc)); |
| Analyze_And_Resolve (N, Rtyp); |
| Set_Is_Static_Expression (N, Static); |
| return; |
| |
| -- If both checks are known to succeed, replace result |
| -- by True, since we know we are in range. |
| |
| elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then |
| Rewrite (N, |
| New_Reference_To (Standard_True, Loc)); |
| Analyze_And_Resolve (N, Rtyp); |
| Set_Is_Static_Expression (N, Static); |
| return; |
| |
| -- If lower bound check succeeds and upper bound check is |
| -- not known to succeed or fail, then replace the range check |
| -- with a comparison against the upper bound. |
| |
| elsif Lcheck in Compare_GE then |
| Rewrite (N, |
| Make_Op_Le (Loc, |
| Left_Opnd => Lop, |
| Right_Opnd => High_Bound (Rop))); |
| Analyze_And_Resolve (N, Rtyp); |
| return; |
| |
| -- If upper bound check succeeds and lower bound check is |
| -- not known to succeed or fail, then replace the range check |
| -- with a comparison against the lower bound. |
| |
| elsif Ucheck in Compare_LE then |
| Rewrite (N, |
| Make_Op_Ge (Loc, |
| Left_Opnd => Lop, |
| Right_Opnd => Low_Bound (Rop))); |
| Analyze_And_Resolve (N, Rtyp); |
| return; |
| end if; |
| end; |
| |
| -- For all other cases of an explicit range, nothing to be done |
| |
| return; |
| |
| -- Here right operand is a subtype mark |
| |
| else |
| declare |
| Typ : Entity_Id := Etype (Rop); |
| Is_Acc : constant Boolean := Is_Access_Type (Typ); |
| Obj : Node_Id := Lop; |
| Cond : Node_Id := Empty; |
| |
| 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 (Rop, |
| 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; |
| |
| -- Ada 2005 (AI-216): Program_Error is raised when evaluating |
| -- a membership test if the subtype mark denotes a constrained |
| -- Unchecked_Union subtype and the expression lacks inferable |
| -- discriminants. |
| |
| elsif Is_Unchecked_Union (Base_Type (Typ)) |
| and then Is_Constrained (Typ) |
| and then not Has_Inferable_Discriminants (Lop) |
| then |
| Insert_Action (N, |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Unchecked_Union_Restriction)); |
| |
| -- Prevent Gigi from generating incorrect code by rewriting |
| -- the test as a standard False. |
| |
| Rewrite (N, |
| New_Occurrence_Of (Standard_False, Loc)); |
| |
| return; |
| end if; |
| |
| -- Here we have a non-scalar type |
| |
| 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 |
| |
| Check_Subscripts : declare |
| function Construct_Attribute_Reference |
| (E : Node_Id; |
| Nam : Name_Id; |
| Dim : Nat) return Node_Id; |
| -- Build attribute reference E'Nam(Dim) |
| |
| ----------------------------------- |
| -- Construct_Attribute_Reference -- |
| ----------------------------------- |
| |
| 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; |
| |
| -- Start processing for Check_Subscripts |
| |
| begin |
| for J in 1 .. Number_Dimensions (Typ) loop |
| Evolve_And_Then (Cond, |
| Make_Op_Eq (Loc, |
| Left_Opnd => |
| Construct_Attribute_Reference |
| (Duplicate_Subexpr_No_Checks (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_No_Checks (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 Check_Subscripts; |
| |
| -- 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 |
| Insert_Explicit_Dereference (P); |
| Analyze_And_Resolve (P, Designated_Type (T)); |
| end if; |
| |
| -- Generate index and validity checks |
| |
| Generate_Index_Checks (N); |
| |
| 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, |
| -- or prefix of the prefix, to handle packed arrays of packed arrays, |
| -- 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; |
| |
| -- If the expression is an index of an indexed component, |
| -- it must be expanded regardless of context. |
| |
| elsif Nkind (Parnt) = N_Indexed_Component |
| and then Child /= Prefix (Parnt) |
| then |
| Expand_Packed_Element_Reference (N); |
| return; |
| |
| elsif Nkind (Parent (Parnt)) = N_Assignment_Statement |
| and then Name (Parent (Parnt)) = Parnt |
| 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); |
| Cfs : constant Boolean := Comes_From_Source (N); |
| |
| begin |
| Rewrite (N, |
| Make_Op_Not (Loc, |
| Right_Opnd => |
| Make_In (Loc, |
| Left_Opnd => Left_Opnd (N), |
| Right_Opnd => Right_Opnd (N)))); |
| |
| -- We want this tp appear as coming from source if original does (see |
| -- tranformations in Expand_N_In). |
| |
| Set_Comes_From_Source (N, Cfs); |
| Set_Comes_From_Source (Right_Opnd (N), Cfs); |
| |
| -- Now analyze tranformed node |
| |
| 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; |
| |
| exception |
| when RE_Not_Available => |
| return; |
| 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 not Backend_Overflow_Checks_On_Target |
| and then Is_Signed_Integer_Type (Etype (N)) |
| and then Do_Overflow_Check (N) |
| then |
| -- The only case to worry about is when the argument is |
| -- equal to the largest negative number, so what we do is |
| -- to insert the check: |
| |
| -- [constraint_error when Expr = typ'Base'First] |
| |
| -- with the usual Duplicate_Subexpr use coding for expr |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => |
| Make_Op_Eq (Loc, |
| Left_Opnd => Duplicate_Subexpr (Expr), |
| Right_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| New_Occurrence_Of (Base_Type (Etype (Expr)), Loc), |
| Attribute_Name => Name_First)), |
| Reason => CE_Overflow_Check_Failed)); |
| end if; |
| |
| -- Vax floating-point types case |
| |
| if 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; |
| |
| -- Arithmetic 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 -- |
| ------------------------ |
| |
| Max_Available_String_Operands : Int := -1; |
| -- This is initialized the first time this routine is called. It records |
| -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are |
| -- available in the run-time: |
| -- |
| -- 0 None available |
| -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available |
| -- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available |
| -- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available |
| -- 5 All routines including RE_Str_Concat_5 available |
| |
| Char_Concat_Available : Boolean; |
| -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if |
| -- all three are available, False if any one of these is unavailable. |
| |
| 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 |
| -- Initialize global variables showing run-time status |
| |
| if Max_Available_String_Operands < 1 then |
| if not RTE_Available (RE_Str_Concat) then |
| Max_Available_String_Operands := 0; |
| elsif not RTE_Available (RE_Str_Concat_3) then |
| Max_Available_String_Operands := 2; |
| elsif not RTE_Available (RE_Str_Concat_4) then |
| Max_Available_String_Operands := 3; |
| elsif not RTE_Available (RE_Str_Concat_5) then |
| Max_Available_String_Operands := 4; |
| else |
| Max_Available_String_Operands := 5; |
| end if; |
| |
| Char_Concat_Available := |
| RTE_Available (RE_Str_Concat_CC) |
| and then |
| RTE_Available (RE_Str_Concat_CS) |
| and then |
| RTE_Available (RE_Str_Concat_SC); |
| end if; |
| |
| -- Ensure validity of both operands |
| |
| 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. We gather any |
| -- number of these in the non-string case, or if no concatenation |
| -- routines are available for string (since in that case we will |
| -- treat string like any other non-string case). Otherwise we only |
| -- gather as many operands as can be handled by the available |
| -- procedures in the run-time library (normally 5, but may be |
| -- less for the configurable run-time case). |
| |
| Inner : while Cnode /= N |
| and then (Base_Type (Etype (Cnode)) /= Standard_String |
| or else |
| Max_Available_String_Operands = 0 |
| or else |
| List_Length (Opnds) < |
| Max_Available_String_Operands) |
| 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) |
| or else not Char_Concat_Available |
| 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 |
| and then Max_Available_String_Operands > 0 |
| 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); |
| Lopnd : constant Node_Id := Left_Opnd (N); |
| Ropnd : constant Node_Id := Right_Opnd (N); |
| Ltyp : constant Entity_Id := Etype (Lopnd); |
| Rtyp : constant Entity_Id := Etype (Ropnd); |
| Typ : Entity_Id := Etype (N); |
| Rknow : constant Boolean := Is_Integer_Type (Typ) |
| and then |
| Compile_Time_Known_Value (Ropnd); |
| Rval : Uint; |
| |
| begin |
| Binary_Op_Validity_Checks (N); |
| |
| if Rknow then |
| Rval := Expr_Value (Ropnd); |
| end if; |
| |
| -- N / 1 = N for integer types |
| |
| if Rknow and then Rval = Uint_1 then |
| Rewrite (N, Lopnd); |
| 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 (Ropnd) = N_Op_Expon |
| and then Is_Power_Of_2_For_Shift (Ropnd) |
| |
| -- We cannot do this transformation in configurable run time mode if we |
| -- have 64-bit -- integers and long shifts are not available. |
| |
| and then |
| (Esize (Ltyp) <= 32 |
| or else Support_Long_Shifts_On_Target) |
| then |
| Rewrite (N, |
| Make_Op_Shift_Right (Loc, |
| Left_Opnd => Lopnd, |
| Right_Opnd => |
| Convert_To (Standard_Natural, Right_Opnd (Ropnd)))); |
| 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 (Ropnd, |
| Convert_To (Universal_Real, Relocate_Node (Ropnd))); |
| |
| Analyze_And_Resolve (Ropnd, Universal_Real); |
| |
| elsif Typ = Universal_Real |
| and then Is_Integer_Type (Ltyp) |
| then |
| Rewrite (Lopnd, |
| Convert_To (Universal_Real, Relocate_Node (Lopnd))); |
| |
| Analyze_And_Resolve (Lopnd, Universal_Real); |
| |
| -- Non-fixed point cases, do integer zero divide and overflow checks |
| |
| elsif Is_Integer_Type (Typ) then |
| Apply_Divide_Check (N); |
| |
| -- Check for 64-bit division available, or long shifts if the divisor |
| -- is a small power of 2 (since such divides will be converted into |
| -- long shifts. |
| |
| if Esize (Ltyp) > 32 |
| and then not Support_64_Bit_Divides_On_Target |
| and then |
| (not Rknow |
| or else not Support_Long_Shifts_On_Target |
| or else (Rval /= Uint_2 and then |
| Rval /= Uint_4 and then |
| Rval /= Uint_8 and then |
| Rval /= Uint_16 and then |
| Rval /= Uint_32 and then |
| Rval /= Uint_64)) |
| then |
| Error_Msg_CRT ("64-bit division", N); |
| end if; |
| |
| -- Deal with Vax_Float |
| |
| elsif Vax_Float (Typ) then |
| Expand_Vax_Arith (N); |
| return; |
| 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); |
| Bodies : constant List_Id := New_List; |
| A_Typ : constant Entity_Id := Etype (Lhs); |
| |
| Typl : Entity_Id := A_Typ; |
| Op_Name : Entity_Id; |
| Prim : Elmt_Id; |
| |
| 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. |
| |
| function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; |
| -- Determines whether a type has a subcompoment of an unconstrained |
| -- Unchecked_Union subtype. Typ is a record type. |
| |
| ------------------------- |
| -- 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; |
| |
| -- If we have an Unchecked_Union, we need to add the inferred |
| -- discriminant values as actuals in the function call. At this |
| -- point, the expansion has determined that both operands have |
| -- inferable discriminants. |
| |
| if Is_Unchecked_Union (Op_Type) then |
| declare |
| Lhs_Type : constant Node_Id := Etype (L_Exp); |
| Rhs_Type : constant Node_Id := Etype (R_Exp); |
| Lhs_Discr_Val : Node_Id; |
| Rhs_Discr_Val : Node_Id; |
| |
| begin |
| -- Per-object constrained selected components require special |
| -- attention. If the enclosing scope of the component is an |
| -- Unchecked_Union, we cannot reference its discriminants |
| -- directly. This is why we use the two extra parameters of |
| -- the equality function of the enclosing Unchecked_Union. |
| |
| -- type UU_Type (Discr : Integer := 0) is |
| -- . . . |
| -- end record; |
| -- pragma Unchecked_Union (UU_Type); |
| |
| -- 1. Unchecked_Union enclosing record: |
| |
| -- type Enclosing_UU_Type (Discr : Integer := 0) is record |
| -- . . . |
| -- Comp : UU_Type (Discr); |
| -- . . . |
| -- end Enclosing_UU_Type; |
| -- pragma Unchecked_Union (Enclosing_UU_Type); |
| |
| -- Obj1 : Enclosing_UU_Type; |
| -- Obj2 : Enclosing_UU_Type (1); |
| |
| -- [. . .] Obj1 = Obj2 [. . .] |
| |
| -- Generated code: |
| |
| -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then |
| |
| -- A and B are the formal parameters of the equality function |
| -- of Enclosing_UU_Type. The function always has two extra |
| -- formals to capture the inferred discriminant values. |
| |
| -- 2. Non-Unchecked_Union enclosing record: |
| |
| -- type |
| -- Enclosing_Non_UU_Type (Discr : Integer := 0) |
| -- is record |
| -- . . . |
| -- Comp : UU_Type (Discr); |
| -- . . . |
| -- end Enclosing_Non_UU_Type; |
| |
| -- Obj1 : Enclosing_Non_UU_Type; |
| -- Obj2 : Enclosing_Non_UU_Type (1); |
| |
| -- ... Obj1 = Obj2 ... |
| |
| -- Generated code: |
| |
| -- if not (uu_typeEQ (obj1.comp, obj2.comp, |
| -- obj1.discr, obj2.discr)) then |
| |
| -- In this case we can directly reference the discriminants of |
| -- the enclosing record. |
| |
| -- Lhs of equality |
| |
| if Nkind (Lhs) = N_Selected_Component |
| and then Has_Per_Object_Constraint |
| (Entity (Selector_Name (Lhs))) |
| then |
| -- Enclosing record is an Unchecked_Union, use formal A |
| |
| if Is_Unchecked_Union (Scope |
| (Entity (Selector_Name (Lhs)))) |
| then |
| Lhs_Discr_Val := |
| Make_Identifier (Loc, |
| Chars => Name_A); |
| |
| -- Enclosing record is of a non-Unchecked_Union type, it is |
| -- possible to reference the discriminant. |
| |
| else |
| Lhs_Discr_Val := |
| Make_Selected_Component (Loc, |
| Prefix => Prefix (Lhs), |
| Selector_Name => |
| New_Copy |
| (Get_Discriminant_Value |
| (First_Discriminant (Lhs_Type), |
| Lhs_Type, |
| Stored_Constraint (Lhs_Type)))); |
| end if; |
| |
| -- Comment needed here ??? |
| |
| else |
| -- Infer the discriminant value |
| |
| Lhs_Discr_Val := |
| New_Copy |
| (Get_Discriminant_Value |
| (First_Discriminant (Lhs_Type), |
| Lhs_Type, |
| Stored_Constraint (Lhs_Type))); |
| end if; |
| |
| -- Rhs of equality |
| |
| if Nkind (Rhs) = N_Selected_Component |
| and then Has_Per_Object_Constraint |
| (Entity (Selector_Name (Rhs))) |
| then |
| if Is_Unchecked_Union |
| (Scope (Entity (Selector_Name (Rhs)))) |
| then |
| Rhs_Discr_Val := |
| Make_Identifier (Loc, |
| Chars => Name_B); |
| |
| else |
| Rhs_Discr_Val := |
| Make_Selected_Component (Loc, |
| Prefix => Prefix (Rhs), |
| Selector_Name => |
| New_Copy (Get_Discriminant_Value ( |
| First_Discriminant (Rhs_Type), |
| Rhs_Type, |
| Stored_Constraint (Rhs_Type)))); |
| |
| end if; |
| else |
| Rhs_Discr_Val := |
| New_Copy (Get_Discriminant_Value ( |
| First_Discriminant (Rhs_Type), |
| Rhs_Type, |
| Stored_Constraint (Rhs_Type))); |
| |
| end if; |
| |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Eq, Loc), |
| Parameter_Associations => New_List ( |
| L_Exp, |
| R_Exp, |
| Lhs_Discr_Val, |
| Rhs_Discr_Val))); |
| end; |
| |
| -- Normal case, not an unchecked union |
| |
| else |
| Rewrite (N, |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (Eq, Loc), |
| Parameter_Associations => New_List (L_Exp, R_Exp))); |
| end if; |
| |
| Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); |
| end Build_Equality_Call; |
| |
| ------------------------------------ |
| -- Has_Unconstrained_UU_Component -- |
| ------------------------------------ |
| |
| function Has_Unconstrained_UU_Component |
| (Typ : Node_Id) return Boolean |
| is |
| Tdef : constant Node_Id := |
| Type_Definition (Declaration_Node (Base_Type (Typ))); |
| Clist : Node_Id; |
| Vpart : Node_Id; |
| |
| function Component_Is_Unconstrained_UU |
| (Comp : Node_Id) return Boolean; |
| -- Determines whether the subtype of the component is an |
| -- unconstrained Unchecked_Union. |
| |
| function Variant_Is_Unconstrained_UU |
| (Variant : Node_Id) return Boolean; |
| -- Determines whether a component of the variant has an unconstrained |
| -- Unchecked_Union subtype. |
| |
| ----------------------------------- |
| -- Component_Is_Unconstrained_UU -- |
| ----------------------------------- |
| |
| function Component_Is_Unconstrained_UU |
| (Comp : Node_Id) return Boolean |
| is |
| begin |
| if Nkind (Comp) /= N_Component_Declaration then |
| return False; |
| end if; |
| |
| declare |
| Sindic : constant Node_Id := |
| Subtype_Indication (Component_Definition (Comp)); |
| |
| begin |
| -- Unconstrained nominal type. In the case of a constraint |
| -- present, the node kind would have been N_Subtype_Indication. |
| |
| if Nkind (Sindic) = N_Identifier then |
| return Is_Unchecked_Union (Base_Type (Etype (Sindic))); |
| end if; |
| |
| return False; |
| end; |
| end Component_Is_Unconstrained_UU; |
| |
| --------------------------------- |
| -- Variant_Is_Unconstrained_UU -- |
| --------------------------------- |
| |
| function Variant_Is_Unconstrained_UU |
| (Variant : Node_Id) return Boolean |
| is |
| Clist : constant Node_Id := Component_List (Variant); |
| |
| begin |
| if Is_Empty_List (Component_Items (Clist)) then |
| return False; |
| end if; |
| |
| -- We only need to test one component |
| |
| declare |
| Comp : Node_Id := First (Component_Items (Clist)); |
| |
| begin |
| while Present (Comp) loop |
| if Component_Is_Unconstrained_UU (Comp) then |
| return True; |
| end if; |
| |
| Next (Comp); |
| end loop; |
| end; |
| |
| -- None of the components withing the variant were of |
| -- unconstrained Unchecked_Union type. |
| |
| return False; |
| end Variant_Is_Unconstrained_UU; |
| |
| -- Start of processing for Has_Unconstrained_UU_Component |
| |
| begin |
| if Null_Present (Tdef) then |
| return False; |
| end if; |
| |
| Clist := Component_List (Tdef); |
| Vpart := Variant_Part (Clist); |
| |
| -- Inspect available components |
| |
| if Present (Component_Items (Clist)) then |
| declare |
| Comp : Node_Id := First (Component_Items (Clist)); |
| |
| begin |
| while Present (Comp) loop |
| |
| -- One component is sufficent |
| |
| if Component_Is_Unconstrained_UU (Comp) then |
| return True; |
| end if; |
| |
| Next (Comp); |
| end loop; |
| end; |
| end if; |
| |
| -- Inspect available components withing variants |
| |
| if Present (Vpart) then |
| declare |
| Variant : Node_Id := First (Variants (Vpart)); |
| |
| begin |
| while Present (Variant) loop |
| |
| -- One component within a variant is sufficent |
| |
| if Variant_Is_Unconstrained_UU (Variant) then |
| return True; |
| end if; |
| |
| Next (Variant); |
| end loop; |
| end; |
| end if; |
| |
| -- Neither the available components, nor the components inside the |
| -- variant parts were of an unconstrained Unchecked_Union subtype. |
| |
| return False; |
| end Has_Unconstrained_UU_Component; |
| |
| -- 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)); |
| else |
| null; |
| 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); |
| |
| -- Boolean types (requiring handling of non-standard case) |
| |
| if 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 |
| |
| -- If we are doing full validity checking, then expand out array |
| -- comparisons to make sure that we check the array elements. |
| |
| if Validity_Check_Operands then |
| declare |
| Save_Force_Validity_Checks : constant Boolean := |
| Force_Validity_Checks; |
| begin |
| Force_Validity_Checks := True; |
| Rewrite (N, |
| Expand_Array_Equality |
| (N, |
| Relocate_Node (Lhs), |
| Relocate_Node (Rhs), |
| Bodies, |
| Typl)); |
| Insert_Actions (N, Bodies); |
| Analyze_And_Resolve (N, Standard_Boolean); |
| Force_Validity_Checks := Save_Force_Validity_Checks; |
| end; |
| |
| -- Packed case where both operands are known aligned |
| |
| elsif Is_Bit_Packed_Array (Typl) |
| and then not Is_Possibly_Unaligned_Object (Lhs) |
| and then not Is_Possibly_Unaligned_Object (Rhs) |
| then |
| Expand_Packed_Eq (N); |
| |
| -- Where the component type is elementary we can use a block bit |
| -- comparison (if supported on the target) exception in the case |
| -- of floating-point (negative zero issues require element by |
| -- element comparison), and atomic types (where we must be sure |
| -- to load elements independently) and possibly unaligned arrays. |
| |
| elsif Is_Elementary_Type (Component_Type (Typl)) |
| and then not Is_Floating_Point_Type (Component_Type (Typl)) |
| and then not Is_Atomic (Component_Type (Typl)) |
| and then not Is_Possibly_Unaligned_Object (Lhs) |
| and then not Is_Possibly_Unaligned_Object (Rhs) |
| and then Support_Composite_Compare_On_Target |
| 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, |
| Relocate_Node (Lhs), |
| Relocate_Node (Rhs), |
| Bodies, |
| Typl)); |
| 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 |
| -- Search for equality operation, checking that the |
| -- operands have the same type. Note that we must find |
| -- a matching entry, or something is very wrong! |
| |
| Prim := First_Elmt (Collect_Primitive_Operations (A_Typ)); |
| |
| while Present (Prim) loop |
| exit when Chars (Node (Prim)) = Name_Op_Eq |
| and then Etype (First_Formal (Node (Prim))) = |
| Etype (Next_Formal (First_Formal (Node (Prim)))) |
| and then |
| Base_Type (Etype (Node (Prim))) = Standard_Boolean; |
| |
| Next_Elmt (Prim); |
| end loop; |
| |
| pragma Assert (Present (Prim)); |
| Op_Name := Node (Prim); |
| |
| -- Find the type's predefined equality or an overriding |
| -- user-defined equality. The reason for not simply calling |
| -- Find_Prim_Op here is that there may be a user-defined |
| -- overloaded equality op that precedes the equality that |
| -- we want, so we have to explicitly search (e.g., there |
| -- could be an equality with two different parameter types). |
| |
| else |
| if Is_Class_Wide_Type (Typl) then |
| Typl := Root_Type (Typl); |
| end if; |
| |
| Prim := First_Elmt (Primitive_Operations (Typl)); |
| while Present (Prim) loop |
| exit when Chars (Node (Prim)) = Name_Op_Eq |
| and then Etype (First_Formal (Node (Prim))) = |
| Etype (Next_Formal (First_Formal (Node (Prim)))) |
| and then |
| Base_Type (Etype (Node (Prim))) = Standard_Boolean; |
| |
| Next_Elmt (Prim); |
| end loop; |
| |
| pragma Assert (Present (Prim)); |
| Op_Name := Node (Prim); |
| end if; |
| |
| Build_Equality_Call (Op_Name); |
| |
| -- Ada 2005 (AI-216): Program_Error is raised when evaluating the |
| -- predefined equality operator for a type which has a subcomponent |
| -- of an Unchecked_Union type whose nominal subtype is unconstrained. |
| |
| elsif Has_Unconstrained_UU_Component (Typl) then |
| Insert_Action (N, |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Unchecked_Union_Restriction)); |
| |
| -- Prevent Gigi from generating incorrect code by rewriting the |
| -- equality as a standard False. |
| |
| Rewrite (N, |
| New_Occurrence_Of (Standard_False, Loc)); |
| |
| elsif Is_Unchecked_Union (Typl) then |
| |
| -- If we can infer the discriminants of the operands, we make a |
| -- call to the TSS equality function. |
| |
| if Has_Inferable_Discriminants (Lhs) |
| and then |
| Has_Inferable_Discriminants (Rhs) |
| then |
| Build_Equality_Call |
| (TSS (Root_Type (Typl), TSS_Composite_Equality)); |
| |
| else |
| -- Ada 2005 (AI-216): Program_Error is raised when evaluating |
| -- the predefined equality operator for an Unchecked_Union type |
| -- if either of the operands lack inferable discriminants. |
| |
| Insert_Action (N, |
| Make_Raise_Program_Error (Loc, |
| Reason => PE_Unchecked_Union_Restriction)); |
| |
| -- Prevent Gigi from generating incorrect code by rewriting |
| -- the equality as a standard False. |
| |
| Rewrite (N, |
| New_Occurrence_Of (Standard_False, Loc)); |
| |
| end if; |
| |
| -- If a type support function is present (for complex cases), use it |
| |
| elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then |
| Build_Equality_Call |
| (TSS (Root_Type (Typl), TSS_Composite_Equality)); |
| |
| -- 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; |
| |
| -- Test if result is known at compile time |
| |
| Rewrite_Comparison (N); |
| |
| -- If we still have comparison for Vax_Float, process it |
| |
| if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare then |
| Expand_Vax_Comparison (N); |
| return; |
| 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)); |
| Bastyp : constant Node_Id := Etype (Base); |
| 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; |
| Etyp : Entity_Id; |
| |
| begin |
| Binary_Op_Validity_Checks (N); |
| |
| -- If either operand is of a private type, then we have the use of |
| -- an intrinsic operator, and we get rid of the privateness, by using |
| -- root types of underlying types for the actual operation. Otherwise |
| -- the private types will cause trouble if we expand multiplications |
| -- or shifts etc. We also do this transformation if the result type |
| -- is different from the base type. |
| |
| if Is_Private_Type (Etype (Base)) |
| or else |
| Is_Private_Type (Typ) |
| or else |
| Is_Private_Type (Exptyp) |
| or else |
| Rtyp /= Root_Type (Bastyp) |
| then |
| declare |
| Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp)); |
| Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp)); |
| |
| begin |
| Rewrite (N, |
| Unchecked_Convert_To (Typ, |
| Make_Op_Expon (Loc, |
| Left_Opnd => Unchecked_Convert_To (Bt, Base), |
| Right_Opnd => Unchecked_Convert_To (Et, Exp)))); |
| Analyze_And_Resolve (N, Typ); |
| return; |
| end; |
| end if; |
| |
| -- Test for case of known 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_No_Checks (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_No_Checks (Base)), |
| Right_Opnd => Duplicate_Subexpr_No_Checks (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_No_Checks (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 leave 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, done using either Integer or Long_Long_Integer. |
| -- It is not worth having routines for Short_[Short_]Integer, since for |
| -- most machines it would not help, and it would generate more code that |
| -- might need certification when a certified run time is required. |
| |
| -- In the integer cases, we have two routines, one for when overflow |
| -- checks are required, and one when they are not required, since there |
| -- is a real gain in omitting checks on many machines. |
| |
| elsif Rtyp = Base_Type (Standard_Long_Long_Integer) |
| or else (Rtyp = Base_Type (Standard_Long_Integer) |
| and then |
| Esize (Standard_Long_Integer) > Esize (Standard_Integer)) |
| or else (Rtyp = Universal_Integer) |
| then |
| Etyp := Standard_Long_Long_Integer; |
| |
| if Ovflo then |
| Rent := RE_Exp_Long_Long_Integer; |
| else |
| Rent := RE_Exn_Long_Long_Integer; |
| end if; |
| |
| elsif Is_Signed_Integer_Type (Rtyp) then |
| Etyp := Standard_Integer; |
| |
| if Ovflo then |
| Rent := RE_Exp_Integer; |
| else |
| Rent := RE_Exn_Integer; |
| end if; |
| |
| -- Floating-point cases, always done using Long_Long_Float. We do not |
| -- need separate routines for the overflow case here, since in the case |
| -- of floating-point, we generate infinities anyway as a rule (either |
| -- that or we automatically trap overflow), and if there is an infinity |
| -- generated and a range check is required, the check will fail anyway. |
| |
| else |
| pragma Assert (Is_Floating_Point_Type (Rtyp)); |
| Etyp := Standard_Long_Long_Float; |
| Rent := RE_Exn_Long_Long_Float; |
| end if; |
| |
| -- Common processing for integer cases and floating-point cases. |
| -- If we are in the right type, we can call runtime routine directly |
| |
| if Typ = Etyp |
| 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 is |
| -- typed using one of the standard types. |
| |
| else |
| Rewrite (N, |
| Convert_To (Typ, |
| Make_Function_Call (Loc, |
| Name => New_Reference_To (RTE (Rent), Loc), |
| Parameter_Associations => New_List ( |
| Convert_To (Etyp, Base), |
| Exp)))); |
| end if; |
| |
| Analyze_And_Resolve (N, Typ); |
| return; |
| |
| exception |
| when RE_Not_Available => |
| 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 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); |
| |
| -- If we still have comparison, and Vax_Float type, process it |
| |
| if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then |
| Expand_Vax_Comparison (N); |
| return; |
| end if; |
| 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 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); |
| |
| -- If we still have comparison, and Vax_Float type, process it |
| |
| if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then |
| Expand_Vax_Comparison (N); |
| return; |
| end if; |
| 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 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); |
| |
| -- If we still have comparison, and Vax_Float type, process it |
| |
| if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then |
| Expand_Vax_Comparison (N); |
| return; |
| end if; |
| 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 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); |
| |
| -- If we still have comparison, and Vax_Float type, process it |
| |
| if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then |
| Expand_Vax_Comparison (N); |
| return; |
| end if; |
| 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 not Backend_Overflow_Checks_On_Target |
| 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); |
| Typ : constant Entity_Id := Etype (N); |
| Left : constant Node_Id := Left_Opnd (N); |
| Right : constant Node_Id := Right_Opnd (N); |
| DOC : constant Boolean := Do_Overflow_Check (N); |
| DDC : constant Boolean := Do_Division_Check (N); |
| |
| 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, Typ); |
| Set_Do_Overflow_Check (N, DOC); |
| Set_Do_Division_Check (N, DDC); |
| Expand_N_Op_Rem (N); |
| Set_Analyzed (N); |
| |
| -- Otherwise, normal mod processing |
| |
| else |
| if Is_Integer_Type (Etype (N)) then |
| Apply_Divide_Check (N); |
| end if; |
| |
| -- Apply optimization x mod 1 = 0. We don't really need that with |
| -- gcc, but it is useful with other back ends (e.g. AAMP), and is |
| -- certainly harmless. |
| |
| if Is_Integer_Type (Etype (N)) |
| and then Compile_Time_Known_Value (Right) |
| and then Expr_Value (Right) = Uint_1 |
| then |
| Rewrite (N, Make_Integer_Literal (Loc, 0)); |
| Analyze_And_Resolve (N, Typ); |
| return; |
| 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. |
| |
| -- The operand type may be private (e.g. in the expansion of an |
| -- an intrinsic operation) so we must use the underlying type to |
| -- get the bounds, and convert the literals explicitly. |
| |
| LLB := |
| Expr_Value |
| (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); |
| |
| if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) |
| and then |
| ((not LOK) or else (Llo = LLB)) |
| then |
| Rewrite (N, |
| Make_Conditional_Expression (Loc, |
| Expressions => New_List ( |
| Make_Op_Eq (Loc, |
| Left_Opnd => Duplicate_Subexpr (Right), |
| Right_Opnd => |
| Unchecked_Convert_To (Typ, |
| Make_Integer_Literal (Loc, -1))), |
| Unchecked_Convert_To (Typ, |
| Make_Integer_Literal (Loc, Uint_0)), |
| Relocate_Node (N)))); |
| |
| Set_Analyzed (Next (Next (First (Expressions (N))))); |
| Analyze_And_Resolve (N, Typ); |
| 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); |
| |
| Lp2 : constant Boolean := |
| Nkind (Lop) = N_Op_Expon |
| and then Is_Power_Of_2_For_Shift (Lop); |
| |
| Rp2 : constant Boolean := |
| Nkind (Rop) = N_Op_Expon |
| and then Is_Power_Of_2_For_Shift (Rop); |
| |
| 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 (Rop) |
| and then Expr_Value (Rop) = Uint_0) |
| or else |
| (Compile_Time_Known_Value (Lop) |
| and then Expr_Value (Lop) = 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 |
| |
| -- This optimisation is not done if we are going to |
| -- rewrite the product 1 * 2 ** N to a shift. |
| |
| if Compile_Time_Known_Value (Rop) |
| and then Expr_Value (Rop) = Uint_1 |
| and then not Lp2 |
| then |
| Rewrite (N, Lop); |
| return; |
| |
| elsif Compile_Time_Known_Value (Lop) |
| and then Expr_Value (Lop) = Uint_1 |
| and then not Rp2 |
| then |
| Rewrite (N, Rop); |
| return; |
| end if; |
| 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 Rp2 then |
| if Lp2 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 Lp2 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); |
| |
| -- Deal with VAX float case |
| |
| elsif Vax_Float (Typ) then |
| Expand_Vax_Arith (N); |
| return; |
| end if; |
| end Expand_N_Op_Multiply; |
| |
| -------------------- |
| -- Expand_N_Op_Ne -- |
| -------------------- |
| |
| procedure Expand_N_Op_Ne (N : Node_Id) is |
| Typ : constant Entity_Id := Etype (Left_Opnd (N)); |
| |
| begin |
| -- Case of elementary type with standard operator |
| |
| if Is_Elementary_Type (Typ) |
| and then Sloc (Entity (N)) = Standard_Location |
| then |
| Binary_Op_Validity_Checks (N); |
| |
| -- Boolean types (requiring handling of non-standard case) |
| |
| if Is_Boolean_Type (Typ) then |
| Adjust_Condition (Left_Opnd (N)); |
| Adjust_Condition (Right_Opnd (N)); |
| Set_Etype (N, Standard_Boolean); |
| Adjust_Result_Type (N, Typ); |
| end if; |
| |
| Rewrite_Comparison (N); |
| |
| -- If we still have comparison for Vax_Float, process it |
| |
| if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare then |
| Expand_Vax_Comparison (N); |
| return; |
| end if; |
| |
| -- For all cases other than elementary types, we 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. This |
| -- signature must be set explicitly since in an instance it may not have |
| -- the same visibility as in the generic unit. This avoids duplicating |
| -- or factoring the complex code for record/array equality tests etc. |
| |
| else |
| declare |
| 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; |
| |
| -- For navigation purposes, the inequality is treated as an |
| -- implicit reference to the corresponding equality. Preserve the |
| -- Comes_From_ source flag so that the proper Xref entry is |
| -- generated. |
| |
| Preserve_Comes_From_Source (Neg, N); |
| Preserve_Comes_From_Source (Right_Opnd (Neg), N); |
| Rewrite (N, Neg); |
| Analyze_And_Resolve (N, Standard_Boolean); |
| end; |
| end if; |
| 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 with a component size of 1, |
| -- handle it in Exp_Pakd if the operand is known to be aligned. |
| |
| if Is_Bit_Packed_Array (Typ) |
| and then Component_Size (Typ) = 1 |
| and then not Is_Possibly_Unaligned_Object (Right_Opnd (N)) |
| then |
| Expand_Packed_Not (N); |
| return; |
| end if; |
| |
| -- Case of array operand which is not bit-packed. If the context is |
| -- a safe assignment, call in-place operation, If context is a larger |
| -- boolean expression in the context of a safe assignment, expansion is |
| -- done by enclosing operation. |
| |
| Opnd := Relocate_Node (Right_Opnd (N)); |
| Convert_To_Actual_Subtype (Opnd); |
| Arr := Etype (Opnd); |
| Ensure_Defined (Arr, N); |
| |
| if Nkind (Parent (N)) = N_Assignment_Statement then |
| if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then |
| Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); |
| return; |
| |
| -- Special case the negation of a binary operation |
| |
| elsif (Nkind (Opnd) = N_Op_And |
| or else Nkind (Opnd) = N_Op_Or |
| or else Nkind (Opnd) = N_Op_Xor) |
| and then Safe_In_Place_Array_Op |
| (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd)) |
| then |
| Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty); |
| return; |
| end if; |
| |
| elsif Nkind (Parent (N)) in N_Binary_Op |
| and then Nkind (Parent (Parent (N))) = N_Assignment_Statement |
| then |
| declare |
| Op1 : constant Node_Id := Left_Opnd (Parent (N)); |
| Op2 : constant Node_Id := Right_Opnd (Parent (N)); |
| Lhs : constant Node_Id := Name (Parent (Parent (N))); |
| |
| begin |
| if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then |
| if N = Op1 |
| and then Nkind (Op2) = N_Op_Not |
| then |
| -- (not A) op (not B) can be reduced to a single call |
| |
| return; |
| |
| elsif N = Op2 |
| and then Nkind (Parent (N)) = N_Op_Xor |
| then |
| -- A xor (not B) can also be special-cased |
| |
| return; |
| end if; |
| end if; |
| end; |
| end if; |
| |
| 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))), |
| Result_Definition => 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); |
| Typ : constant Entity_Id := Etype (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; |
| |
| begin |
| Binary_Op_Validity_Checks (N); |
| |
| if Is_Integer_Type (Etype (N)) then |
| Apply_Divide_Check (N); |
| end if; |
| |
| -- Apply optimization x rem 1 = 0. We don't really need that with |
| -- gcc, but it is useful with other back ends (e.g. AAMP), and is |
| -- certainly harmless. |
| |
| if Is_Integer_Type (Etype (N)) |
| and then Compile_Time_Known_Value (Right) |
| and then Expr_Value (Right) = Uint_1 |
| then |
| Rewrite (N, Make_Integer_Literal (Loc, 0)); |
| Analyze_And_Resolve (N, Typ); |
| return; |
| 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); |
| |
| -- The operand type may be private (e.g. in the expansion of an |
| -- an intrinsic operation) so we must use the underlying type to |
| -- get the bounds, and convert the literals explicitly. |
| |
| LLB := |
| Expr_Value |
| (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left))))); |
| |
| -- Now perform the test, generating code only if needed |
| |
| if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi)) |
| and then |
| ((not LOK) or else (Llo = LLB)) |
| then |
| Rewrite (N, |
| Make_Conditional_Expression (Loc, |
| Expressions => New_List ( |
| Make_Op_Eq (Loc, |
| Left_Opnd => Duplicate_Subexpr (Right), |
| Right_Opnd => |
| Unchecked_Convert_To (Typ, |
| Make_Integer_Literal (Loc, -1))), |
| |
| Unchecked_Convert_To (Typ, |
| Make_Integer_Literal (Loc, Uint_0)), |
| |
| Relocate_Node (N)))); |
| |
| 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); |
| end if; |
| |
| -- Check for cases of left argument is True or False |
| |
| if 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 |
| -- Do validity check if validity checking operands |
| |
| if Validity_Checks_On |
| and then Validity_Check_Operands |
| then |
| Ensure_Valid (Operand); |
| end if; |
| |
| -- Apply possible constraint check |
| |
| 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); |
| Ptyp : Entity_Id := Underlying_Type (Etype (P)); |
| Disc : Entity_Id; |
| New_N : Node_Id; |
| Dcon : Elmt_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. |
| -- Don't we have a general routine that does this??? |
| |
| ----------------------- |
| -- In_Left_Hand_Side -- |
| ----------------------- |
| |
| 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; |
| |
| -- Start of processing for Expand_N_Selected_Component |
| |
| begin |
| -- Insert explicit dereference if required |
| |
| if Is_Access_Type (Ptyp) then |
| Insert_Explicit_Dereference (P); |
| Analyze_And_Resolve (P, Designated_Type (Ptyp)); |
| |
| if Ekind (Etype (P)) = E_Private_Subtype |
| and then Is_For_Access_Subtype (Etype (P)) |
| then |
| Set_Etype (P, Base_Type (Etype (P))); |
| end if; |
| |
| Ptyp := Etype (P); |
| end if; |
| |
| -- Deal with discriminant check required |
| |
| 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))))); |
| |
| -- Now reset the flag and generate the call |
| |
| Set_Do_Discriminant_Check (N, False); |
| Generate_Discriminant_Check (N); |
| 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, then we cannot force the evaluation. |
| |
| 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, |
| -- we may be able to rewrite the expression with the actual value |
| -- of the discriminant, a useful optimization in some cases. |
| |
| if Is_Record_Type (Ptyp) |
| and then Has_Discriminants (Ptyp) |
| and then Is_Constrained (Ptyp) |
| then |
| -- Do this optimization for discrete types only, and not for |
| -- access types (access discriminants get us into trouble!) |
| |
| if not Is_Discrete_Type (Etype (N)) then |
| null; |
| |
| -- Don't do this on the left hand of an assignment statement. |
| -- Normally one would think that references like this would |
| -- not occur, but they do in generated code, and mean that |
| -- we really do want to assign the discriminant! |
| |
| elsif Nkind (Par) = N_Assignment_Statement |
| and then Name (Par) = N |
| then |
| null; |
| |
| -- Don't do this optimization for the prefix of an attribute |
| -- or the operand of an object renaming declaration since these |
| -- are contexts where we do not want the value anyway. |
| |
| elsif (Nkind (Par) = N_Attribute_Reference |
| and then Prefix (Par) = N) |
| or else Is_Renamed_Object (N) |
| then |
| null; |
| |
| -- Don't do this optimization if we are within the code for a |
| -- discriminant check, since the whole point of such a check may |
| -- be to verify the condition on which the code below depends! |
| |
| elsif Is_In_Discriminant_Check (N) then |
| null; |
| |
| -- Green light to see if we can do the optimization. There is |
| -- still one condition that inhibits the optimization below |
| -- but now is the time to check the particular discriminant. |
| |
| else |
| -- Loop through discriminants to find the matching |
| -- discriminant constraint to see if we can copy it. |
| |
| Disc := First_Discriminant (Ptyp); |
| Dcon := First_Elmt (Discriminant_Constraint (Ptyp)); |
| Discr_Loop : while Present (Dcon) loop |
| |
| -- Check if this is the matching discriminant |
| |
| if Disc = Entity (Selector_Name (N)) then |
| |
| -- Here we have the matching discriminant. Check for |
| -- the case of a discriminant of a component that is |
| -- constrained by an outer discriminant, which cannot |
| -- be optimized away. |
| |
| if |
| Denotes_Discriminant |
| (Node (Dcon), Check_Protected => True) |
| then |
| exit Discr_Loop; |
| |
| -- 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. |
| |
| elsif Nkind (Parent (N)) = N_Case_Statement |
| and then Etype (Node (Dcon)) /= Etype (Disc) |
| then |
| Rewrite (N, |
| Make_Qualified_Expression (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Etype (Disc), Loc), |
| Expression => |
| New_Copy_Tree (Node (Dcon)))); |
| Analyze_And_Resolve (N, Etype (Disc)); |
| |
| -- In case that comes out as a static expression, |
| -- reset it (a selected component is never static). |
| |
| Set_Is_Static_Expression (N, False); |
| return; |
| |
| -- Otherwise we can just copy the constraint, but the |
| -- result is certainly not static! In some cases the |
| -- discriminant constraint has been analyzed in the |
| -- context of the original subtype indication, but for |
| -- itypes the constraint might not have been analyzed |
| -- yet, and this must be done now. |
| |
| else |
| Rewrite (N, New_Copy_Tree (Node (Dcon))); |
| Analyze_And_Resolve (N); |
| Set_Is_Static_Expression (N, False); |
| return; |
| end if; |
| end if; |
| |
| Next_Elmt (Dcon); |
| Next_Discriminant (Disc); |
| end loop Discr_Loop; |
| |
| -- Note: the above loop should always find a matching |
| -- discriminant, but if it does not, we just missed an |
| -- optimization due to some glitch (perhaps a previous |
| -- error), so ignore. |
| |
| end if; |
| 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); |
| |
| function Is_Procedure_Actual (N : Node_Id) return Boolean; |
| -- Check whether the argument is an actual for a procedure call, |
| -- in which case the expansion of a bit-packed slice is deferred |
| -- until the call itself is expanded. The reason this is required |
| -- is that we might have an IN OUT or OUT parameter, and the copy out |
| -- is essential, and that copy out would be missed if we created a |
| -- temporary here in Expand_N_Slice. Note that we don't bother |
| -- to test specifically for an IN OUT or OUT mode parameter, since it |
| -- is a bit tricky to do, and it is harmless to defer expansion |
| -- in the IN case, since the call processing will still generate the |
| -- appropriate copy in operation, which will take care of the slice. |
| |
| procedure Make_Temporary; |
| -- Create a named variable for the value of the slice, in |
| -- cases where the back-end cannot handle it properly, e.g. |
| -- when packed types or unaligned slices are involved. |
| |
| ------------------------- |
| -- Is_Procedure_Actual -- |
| ------------------------- |
| |
| function Is_Procedure_Actual (N : Node_Id) return Boolean is |
| Par : Node_Id := Parent (N); |
| |
| begin |
| loop |
| -- If our parent is a procedure call we can return |
| |
| if Nkind (Par) = N_Procedure_Call_Statement then |
| return True; |
| |
| -- If our parent is a type conversion, keep climbing the |
| -- tree, since a type conversion can be a procedure actual. |
| -- Also keep climbing if parameter association or a qualified |
| -- expression, since these are additional cases that do can |
| -- appear on procedure actuals. |
| |
| elsif Nkind (Par) = N_Type_Conversion |
| or else Nkind (Par) = N_Parameter_Association |
| or else Nkind (Par) = N_Qualified_Expression |
| then |
| Par := Parent (Par); |
| |
| -- Any other case is not what we are looking for |
| |
| else |
| return False; |
| end if; |
| end loop; |
| end Is_Procedure_Actual; |
| |
| -------------------- |
| -- Make_Temporary -- |
| -------------------- |
| |
| procedure Make_Temporary is |
| Decl : Node_Id; |
| Ent : constant Entity_Id := |
| Make_Defining_Identifier (Loc, New_Internal_Name ('T')); |
| begin |
| 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 Make_Temporary; |
| |
| -- Start of processing for Expand_N_Slice |
| |
| begin |
| -- Special handling for access types |
| |
| if Is_Access_Type (Ptp) then |
| |
| Ptp := Designated_Type (Ptp); |
| |
| Rewrite (Pfx, |
| Make_Explicit_Dereference (Sloc (N), |
| Prefix => Relocate_Node (Pfx))); |
| |
| Analyze_And_Resolve (Pfx, Ptp); |
| 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 not Is_Packed (Typ) then |
| |
| -- Apply transformation for actuals of a function call, |
| -- where Expand_Actuals is not used. |
| |
| if Nkind (Parent (N)) = N_Function_Call |
| and then Is_Possibly_Unaligned_Slice (N) |
| then |
| Make_Temporary; |
| end if; |
| |
| elsif Nkind (Parent (N)) = N_Assignment_Statement |
| or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement |
| and then Parent (N) = Name (Parent (Parent (N)))) |
| then |
| return; |
| |
| elsif Nkind (Parent (N)) = N_Indexed_Component |
| or else Is_Renamed_Object (N) |
| or else Is_Procedure_Actual (N) |
| then |
| return; |
| |
| elsif Nkind (Parent (N)) = N_Attribute_Reference |
| and then Attribute_Name (Parent (N)) = Name_Address |
| then |
| return; |
| |
| else |
| Make_Temporary; |
| 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 else 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); |
| |
| if Disc /= First_Stored_Discriminant (Operand_Type) then |
| Disc := First_Stored_Discriminant (Operand_Type); |
| end if; |
| |
| Cons := New_List; |
| while Present (Disc) loop |
| Append_To (Cons, |
| Make_Selected_Component (Loc, |
| Prefix => Duplicate_Subexpr_Move_Checks (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_No_Checks |
| (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_No_Checks |
| (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 |
| |
| -- This is necessary when there is a conversion of integer to float |
| -- or to fixed-point to ensure that the correct checks are made. It |
| -- is not necessary for float to float where it is enough to simply |
| -- set the Do_Range_Check flag. |
| |
| 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); |
| Xtyp : constant Entity_Id := Etype (Operand); |
| 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 (Operand) |
| and then Range_Checks_Suppressed (Entity (Operand)) |
| then |
| return; |
| end if; |
| |
| -- Nothing to do if bounds are all static and we can tell that |
| -- the expression is within the bounds of the target. Note that |
| -- if the operand is of an unconstrained floating-point type, |
| -- then we do not trust it to be in range (might be infinite) |
| |
| declare |
| S_Lo : constant Node_Id := Type_Low_Bound (Xtyp); |
| S_Hi : constant Node_Id := Type_High_Bound (Xtyp); |
| |
| begin |
| if (not Is_Floating_Point_Type (Xtyp) |
| or else Is_Constrained (Xtyp)) |
| and then Compile_Time_Known_Value (S_Lo) |
| and then Compile_Time_Known_Value (S_Hi) |
| and then Compile_Time_Known_Value (Hi) |
| and then Compile_Time_Known_Value (Lo) |
| then |
| declare |
| D_Lov : constant Ureal := Expr_Value_R (Lo); |
| D_Hiv : constant Ureal := Expr_Value_R (Hi); |
| S_Lov : Ureal; |
| S_Hiv : Ureal; |
| |
| begin |
| if Is_Real_Type (Xtyp) then |
| S_Lov := Expr_Value_R (S_Lo); |
| S_Hiv := Expr_Value_R (S_Hi); |
| else |
| S_Lov := UR_From_Uint (Expr_Value (S_Lo)); |
| S_Hiv := UR_From_Uint (Expr_Value (S_Hi)); |
| end if; |
| |
| if D_Hiv > D_Lov |
| and then S_Lov >= D_Lov |
| and then S_Hiv <= D_Hiv |
| then |
| Set_Do_Range_Check (Operand, False); |
| return; |
| end if; |
| end; |
| end if; |
| end; |
| |
| -- For float to float conversions, we are done |
| |
| if Is_Floating_Point_Type (Xtyp) |
| and then |
| Is_Floating_Point_Type (Btyp) |
| then |
| return; |
| end if; |
| |
| -- Otherwise rewrite the conversion as described above |
| |
| Conv := Relocate_Node (N); |
| Rewrite |
| (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc)); |
| Set_Etype (Conv, Btyp); |
| |
| -- Enable overflow except for case of integer to float conversions, |
| -- where it is never required, since we can never have overflow in |
| -- this case. |
| |
| if not Is_Integer_Type (Etype (Operand)) then |
| Enable_Overflow_Check (Conv); |
| 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)))), |
| Reason => CE_Range_Check_Failed))); |
| |
| 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 (Operand)); |
| 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 |
| |
| -- Do validity check if validity checking operands |
| |
| if Validity_Checks_On |
| and then Validity_Check_Operands |
| then |
| Ensure_Valid (Operand); |
| end if; |
| |
| -- 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), |
| Reason => PE_Accessibility_Check_Failed)); |
| 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), |
| Reason => PE_Accessibility_Check_Failed)); |
| 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_No_Checks (Operand), |
| Right_Opnd => Make_Null (Loc)), |
| |
| Right_Opnd => |
| Make_Not_In (Loc, |
| Left_Opnd => |
| Make_Explicit_Dereference (Loc, |
| Prefix => |
| Duplicate_Subexpr_No_Checks (Operand)), |
| Right_Opnd => |
| New_Reference_To (Actual_Target_Type, Loc))); |
| |
| else |
| Cond := |
| Make_Not_In (Loc, |
| Left_Opnd => Duplicate_Subexpr_No_Checks (Operand), |
| Right_Opnd => |
| New_Reference_To (Actual_Target_Type, Loc)); |
| end if; |
| |
| Insert_Action (N, |
| Make_Raise_Constraint_Error (Loc, |
| Condition => Cond, |
| Reason => CE_Tag_Check_Failed)); |
| |
| declare |
| Conv : Node_Id; |
| begin |
| Conv := |
| Make_Unchecked_Type_Conversion (Loc, |
| Subtype_Mark => New_Occurrence_Of (Target_Type, Loc), |
| Expression => Relocate_Node (Expression (N))); |
| Rewrite (N, Conv); |
| Analyze_And_Resolve (N, Target_Type); |
| end; |
| 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 Universal_Real is |
| -- helpful, but still does not catch all cases with 64-bit integers |
| -- on targets with only 64-bit floats ??? |
| |
| if Do_Range_Check (Operand) then |
| Rewrite (Operand, |
| Make_Type_Conversion (Loc, |
| Subtype_Mark => |
| New_Occurrence_Of (Universal_Real, Loc), |
| Expression => |
| Relocate_Node (Operand))); |
| |
| Set_Etype (Operand, Universal_Real); |
| Enable_Range_Check (Operand); |
| Set_Do_Range_Check (Expression (Operand), 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 |
| |
| -- Ada 2005 (AI-216): Program_Error is raised when converting from |
| -- a derived Unchecked_Union type to an unconstrained non-Unchecked_ |
| -- Union type if the operand lacks inferable discriminants. |
| |
| if Is_Derived_Type (Operand_Type) |
| and then Is_Unchecked_Union (Base_Type (Operand_Type)) |
| and then not Is_Constrained (Target_Type) |
| and then not Is_Unchecked_Union (Base_Type (Target_Type)) |
| and then not Has_Inferable_Discriminants (Operand) |
| then |
| -- To prevent Gigi from generating illegal code, we make a |
| -- Program_Error node, but we give it the target type of the |
| -- conversion. |
| |
| declare |
| PE : constant Node_Id := Make_Raise_Program_Error (Loc, |
| Reason => PE_Unchecked_Union_Restriction); |
| |
| begin |
| Set_Etype (PE, Target_Type); |
| Rewrite (N, PE); |
| |
| end; |
| else |
| Handle_Changed_Representation; |
| end if; |
| |
| -- 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; |
| 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 |
| |
| -- Check: are these rules stated in sinfo??? if so, why restate here??? |
| |
| -- The only remaining step is to generate a range check if we still |
| -- have a type conversion at this stage and Do_Range_Check is set. |
| -- For now we do this only for conversions of discrete types. |
| |
| if Nkind (N) = N_Type_Conversion |
| and then Is_Discrete_Type (Etype (N)) |
| then |
| declare |
| Expr : constant Node_Id := Expression (N); |
| Ftyp : Entity_Id; |
| Ityp : Entity_Id; |
| |
| begin |
| if Do_Range_Check (Expr) |
| and then Is_Discrete_Type (Etype (Expr)) |
| then |
| Set_Do_Range_Check (Expr, False); |
| |
| -- Before we do a range check, we have to deal with treating |
| -- a fixed-point operand as an integer. The way we do this |
| -- is simply to do an unchecked conversion to an appropriate |
| -- integer type large enough to hold the result. |
| |
| -- This code is not active yet, because we are only dealing |
| -- with discrete types so far ??? |
| |
| if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer |
| and then Treat_Fixed_As_Integer (Expr) |
| then |
| Ftyp := Base_Type (Etype (Expr)); |
| |
| if Esize (Ftyp) >= Esize (Standard_Integer) then |
| Ityp := Standard_Long_Long_Integer; |
| else |
| Ityp := Standard_Integer; |
| end if; |
| |
| Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr)); |
| end if; |
| |
| -- Reset overflow flag, since the range check will include |
| -- dealing with possible overflow, and generate the check |
| -- If Address is either source or target type, suppress |
| -- range check to avoid typing anomalies when it is a visible |
| -- integer type. |
| |
| Set_Do_Overflow_Check (N, False); |
| if not Is_Descendent_Of_Address (Etype (Expr)) |
| and then not Is_Descendent_Of_Address (Target_Type) |
| then |
| Generate_Range_Check |
| (Expr, Target_Type, CE_Range_Check_Failed); |
| end if; |
| end if; |
| end; |
| end if; |
| |
| -- Final step, if the result is a type conversion involving Vax_Float |
| -- types, then it is subject for further special processing. |
| |
| if Nkind (N) = N_Type_Conversion |
| and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type)) |
| then |
| Expand_Vax_Conversion (N); |
| return; |
| end if; |
| 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)); |
| |
| -- If Address is the target type, just set the type |
| -- to avoid a spurious type error on the literal when |
| -- Address is a visible integer type. |
| |
| if Is_Descendent_Of_Address (Target_Type) then |
| Set_Etype (N, Target_Type); |
| else |
| Analyze_And_Resolve (N, Target_Type); |
| end if; |
| |
| 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); |
| |
| Result : Node_Id; |
| C : Entity_Id; |
| |
| First_Time : Boolean := True; |
| |
| function Suitable_Element (C : Entity_Id) return Entity_Id; |
| -- Return the first field to compare beginning with C, skipping the |
| -- inherited components. |
| |
| ---------------------- |
| -- Suitable_Element -- |
| ---------------------- |
| |
| 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; |
| |
| -- Start of processing for Expand_Record_Equality |
| |
| begin |
| -- 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; |
| Check : 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; |
| |
| Check := |
| 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); |
| |
| -- If some (sub)component is an unchecked_union, the whole |
| -- operation will raise program error. |
| |
| if Nkind (Check) = N_Raise_Program_Error then |
| Result := Check; |
| Set_Etype (Result, Standard_Boolean); |
| exit; |
| else |
| Result := |
| Make_And_Then (Loc, |
| Left_Opnd => Result, |
| Right_Opnd => Check); |
| end if; |
| 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; |
| |
| ------------------------------ |
| -- Get_Allocator_Final_List -- |
| ------------------------------ |
| |
| function Get_Allocator_Final_List |
| (N : Node_Id; |
| T : Entity_Id; |
| PtrT : Entity_Id) return Entity_Id |
| is |
| Loc : constant Source_Ptr := Sloc (N); |
| |
| Owner : Entity_Id := PtrT; |
| -- The entity whose finalisation list must be used to attach the |
| -- allocated object. |
| |
| begin |
| if Ekind (PtrT) = E_Anonymous_Access_Type then |
| if Nkind (Associated_Node_For_Itype (PtrT)) |
| in N_Subprogram_Specification |
| 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. The Final_Chain |
| -- that is thus created is shared by the access parameter. |
| |
| Owner := Make_Defining_Identifier (Loc, New_Internal_Name ('J')); |
| Insert_Action (N, |
| Make_Full_Type_Declaration (Loc, |
| Defining_Identifier => Owner, |
| Type_Definition => |
| Make_Access_To_Object_Definition (Loc, |
| Subtype_Indication => |
| New_Occurrence_Of (T, Loc)))); |
| |
| Build_Final_List (N, Owner); |
| Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner)); |
| |
| else |
| -- Case of an access discriminant, or (Ada 2005) of |
| -- an anonymous access component: find the final list |
| -- associated with the scope of the type. |
| |
| Owner := Scope (PtrT); |
| end if; |
| end if; |
| |
| return Find_Final_List (Owner); |
| end Get_Allocator_Final_List; |
| |
| --------------------------------- |
| -- Has_Inferable_Discriminants -- |
| --------------------------------- |
| |
| function Has_Inferable_Discriminants (N : Node_Id) return Boolean is |
| |
| function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; |
| -- Determines whether the left-most prefix of a selected component is a |
| -- formal parameter in a subprogram. Assumes N is a selected component. |
| |
| -------------------------------- |
| -- Prefix_Is_Formal_Parameter -- |
| -------------------------------- |
| |
| function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is |
| Sel_Comp : Node_Id := N; |
| |
| begin |
| -- Move to the left-most prefix by climbing up the tree |
| |
| while Present (Parent (Sel_Comp)) |
| and then Nkind (Parent (Sel_Comp)) = N_Selected_Component |
| loop |
| Sel_Comp := Parent (Sel_Comp); |
| end loop; |
| |
| return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; |
| end Prefix_Is_Formal_Parameter; |
| |
| -- Start of processing for Has_Inferable_Discriminants |
| |
| begin |
| -- For identifiers and indexed components, it is sufficent to have a |
| -- constrained Unchecked_Union nominal subtype. |
| |
| if Nkind (N) = N_Identifier |
| or else |
| Nkind (N) = N_Indexed_Component |
| then |
| return Is_Unchecked_Union (Base_Type (Etype (N))) |
| and then |
| Is_Constrained (Etype (N)); |
| |
| -- For selected components, the subtype of the selector must be a |
| -- constrained Unchecked_Union. If the component is subject to a |
| -- per-object constraint, then the enclosing object must have inferable |
| -- discriminants. |
| |
| elsif Nkind (N) = N_Selected_Component then |
| if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then |
| |
| -- A small hack. If we have a per-object constrained selected |
| -- component of a formal parameter, return True since we do not |
| -- know the actual parameter association yet. |
| |
| if Prefix_Is_Formal_Parameter (N) then |
| return True; |
| end if; |
| |
| -- Otherwise, check the enclosing object and the selector |
| |
| return Has_Inferable_Discriminants (Prefix (N)) |
| and then |
| Has_Inferable_Discriminants (Selector_Name (N)); |
| end if; |
| |
| -- The call to Has_Inferable_Discriminants will determine whether |
| -- the selector has a constrained Unchecked_Union nominal type. |
| |
| return Has_Inferable_Discriminants (Selector_Name (N)); |
| |
| -- A qualified expression has inferable discriminants if its subtype |
| -- mark is a constrained Unchecked_Union subtype. |
| |
| elsif Nkind (N) = N_Qualified_Expression then |
| return Is_Unchecked_Union (Subtype_Mark (N)) |
| and then |
| Is_Constrained (Subtype_Mark (N)); |
| |
| end if; |
| |
| return False; |
| end Has_Inferable_Discriminants; |
| |
| ------------------------------- |
| -- 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); |
| Pnod : constant Node_Id := Parent (N); |
| |
| function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; |
| -- Return true if type of P is derived from Checked_Pool; |
| |
| ----------------------------- |
| -- Is_Checked_Storage_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 |
| pragma Assert (Nkind (Pnod) = N_Explicit_Dereference); |
| |
| if not (Is_Checked_Storage_Pool (Pool) |
| and then Comes_From_Source (Original_Node (Pnod))) |
| 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. We use the attribute Pool_Address, |
| -- which uses the pointer itself to find the address of |
| -- the object, and which handles unconstrained arrays |
| -- properly by computing the address of the template. |
| -- i.e. the correct address of the corresponding allocation. |
| |
| Make_Attribute_Reference (Loc, |
| Prefix => Duplicate_Subexpr_Move_Checks (N), |
| Attribute_Name => Name_Pool_Address), |
| |
| -- Size_In_Storage_Elements |
| |
| Make_Op_Divide (Loc, |
| Left_Opnd => |
| Make_Attribute_Reference (Loc, |
| Prefix => |
| Make_Explicit_Dereference (Loc, |
| Duplicate_Subexpr_Move_Checks (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_Move_Checks (N)), |
| Attribute_Name => Name_Alignment)))); |
| |
| exception |
| when RE_Not_Available => |
| return; |
| 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, |
| Result_Definition => 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, |
| Result_Definition => 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 |
| begin |
| if Nkind (N) = N_Type_Conversion then |
| Rewrite_Comparison (Expression (N)); |
| |
| elsif Nkind (N) not in N_Op_Compare then |
| null; |
| |
| else |
| declare |
| 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 compile time determined |
| |
| 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; |
| |
| if Res = LE |
| and then Constant_Condition_Warnings |
| and then Comes_From_Source (Original_Node (N)) |
| and then Nkind (Original_Node (N)) = N_Op_Ge |
| and then not In_Instance |
| and then not Warnings_Off (Etype (Left_Opnd (N))) |
| and then Is_Integer_Type (Etype (Left_Opnd (N))) |
| then |
| Error_Msg_N |
| ("can never be greater than, could replace by ""'=""?", N); |
| end if; |
| |
| 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; |
| |
| if Res = GE |
| and then Constant_Condition_Warnings |
| and then Comes_From_Source (Original_Node (N)) |
| and then Nkind (Original_Node (N)) = N_Op_Le |
| and then not In_Instance |
| and then not Warnings_Off (Etype (Left_Opnd (N))) |
| and then Is_Integer_Type (Etype (Left_Opnd (N))) |
| then |
| Error_Msg_N |
| ("can never be less than, could replace by ""'=""?", N); |
| end if; |
| |
| when N_Op_Ne => |
| True_Result := Res = NE or else Res = GT or else Res = LT; |
| False_Result := 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); |
| Warn_On_Known_Condition (N); |
| |
| elsif False_Result then |
| Rewrite (N, |
| Convert_To (Typ, |
| New_Occurrence_Of (Standard_False, Sloc (N)))); |
| Analyze_And_Resolve (N, Typ); |
| Warn_On_Known_Condition (N); |
| end if; |
| end; |
| end if; |
| end Rewrite_Comparison; |
| |
| ---------------------------- |
| -- Safe_In_Place_Array_Op -- |
| ---------------------------- |
| |
| function Safe_In_Place_Array_Op |
| (Lhs : Node_Id; |
| Op1 : Node_Id; |
| Op2 : Node_Id) return Boolean |
| is |
| Target : Entity_Id; |
| |
| function Is_Safe_Operand (Op : Node_Id) return Boolean; |
| -- Operand is safe if it cannot overlap part of the target of the |
| -- operation. If the operand and the target are identical, the operand |
| -- is safe. The operand can be empty in the case of negation. |
| |
| function Is_Unaliased (N : Node_Id) return Boolean; |
| -- Check that N is a stand-alone entity |
| |
| ------------------ |
| -- Is_Unaliased -- |
| ------------------ |
| |
| function Is_Unaliased (N : Node_Id) return Boolean is |
| begin |
| return |
| Is_Entity_Name (N) |
| and then No (Address_Clause (Entity (N))) |
| and then No (Renamed_Object (Entity (N))); |
| end Is_Unaliased; |
| |
| --------------------- |
| -- Is_Safe_Operand -- |
| --------------------- |
| |
| function Is_Safe_Operand (Op : Node_Id) return Boolean is |
| begin |
| if No (Op) then |
| return True; |
| |
| elsif Is_Entity_Name (Op) then |
| return Is_Unaliased (Op); |
| |
| elsif Nkind (Op) = N_Indexed_Component |
| or else Nkind (Op) = N_Selected_Component |
| then |
| return Is_Unaliased (Prefix (Op)); |
| |
| elsif Nkind (Op) = N_Slice then |
| return |
| Is_Unaliased (Prefix (Op)) |
| and then Entity (Prefix (Op)) /= Target; |
| |
| elsif Nkind (Op) = N_Op_Not then |
| return Is_Safe_Operand (Right_Opnd (Op)); |
| |
| else |
| return False; |
| end if; |
| end Is_Safe_Operand; |
| |
| -- Start of processing for Is_Safe_In_Place_Array_Op |
| |
| begin |
| -- We skip this processing if the component size is not the |
| -- same as a system storage unit (since at least for NOT |
| -- this would cause problems). |
| |
| if Component_Size (Etype (Lhs)) /= System_Storage_Unit then |
| return False; |
| |
| -- Cannot do in place stuff on Java_VM since cannot pass addresses |
| |
| elsif Java_VM then |
| return False; |
| |
| -- Cannot do in place stuff if non-standard Boolean representation |
| |
| elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then |
| return False; |
| |
| elsif not Is_Unaliased (Lhs) then |
| return False; |
| else |
| Target := Entity (Lhs); |
| |
| return |
| Is_Safe_Operand (Op1) |
| and then Is_Safe_Operand (Op2); |
| end if; |
| end Safe_In_Place_Array_Op; |
| |
| ----------------------- |
| -- 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 (First_Tag_Component (Left_Type), Loc)); |
| |
| if Is_Class_Wide_Type (Right_Type) then |
| |
| -- Ada 2005 (AI-251): Class-wide applied to interfaces |
| |
| if Is_Interface (Etype (Class_Wide_Type (Right_Type))) |
| |
| -- Give support to: "Iface_CW_Typ in Typ'Class" |
| |
| or else Is_Interface (Left_Type) |
| then |
| -- Issue error if IW_Membership operation not available in a |
| -- configurable run time setting. |
| |
| if not RTE_Available (RE_IW_Membership) then |
| Error_Msg_CRT ("abstract interface types", N); |
| return Empty; |
| end if; |
| |
| return |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc), |
| Parameter_Associations => New_List ( |
| Make_Attribute_Reference (Loc, |
| Prefix => Obj_Tag, |
| Attribute_Name => Name_Address), |
| New_Reference_To ( |
| Node (First_Elmt |
| (Access_Disp_Table (Root_Type (Right_Type)))), |
| Loc))); |
| |
| -- Ada 95: Normal case |
| |
| else |
| return |
| Make_Function_Call (Loc, |
| Name => New_Occurrence_Of (RTE (RE_CW_Membership), Loc), |
| Parameter_Associations => New_List ( |
| Obj_Tag, |
| New_Reference_To ( |
| Node (First_Elmt |
| (Access_Disp_Table (Root_Type (Right_Type)))), |
| Loc))); |
| end if; |
| |
| else |
| return |
| Make_Op_Eq (Loc, |
| Left_Opnd => Obj_Tag, |
| Right_Opnd => |
| New_Reference_To |
| (Node (First_Elmt (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; |