CbC/CbC_gcc: gcc/ada/exp_ch4.adb comparison

comparison gcc/ada/exp_ch4.adb @ 131:84e7813d76e9

gcc-8.2

author	mir3636
date	Thu, 25 Oct 2018 07:37:49 +0900
parents	04ced10e8804
children	1830386684a0

comparison

equal deleted inserted replaced

-:04ced10e8804
+:84e7813d76e9
 --                                                                          --
 --                              E X P _ C H 4                               --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2017, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2018, 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 3,  or (at your option) any later ver- --
 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
 --  Finalize the object if applicable. Generate:
 --    [Deep_]Finalize (Obj_Ref.all);
-if Needs_Finalization (DesigT) then
+if Needs_Finalization (DesigT)
+and then not No_Heap_Finalization (PtrT)
+then
 Fin_Call :=
 Make_Final_Call
 (Obj_Ref =>
 Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
 Typ     => DesigT);
 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;
 function Find_Primitive_Eq return Node_Id;
 --  AI05-0123: Locate primitive equality for type if it exists, and
 --  build the corresponding call. If operation is abstract, replace
 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
+--  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);
+declare
+Comp_Typ : Entity_Id;
+Hi       : Node_Id;
+Indx     : Node_Id;
+Ityp     : Entity_Id;
+Lo       : Node_Id;
+begin
+--  Do the comparison in the type (or its full view) and not in
+--  its unconstrained base type, because the latter operation is
+--  more complex and would also require an unchecked conversion.
+if Is_Private_Type (Typ) then
+Comp_Typ := Underlying_Type (Typ);
+else
+Comp_Typ := Typ;
+end if;
+--  Except for the case where the bounds of the type depend on a
+--  discriminant, or else we would run into scoping issues.
+Indx := First_Index (Comp_Typ);
+while Present (Indx) loop
+Ityp := Etype (Indx);
+Lo := Type_Low_Bound (Ityp);
+Hi := Type_High_Bound (Ityp);
+if (Nkind (Lo) = N_Identifier
+and then Ekind (Entity (Lo)) = E_Discriminant)
+or else
+(Nkind (Hi) = N_Identifier
+and then Ekind (Entity (Hi)) = E_Discriminant)
+then
+Comp_Typ := Full_Type;
+exit;
+end if;
+Next_Index (Indx);
+end loop;
+return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Comp_Typ);
+end;
 end if;
 --  Case of tagged record types
 elsif Is_Tagged_Type (Full_Type) then
+Eq_Op := Find_Primitive_Eq (Typ);
---  Call the primitive operation "=" of this type
+pragma Assert (Present (Eq_Op));
-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_Occurrence_Of (Eq_Op, Loc),
 Parameter_Associations =>
 --  A tree node representing the high bound of the last operand. This
 --  need only be set if the result could be null. It is used for the
 --  special case of setting the right high bound for a null result.
 --  This is of type Ityp.
-High_Bound : Node_Id;
+High_Bound : Node_Id := Empty;
 --  A tree node representing the high bound of the result (of type Ityp)
 Result : Node_Id;
 --  Result of the concatenation (of type Ityp)
 Cond_Expr : constant Node_Id := New_Op_Node (N_Op_Lt, Loc);
 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
 Loc);
 begin
+--  To prevent spurious visibility issues, convert all
+--  operands to Standard.Unsigned.
 Set_Left_Opnd (Cond_Expr,
-New_Copy_Tree (Left_Opnd (N)));
+Unchecked_Convert_To (Standard_Unsigned,
+New_Copy_Tree (Left_Opnd (N))));
 Set_Right_Opnd (Cond_Expr,
 Make_Integer_Literal (Loc, Mod_Minus_Right));
 Append_To (Exprs, Cond_Expr);
 Set_Left_Opnd (Then_Expr,
 procedure Expand_Modular_Op is
 Op_Expr  : constant Node_Id := New_Op_Node (Nkind (N), Loc);
 Mod_Expr : constant Node_Id := New_Op_Node (N_Op_Mod, Loc);
+Target_Type   : Entity_Id;
 begin
 --  Convert nonbinary modular type operands into integer values. Thus
 --  we avoid never-ending loops expanding them, and we also ensure
 --  the back end never receives nonbinary modular type expressions.
-if Nkind_In (Nkind (N), N_Op_And, N_Op_Or) then
+if Nkind_In (Nkind (N), N_Op_And, N_Op_Or, N_Op_Xor) then
 Set_Left_Opnd (Op_Expr,
 Unchecked_Convert_To (Standard_Unsigned,
 New_Copy_Tree (Left_Opnd (N))));
 Set_Right_Opnd (Op_Expr,
 Unchecked_Convert_To (Standard_Unsigned,
 New_Copy_Tree (Right_Opnd (N))));
 Set_Left_Opnd (Mod_Expr,
 Unchecked_Convert_To (Standard_Integer, Op_Expr));
 else
+--  If the modulus of the type is larger than Integer'Last
+--  use a larger type for the operands, to prevent spurious
+--  constraint errors on large legal literals of the type.
+if Modulus (Etype (N)) > UI_From_Int (Int (Integer'Last)) then
+Target_Type := Standard_Long_Integer;
+else
+Target_Type := Standard_Integer;
+end if;
 Set_Left_Opnd (Op_Expr,
-Unchecked_Convert_To (Standard_Integer,
+Unchecked_Convert_To (Target_Type,
 New_Copy_Tree (Left_Opnd (N))));
 Set_Right_Opnd (Op_Expr,
-Unchecked_Convert_To (Standard_Integer,
+Unchecked_Convert_To (Target_Type,
 New_Copy_Tree (Right_Opnd (N))));
 --  Link this node to the tree to analyze it
 --  If the parent node is an expression with actions we link it to
 Then_Expr : constant Node_Id := New_Op_Node (N_Op_Add, Loc);
 Else_Expr : constant Node_Id := New_Op_Node (N_Op_Subtract,
 Loc);
 begin
 Set_Left_Opnd (Cond_Expr,
-New_Copy_Tree (Left_Opnd (N)));
+Unchecked_Convert_To (Standard_Unsigned,
+New_Copy_Tree (Left_Opnd (N))));
 Set_Right_Opnd (Cond_Expr,
 Make_Integer_Literal (Loc, Intval (Right_Opnd (N))));
 Append_To (Exprs, Cond_Expr);
 Set_Left_Opnd (Then_Expr,
 end Expand_Modular_Subtraction;
 --  Start of processing for Expand_Nonbinary_Modular_Op
 begin
---  No action needed if we are not generating C code for a nonbinary
+--  No action needed if front-end expansion is not required or if we
---  modular operand.
+--  have a binary modular operand.
-if not Modify_Tree_For_C
+if not Expand_Nonbinary_Modular_Ops
 or else not Non_Binary_Modulus (Typ)
 then
 return;
 end if;
 if Present (Pool) then
 Set_Storage_Pool (N, Pool);
 if Is_RTE (Pool, RE_SS_Pool) then
+Check_Restriction (No_Secondary_Stack, N);
 Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
 --  In the case of an allocator for a simple storage pool, locate
 --  and save a reference to the pool type's Allocate routine.
 Make_Integer_Literal (Loc, Uint_7 * (Uint_2 ** 29))),
 Reason    => SE_Object_Too_Large));
 end if;
 end if;
---  If no storage pool has been specified and we have the restriction
+--  If no storage pool has been specified, or the storage pool
+--  is System.Pool_Global.Global_Pool_Object, and the restriction
 --  No_Standard_Allocators_After_Elaboration is present, then generate
 --  a call to Elaboration_Allocators.Check_Standard_Allocator.
 if Nkind (N) = N_Allocator
-and then No (Storage_Pool (N))
+and then (No (Storage_Pool (N))
+or else Is_RTE (Storage_Pool (N), RE_Global_Pool_Object))
 and then Restriction_Active (No_Standard_Allocators_After_Elaboration)
 then
 Insert_Action (N,
 Make_Procedure_Call_Statement (Loc,
 Name =>
 --  that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
 --  for details). In addition, if the type T is a task type, then the
 --  first argument to Init must be converted to the task record type.
 declare
-T         : constant Entity_Id := Entity (Expression (N));
+T         : constant Entity_Id := Etype (Expression (N));
 Args      : List_Id;
 Decls     : List_Id;
 Decl      : Node_Id;
 Discr     : Elmt_Id;
 Init      : Entity_Id;
 if Present (Finalization_Master (PtrT)) then
 Build_Allocate_Deallocate_Proc
 (N           => N,
 Is_Allocate => True);
 end if;
+--  Optimize the default allocation of an array object when pragma
+--  Initialize_Scalars or Normalize_Scalars is in effect. Construct an
+--  in-place initialization aggregate which may be convert into a fast
+--  memset by the backend.
+elsif Init_Or_Norm_Scalars
+and then Is_Array_Type (T)
+--  The array must lack atomic components because they are treated
+--  as non-static, and as a result the backend will not initialize
+--  the memory in one go.
+and then not Has_Atomic_Components (T)
+--  The array must not be packed because the invalid values in
+--  System.Scalar_Values are multiples of Storage_Unit.
+and then not Is_Packed (T)
+--  The array must have static non-empty ranges, otherwise the
+--  backend cannot initialize the memory in one go.
+and then Has_Static_Non_Empty_Array_Bounds (T)
+--  The optimization is only relevant for arrays of scalar types
+and then Is_Scalar_Type (Component_Type (T))
+--  Similar to regular array initialization using a type init proc,
+--  predicate checks are not performed because the initialization
+--  values are intentionally invalid, and may violate the predicate.
+and then not Has_Predicates (Component_Type (T))
+--  The component type must have a single initialization value
+and then Needs_Simple_Initialization
+(Typ         => Component_Type (T),
+Consider_IS => True)
+then
+Set_Analyzed (N);
+Temp := Make_Temporary (Loc, 'P');
+--  Generate:
+--    Temp : Ptr_Typ := new ...;
+Insert_Action
+(Assoc_Node => N,
+Ins_Action =>
+Make_Object_Declaration (Loc,
+Defining_Identifier => Temp,
+Object_Definition   => New_Occurrence_Of (PtrT, Loc),
+Expression          => Relocate_Node (N)),
+Suppress   => All_Checks);
+--  Generate:
+--    Temp.all := (others => ...);
+Insert_Action
+(Assoc_Node => N,
+Ins_Action =>
+Make_Assignment_Statement (Loc,
+Name       =>
+Make_Explicit_Dereference (Loc,
+Prefix => New_Occurrence_Of (Temp, Loc)),
+Expression =>
+Get_Simple_Init_Val
+(Typ  => T,
+N    => N,
+Size => Esize (Component_Type (T)))),
+Suppress   => All_Checks);
+Rewrite (N, New_Occurrence_Of (Temp, Loc));
+Analyze_And_Resolve (N, PtrT);
 --  Case of no initialization procedure present
 elsif not Has_Non_Null_Base_Init_Proc (T) then
 --  Add discriminants if discriminated type
 declare
 Dis : Boolean := False;
-Typ : Entity_Id;
+Typ : Entity_Id := Empty;
 begin
 if Has_Discriminants (T) then
 Dis := True;
 Typ := T;
 begin
 if Nkind (Act) = N_Object_Declaration
 and then Is_Finalizable_Transient (Act, N)
 then
 Process_Transient_In_Expression (Act, N, Acts);
-return Abandon;
+return Skip;
 --  Avoid processing temporary function results multiple times when
 --  dealing with nested expression_with_actions.
 elsif Nkind (Act) = N_Expression_With_Actions then
 --  Kill warnings in instances, since they may be cases where we
 --  have a test in the generic that makes sense with some types
 --  and not with other types.
-and then not In_Instance
+--  Similarly, do not rewrite membership as a validity check if
+--  within the predicate function for the type.
 then
-Substitute_Valid_Check;
+if In_Instance
-goto Leave;
+or else (Ekind (Current_Scope) = E_Function
+and then Is_Predicate_Function (Current_Scope))
+then
+null;
+else
+Substitute_Valid_Check;
+goto Leave;
+end if;
 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).
 return;
 end if;
 --  Deal with software overflow checking
-if not Backend_Overflow_Checks_On_Target
+if Is_Signed_Integer_Type (Etype (N))
-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:
 Make_Attribute_Reference (Loc,
 Prefix         =>
 New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
 Attribute_Name => Name_First)),
 Reason => CE_Overflow_Check_Failed));
+Set_Do_Overflow_Check (N, False);
 end if;
 end Expand_N_Op_Abs;
 ---------------------
 -- Expand_N_Op_Add --
 --  Overflow checks for floating-point if -gnateF mode active
 Check_Float_Op_Overflow (N);
---  When generating C code, convert nonbinary modular additions into code
+Expand_Nonbinary_Modular_Op (N);
---  that relies on the front-end expansion of operator Mod.
-if Modify_Tree_For_C then
-Expand_Nonbinary_Modular_Op (N);
-end if;
 end Expand_N_Op_Add;
 ---------------------
 -- Expand_N_Op_And --
 ---------------------
 elsif Is_Intrinsic_Subprogram (Entity (N)) then
 Expand_Intrinsic_Call (N, Entity (N));
 end if;
---  When generating C code, convert nonbinary modular operators into code
+Expand_Nonbinary_Modular_Op (N);
---  that relies on the front-end expansion of operator Mod.
-if Modify_Tree_For_C then
-Expand_Nonbinary_Modular_Op (N);
-end if;
 end Expand_N_Op_And;
 ------------------------
 -- Expand_N_Op_Concat --
 ------------------------
 --  Overflow checks for floating-point if -gnateF mode active
 Check_Float_Op_Overflow (N);
---  When generating C code, convert nonbinary modular divisions into code
+Expand_Nonbinary_Modular_Op (N);
---  that relies on the front-end expansion of operator Mod.
-if Modify_Tree_For_C then
-Expand_Nonbinary_Modular_Op (N);
-end if;
 end Expand_N_Op_Divide;
 --------------------
 -- Expand_N_Op_Eq --
 --------------------
 if Restriction_Active (No_Dispatching_Calls) then
 return;
 end if;
---  If this is derived from an untagged private type completed with
+--  If this is an untagged private type completed with a derivation
---  a tagged type, it does not have a full view, so we use the
+--  of an untagged private type whose full view is a tagged type,
---  primitive operations of the private type. This check should no
+--  we use the primitive operations of the private type (since it
---  longer be necessary when these types get their full views???
+--  does not have a full view, and also because its equality
+--  primitive may have been overridden in its untagged full view).
-if Is_Private_Type (A_Typ)
-and then not Is_Tagged_Type (A_Typ)
+if Inherits_From_Tagged_Full_View (A_Typ) then
-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));
 Right_Opnd => Right_Opnd (N)));
 Analyze_And_Resolve (N, Typ);
 end if;
---  When generating C code, convert nonbinary modular minus into code
+Expand_Nonbinary_Modular_Op (N);
---  that relies on the front-end expansion of operator Mod.
-if Modify_Tree_For_C then
-Expand_Nonbinary_Modular_Op (N);
-end if;
 end Expand_N_Op_Minus;
 ---------------------
 -- Expand_N_Op_Mod --
 ---------------------
 --  Overflow checks for floating-point if -gnateF mode active
 Check_Float_Op_Overflow (N);
---  When generating C code, convert nonbinary modular multiplications
+Expand_Nonbinary_Modular_Op (N);
---  into code that relies on the front-end expansion of operator Mod.
-if Modify_Tree_For_C then
-Expand_Nonbinary_Modular_Op (N);
-end if;
 end Expand_N_Op_Multiply;
 --------------------
 -- Expand_N_Op_Ne --
 --------------------
 elsif Is_Intrinsic_Subprogram (Entity (N)) then
 Expand_Intrinsic_Call (N, Entity (N));
 end if;
---  When generating C code, convert nonbinary modular operators into code
+Expand_Nonbinary_Modular_Op (N);
---  that relies on the front-end expansion of operator Mod.
-if Modify_Tree_For_C then
-Expand_Nonbinary_Modular_Op (N);
-end if;
 end Expand_N_Op_Or;
 ----------------------
 -- Expand_N_Op_Plus --
 ----------------------
 --  Overflow checks for floating-point if -gnateF mode active
 Check_Float_Op_Overflow (N);
---  When generating C code, convert nonbinary modular subtractions into
+Expand_Nonbinary_Modular_Op (N);
---  code that relies on the front-end expansion of operator Mod.
-if Modify_Tree_For_C then
-Expand_Nonbinary_Modular_Op (N);
-end if;
 end Expand_N_Op_Subtract;
 ---------------------
 -- Expand_N_Op_Xor --
 ---------------------
 Set_Etype (N, Standard_Boolean);
 Adjust_Result_Type (N, Typ);
 elsif Is_Intrinsic_Subprogram (Entity (N)) then
 Expand_Intrinsic_Call (N, Entity (N));
+end if;
-end if;
+Expand_Nonbinary_Modular_Op (N);
 end Expand_N_Op_Xor;
 ----------------------
 -- Expand_N_Or_Else --
 ----------------------
 Disc_O := First_Discriminant (Operand_Type);
 Disc_S := First_Stored_Discriminant (Operand_Type);
 if Present (Stored) then
 Elmt := First_Elmt (Stored);
+else
+Elmt := No_Elmt; -- init to avoid warning
 end if;
 Cons := New_List;
 while Present (Disc_T) loop
 if Present (Disc_O)
 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;
+Conv   : Node_Id;
+Hi_Arg : Node_Id;
+Hi_Val : Node_Id;
+Lo_Arg : Node_Id;
+Lo_Val : Node_Id;
+Tnn    : Entity_Id;
 begin
 --  Nothing to do if conversion was rewritten
 if Nkind (N) /= N_Type_Conversion then
 Enable_Overflow_Check (Conv);
 end if;
 Tnn := Make_Temporary (Loc, 'T', Conv);
+--  For a conversion from Float to Fixed where the bounds of the
+--  fixed-point type are static, we can obtain a more accurate
+--  fixed-point value by converting the result of the floating-
+--  point expression to an appropriate integer type, and then
+--  performing an unchecked conversion to the target fixed-point
+--  type. The range check can then use the corresponding integer
+--  value of the bounds instead of requiring further conversions.
+--  This preserves the identity:
+--        Fix_Val = Fixed_Type (Float_Type (Fix_Val))
+--  which used to fail when Fix_Val was a bound of the type and
+--  the 'Small was not a representable number.
+--  This transformation requires an integer type large enough to
+--  accommodate a fixed-point value. This will not be the case
+--  in systems where Duration is larger than Long_Integer.
+if Is_Ordinary_Fixed_Point_Type (Target_Type)
+and then Is_Floating_Point_Type (Operand_Type)
+and then RM_Size (Base_Type (Target_Type)) <=
+RM_Size (Standard_Long_Integer)
+and then Nkind (Lo) = N_Real_Literal
+and then Nkind (Hi) = N_Real_Literal
+then
+--  Find the integer type of the right size to perform an unchecked
+--  conversion to the target fixed-point type.
+declare
+Bfx_Type : constant Entity_Id := Base_Type (Target_Type);
+Expr_Id  : constant Entity_Id :=
+Make_Temporary (Loc, 'T', Conv);
+Int_Type : Entity_Id;
+begin
+if RM_Size (Bfx_Type) > RM_Size (Standard_Integer) then
+Int_Type := Standard_Long_Integer;
+elsif RM_Size (Bfx_Type) > RM_Size (Standard_Short_Integer) then
+Int_Type := Standard_Integer;
+else
+Int_Type := Standard_Short_Integer;
+end if;
+--  Generate a temporary with the integer value. Required in the
+--  CCG compiler to ensure that runtime checks reference this
+--  integer expression (instead of the resulting fixed-point
+--  value) because fixed-point values are handled by means of
+--  unsigned integer types).
+Insert_Action (N,
+Make_Object_Declaration (Loc,
+Defining_Identifier => Expr_Id,
+Object_Definition   => New_Occurrence_Of (Int_Type, Loc),
+Constant_Present    => True,
+Expression          =>
+Convert_To (Int_Type, Expression (Conv))));
+--  Create integer objects for range checking of result.
+Lo_Arg :=
+Unchecked_Convert_To
+(Int_Type, New_Occurrence_Of (Expr_Id, Loc));
+Lo_Val :=
+Make_Integer_Literal (Loc, Corresponding_Integer_Value (Lo));
+Hi_Arg :=
+Unchecked_Convert_To
+(Int_Type, New_Occurrence_Of (Expr_Id, Loc));
+Hi_Val :=
+Make_Integer_Literal (Loc, Corresponding_Integer_Value (Hi));
+--  Rewrite conversion as an integer conversion of the
+--  original floating-point expression, followed by an
+--  unchecked conversion to the target fixed-point type.
+Conv :=
+Make_Unchecked_Type_Conversion (Loc,
+Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
+Expression   => New_Occurrence_Of (Expr_Id, Loc));
+end;
+--  All other conversions
+else
+Lo_Arg := New_Occurrence_Of (Tnn, Loc);
+Lo_Val :=
+Make_Attribute_Reference (Loc,
+Prefix         => New_Occurrence_Of (Target_Type, Loc),
+Attribute_Name => Name_First);
+Hi_Arg := New_Occurrence_Of (Tnn, Loc);
+Hi_Val :=
+Make_Attribute_Reference (Loc,
+Prefix         => New_Occurrence_Of (Target_Type, Loc),
+Attribute_Name => Name_Last);
+end if;
+--  Build code for range checking
 Insert_Actions (N, New_List (
 Make_Object_Declaration (Loc,
 Defining_Identifier => Tnn,
 Object_Definition   => New_Occurrence_Of (Btyp, Loc),
 Constant_Present    => True,
 Expression          => Conv),
 Make_Raise_Constraint_Error (Loc,
 Condition =>
 Make_Or_Else (Loc,
-Left_Opnd =>
+Left_Opnd  =>
 Make_Op_Lt (Loc,
-Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
+Left_Opnd  => Lo_Arg,
-Right_Opnd =>
+Right_Opnd => Lo_Val),
-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),
+Left_Opnd  => Hi_Arg,
-Right_Opnd =>
+Right_Opnd => Hi_Val)),
-Make_Attribute_Reference (Loc,
+Reason   => CE_Range_Check_Failed)));
-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;
 -----------------------------
 -- Has_Extra_Accessibility --
 -----------------------------
---  Returns true for a formal of an anonymous access type or for
+--  Returns true for a formal of an anonymous access type or for an Ada
---  an Ada 2012-style stand-alone object of an anonymous access type.
+--  2012-style stand-alone object of an anonymous access type.
 function Has_Extra_Accessibility (Id : Entity_Id) return Boolean is
 begin
 if Is_Formal (Id) or else Ekind_In (Id, E_Constant, E_Variable) then
 return Present (Effective_Extra_Accessibility (Id));
 --  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 Ekind (Entity (Selector_Name (Operand))) = E_Discriminant
 and then Object_Access_Level (Operand) >
 Type_Access_Level (Target_Type)
 then
 Raise_Accessibility_Error;
 goto Done;
 Real_Range_Check;
 elsif Is_Integer_Type (Etype (N)) then
 Expand_Convert_Fixed_To_Integer (N);
+--  The result of the conversion might need a range check,
+--   so do not assume that the result is in bounds.
+Set_Etype (N, Base_Type (Target_Type));
 else
 pragma Assert (Is_Floating_Point_Type (Etype (N)));
 Expand_Convert_Fixed_To_Float (N);
 Real_Range_Check;
 end if;
 begin
 --  Generates the following code: (assuming that Typ has one Discr and
 --  component C2 is also a record)
---   True
+--  Lhs.Discr1 = Rhs.Discr1
---     and then Lhs.Discr1 = Rhs.Discr1
+--    and then Lhs.C1 = Rhs.C1
---     and then Lhs.C1 = Rhs.C1
+--    and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
---     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
+--    and then ...
---     and then ...
+--    and then Lhs.Cmpn = Rhs.Cmpn
---     and then Lhs.Cmpn = Rhs.Cmpn
 Result := New_Occurrence_Of (Standard_True, Loc);
 C := Element_To_Compare (First_Entity (Typ));
 while Present (C) loop
 declare
 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);
 if Nkind (Check) = N_Raise_Program_Error then
 Result := Check;
 Set_Etype (Result, Standard_Boolean);
 exit;
 else
-Result :=
+if First_Time then
-Make_And_Then (Loc,
+Result := Check;
-Left_Opnd  => Result,
-Right_Opnd => Check);
+--  Generate logical "and" for CodePeer to simplify the
+--  generated code and analysis.
+elsif CodePeer_Mode then
+Result :=
+Make_Op_And (Loc,
+Left_Opnd  => Result,
+Right_Opnd => Check);
+else
+Result :=
+Make_And_Then (Loc,
+Left_Opnd  => Result,
+Right_Opnd => Check);
+end if;
 end if;
 end;
+First_Time := False;
 C := Element_To_Compare (Next_Entity (C));
 end loop;
 return Result;
 end Expand_Record_Equality;
 -- Make_Cond --
 ---------------
 function Make_Cond (Alt : Node_Id) return Node_Id is
 Cond : Node_Id;
-L    : constant Node_Id := New_Copy (Lop);
+L    : constant Node_Id := New_Copy_Tree (Lop);
 R    : constant Node_Id := Relocate_Node (Alt);
 begin
 if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
 or else Nkind (Alt) = N_Range
 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;
+return Is_Formal (Entity (Prefix (Sel_Comp)));
 end Prefix_Is_Formal_Parameter;
 --  Start of processing for Has_Inferable_Discriminants
 begin
 --  True for comparison operand of zero
 Comp : Node_Id;
 --  Comparison operand, set only if Is_Zero is false
-Ent : Entity_Id;
+Ent : Entity_Id := Empty;
 --  Entity whose length is being compared
-Index : Node_Id;
+Index : Node_Id := Empty;
 --  Integer_Literal node for length attribute expression, or Empty
 --  if there is no such expression present.
 Ityp  : Entity_Id;
 --  Type of array index to which 'Length is applied
 Make_Selected_Component (Loc,
 Prefix        => Relocate_Node (Left),
 Selector_Name =>
 New_Occurrence_Of (First_Tag_Component (Left_Type), Loc));
-if Is_Class_Wide_Type (Right_Type) then
+if Is_Class_Wide_Type (Right_Type) or else Is_Interface (Left_Type) then
 --  No need to issue a run-time check if we statically know that the
 --  result of this membership test is always true. For example,
 --  considering the following declarations:

Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/exp_ch4.adb @ 131:84e7813d76e9