OSDN Git Service

gcc/
[pf3gnuchains/gcc-fork.git] / gcc / ada / exp_ch4.adb
1 ------------------------------------------------------------------------------
2 --                                                                          --
3 --                         GNAT COMPILER COMPONENTS                         --
4 --                                                                          --
5 --                              E X P _ C H 4                               --
6 --                                                                          --
7 --                                 B o d y                                  --
8 --                                                                          --
9 --          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
10 --                                                                          --
11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 -- terms of the  GNU General Public License as published  by the Free Soft- --
13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
17 -- for  more details.  You should have  received  a copy of the GNU General --
18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
20 --                                                                          --
21 -- GNAT was originally developed  by the GNAT team at  New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
23 --                                                                          --
24 ------------------------------------------------------------------------------
25
26 with Atree;    use Atree;
27 with Checks;   use Checks;
28 with Debug;    use Debug;
29 with Einfo;    use Einfo;
30 with Elists;   use Elists;
31 with Errout;   use Errout;
32 with Exp_Aggr; use Exp_Aggr;
33 with Exp_Atag; use Exp_Atag;
34 with Exp_Ch3;  use Exp_Ch3;
35 with Exp_Ch6;  use Exp_Ch6;
36 with Exp_Ch7;  use Exp_Ch7;
37 with Exp_Ch9;  use Exp_Ch9;
38 with Exp_Disp; use Exp_Disp;
39 with Exp_Fixd; use Exp_Fixd;
40 with Exp_Pakd; use Exp_Pakd;
41 with Exp_Tss;  use Exp_Tss;
42 with Exp_Util; use Exp_Util;
43 with Exp_VFpt; use Exp_VFpt;
44 with Freeze;   use Freeze;
45 with Inline;   use Inline;
46 with Namet;    use Namet;
47 with Nlists;   use Nlists;
48 with Nmake;    use Nmake;
49 with Opt;      use Opt;
50 with Par_SCO;  use Par_SCO;
51 with Restrict; use Restrict;
52 with Rident;   use Rident;
53 with Rtsfind;  use Rtsfind;
54 with Sem;      use Sem;
55 with Sem_Aux;  use Sem_Aux;
56 with Sem_Cat;  use Sem_Cat;
57 with Sem_Ch3;  use Sem_Ch3;
58 with Sem_Ch8;  use Sem_Ch8;
59 with Sem_Ch13; use Sem_Ch13;
60 with Sem_Eval; use Sem_Eval;
61 with Sem_Res;  use Sem_Res;
62 with Sem_Type; use Sem_Type;
63 with Sem_Util; use Sem_Util;
64 with Sem_Warn; use Sem_Warn;
65 with Sinfo;    use Sinfo;
66 with Snames;   use Snames;
67 with Stand;    use Stand;
68 with SCIL_LL;  use SCIL_LL;
69 with Targparm; use Targparm;
70 with Tbuild;   use Tbuild;
71 with Ttypes;   use Ttypes;
72 with Uintp;    use Uintp;
73 with Urealp;   use Urealp;
74 with Validsw;  use Validsw;
75
76 package body Exp_Ch4 is
77
78    -----------------------
79    -- Local Subprograms --
80    -----------------------
81
82    procedure Binary_Op_Validity_Checks (N : Node_Id);
83    pragma Inline (Binary_Op_Validity_Checks);
84    --  Performs validity checks for a binary operator
85
86    procedure Build_Boolean_Array_Proc_Call
87      (N   : Node_Id;
88       Op1 : Node_Id;
89       Op2 : Node_Id);
90    --  If a boolean array assignment can be done in place, build call to
91    --  corresponding library procedure.
92
93    procedure Displace_Allocator_Pointer (N : Node_Id);
94    --  Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
95    --  Expand_Allocator_Expression. Allocating class-wide interface objects
96    --  this routine displaces the pointer to the allocated object to reference
97    --  the component referencing the corresponding secondary dispatch table.
98
99    procedure Expand_Allocator_Expression (N : Node_Id);
100    --  Subsidiary to Expand_N_Allocator, for the case when the expression
101    --  is a qualified expression or an aggregate.
102
103    procedure Expand_Array_Comparison (N : Node_Id);
104    --  This routine handles expansion of the comparison operators (N_Op_Lt,
105    --  N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
106    --  code for these operators is similar, differing only in the details of
107    --  the actual comparison call that is made. Special processing (call a
108    --  run-time routine)
109
110    function Expand_Array_Equality
111      (Nod    : Node_Id;
112       Lhs    : Node_Id;
113       Rhs    : Node_Id;
114       Bodies : List_Id;
115       Typ    : Entity_Id) return Node_Id;
116    --  Expand an array equality into a call to a function implementing this
117    --  equality, and a call to it. Loc is the location for the generated nodes.
118    --  Lhs and Rhs are the array expressions to be compared. Bodies is a list
119    --  on which to attach bodies of local functions that are created in the
120    --  process. It is the responsibility of the caller to insert those bodies
121    --  at the right place. Nod provides the Sloc value for the generated code.
122    --  Normally the types used for the generated equality routine are taken
123    --  from Lhs and Rhs. However, in some situations of generated code, the
124    --  Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
125    --  the type to be used for the formal parameters.
126
127    procedure Expand_Boolean_Operator (N : Node_Id);
128    --  Common expansion processing for Boolean operators (And, Or, Xor) for the
129    --  case of array type arguments.
130
131    procedure Expand_Short_Circuit_Operator (N : Node_Id);
132    --  Common expansion processing for short-circuit boolean operators
133
134    function Expand_Composite_Equality
135      (Nod    : Node_Id;
136       Typ    : Entity_Id;
137       Lhs    : Node_Id;
138       Rhs    : Node_Id;
139       Bodies : List_Id) return Node_Id;
140    --  Local recursive function used to expand equality for nested composite
141    --  types. Used by Expand_Record/Array_Equality, Bodies is a list on which
142    --  to attach bodies of local functions that are created in the process.
143    --  This is the responsibility of the caller to insert those bodies at the
144    --  right place. Nod provides the Sloc value for generated code. Lhs and Rhs
145    --  are the left and right sides for the comparison, and Typ is the type of
146    --  the arrays to compare.
147
148    procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id);
149    --  Routine to expand concatenation of a sequence of two or more operands
150    --  (in the list Operands) and replace node Cnode with the result of the
151    --  concatenation. The operands can be of any appropriate type, and can
152    --  include both arrays and singleton elements.
153
154    procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
155    --  N is a N_Op_Divide or N_Op_Multiply node whose result is universal
156    --  fixed. We do not have such a type at runtime, so the purpose of this
157    --  routine is to find the real type by looking up the tree. We also
158    --  determine if the operation must be rounded.
159
160    function Get_Allocator_Final_List
161      (N    : Node_Id;
162       T    : Entity_Id;
163       PtrT : Entity_Id) return Entity_Id;
164    --  If the designated type is controlled, build final_list expression for
165    --  created object. If context is an access parameter, create a local access
166    --  type to have a usable finalization list.
167
168    function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
169    --  Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
170    --  discriminants if it has a constrained nominal type, unless the object
171    --  is a component of an enclosing Unchecked_Union object that is subject
172    --  to a per-object constraint and the enclosing object lacks inferable
173    --  discriminants.
174    --
175    --  An expression of an Unchecked_Union type has inferable discriminants
176    --  if it is either a name of an object with inferable discriminants or a
177    --  qualified expression whose subtype mark denotes a constrained subtype.
178
179    procedure Insert_Dereference_Action (N : Node_Id);
180    --  N is an expression whose type is an access. When the type of the
181    --  associated storage pool is derived from Checked_Pool, generate a
182    --  call to the 'Dereference' primitive operation.
183
184    function Make_Array_Comparison_Op
185      (Typ : Entity_Id;
186       Nod : Node_Id) return Node_Id;
187    --  Comparisons between arrays are expanded in line. This function produces
188    --  the body of the implementation of (a > b), where a and b are one-
189    --  dimensional arrays of some discrete type. The original node is then
190    --  expanded into the appropriate call to this function. Nod provides the
191    --  Sloc value for the generated code.
192
193    function Make_Boolean_Array_Op
194      (Typ : Entity_Id;
195       N   : Node_Id) return Node_Id;
196    --  Boolean operations on boolean arrays are expanded in line. This function
197    --  produce the body for the node N, which is (a and b), (a or b), or (a xor
198    --  b). It is used only the normal case and not the packed case. The type
199    --  involved, Typ, is the Boolean array type, and the logical operations in
200    --  the body are simple boolean operations. Note that Typ is always a
201    --  constrained type (the caller has ensured this by using
202    --  Convert_To_Actual_Subtype if necessary).
203
204    procedure Rewrite_Comparison (N : Node_Id);
205    --  If N is the node for a comparison whose outcome can be determined at
206    --  compile time, then the node N can be rewritten with True or False. If
207    --  the outcome cannot be determined at compile time, the call has no
208    --  effect. If N is a type conversion, then this processing is applied to
209    --  its expression. If N is neither comparison nor a type conversion, the
210    --  call has no effect.
211
212    procedure Tagged_Membership
213      (N         : Node_Id;
214       SCIL_Node : out Node_Id;
215       Result    : out Node_Id);
216    --  Construct the expression corresponding to the tagged membership test.
217    --  Deals with a second operand being (or not) a class-wide type.
218
219    function Safe_In_Place_Array_Op
220      (Lhs : Node_Id;
221       Op1 : Node_Id;
222       Op2 : Node_Id) return Boolean;
223    --  In the context of an assignment, where the right-hand side is a boolean
224    --  operation on arrays, check whether operation can be performed in place.
225
226    procedure Unary_Op_Validity_Checks (N : Node_Id);
227    pragma Inline (Unary_Op_Validity_Checks);
228    --  Performs validity checks for a unary operator
229
230    -------------------------------
231    -- Binary_Op_Validity_Checks --
232    -------------------------------
233
234    procedure Binary_Op_Validity_Checks (N : Node_Id) is
235    begin
236       if Validity_Checks_On and Validity_Check_Operands then
237          Ensure_Valid (Left_Opnd (N));
238          Ensure_Valid (Right_Opnd (N));
239       end if;
240    end Binary_Op_Validity_Checks;
241
242    ------------------------------------
243    -- Build_Boolean_Array_Proc_Call --
244    ------------------------------------
245
246    procedure Build_Boolean_Array_Proc_Call
247      (N   : Node_Id;
248       Op1 : Node_Id;
249       Op2 : Node_Id)
250    is
251       Loc       : constant Source_Ptr := Sloc (N);
252       Kind      : constant Node_Kind := Nkind (Expression (N));
253       Target    : constant Node_Id   :=
254                     Make_Attribute_Reference (Loc,
255                       Prefix         => Name (N),
256                       Attribute_Name => Name_Address);
257
258       Arg1      : constant Node_Id := Op1;
259       Arg2      : Node_Id := Op2;
260       Call_Node : Node_Id;
261       Proc_Name : Entity_Id;
262
263    begin
264       if Kind = N_Op_Not then
265          if Nkind (Op1) in N_Binary_Op then
266
267             --  Use negated version of the binary operators
268
269             if Nkind (Op1) = N_Op_And then
270                Proc_Name := RTE (RE_Vector_Nand);
271
272             elsif Nkind (Op1) = N_Op_Or then
273                Proc_Name := RTE (RE_Vector_Nor);
274
275             else pragma Assert (Nkind (Op1) = N_Op_Xor);
276                Proc_Name := RTE (RE_Vector_Xor);
277             end if;
278
279             Call_Node :=
280               Make_Procedure_Call_Statement (Loc,
281                 Name => New_Occurrence_Of (Proc_Name, Loc),
282
283                 Parameter_Associations => New_List (
284                   Target,
285                   Make_Attribute_Reference (Loc,
286                     Prefix => Left_Opnd (Op1),
287                     Attribute_Name => Name_Address),
288
289                   Make_Attribute_Reference (Loc,
290                     Prefix => Right_Opnd (Op1),
291                     Attribute_Name => Name_Address),
292
293                   Make_Attribute_Reference (Loc,
294                     Prefix => Left_Opnd (Op1),
295                     Attribute_Name => Name_Length)));
296
297          else
298             Proc_Name := RTE (RE_Vector_Not);
299
300             Call_Node :=
301               Make_Procedure_Call_Statement (Loc,
302                 Name => New_Occurrence_Of (Proc_Name, Loc),
303                 Parameter_Associations => New_List (
304                   Target,
305
306                   Make_Attribute_Reference (Loc,
307                     Prefix => Op1,
308                     Attribute_Name => Name_Address),
309
310                   Make_Attribute_Reference (Loc,
311                     Prefix => Op1,
312                      Attribute_Name => Name_Length)));
313          end if;
314
315       else
316          --  We use the following equivalences:
317
318          --   (not X) or  (not Y)  =  not (X and Y)  =  Nand (X, Y)
319          --   (not X) and (not Y)  =  not (X or Y)   =  Nor  (X, Y)
320          --   (not X) xor (not Y)  =  X xor Y
321          --   X       xor (not Y)  =  not (X xor Y)  =  Nxor (X, Y)
322
323          if Nkind (Op1) = N_Op_Not then
324             if Kind = N_Op_And then
325                Proc_Name := RTE (RE_Vector_Nor);
326             elsif Kind = N_Op_Or then
327                Proc_Name := RTE (RE_Vector_Nand);
328             else
329                Proc_Name := RTE (RE_Vector_Xor);
330             end if;
331
332          else
333             if Kind = N_Op_And then
334                Proc_Name := RTE (RE_Vector_And);
335             elsif Kind = N_Op_Or then
336                Proc_Name := RTE (RE_Vector_Or);
337             elsif Nkind (Op2) = N_Op_Not then
338                Proc_Name := RTE (RE_Vector_Nxor);
339                Arg2 := Right_Opnd (Op2);
340             else
341                Proc_Name := RTE (RE_Vector_Xor);
342             end if;
343          end if;
344
345          Call_Node :=
346            Make_Procedure_Call_Statement (Loc,
347              Name => New_Occurrence_Of (Proc_Name, Loc),
348              Parameter_Associations => New_List (
349                Target,
350                Make_Attribute_Reference (Loc,
351                  Prefix         => Arg1,
352                  Attribute_Name => Name_Address),
353                Make_Attribute_Reference (Loc,
354                  Prefix         => Arg2,
355                  Attribute_Name => Name_Address),
356                Make_Attribute_Reference (Loc,
357                  Prefix         => Op1,
358                  Attribute_Name => Name_Length)));
359       end if;
360
361       Rewrite (N, Call_Node);
362       Analyze (N);
363
364    exception
365       when RE_Not_Available =>
366          return;
367    end Build_Boolean_Array_Proc_Call;
368
369    --------------------------------
370    -- Displace_Allocator_Pointer --
371    --------------------------------
372
373    procedure Displace_Allocator_Pointer (N : Node_Id) is
374       Loc       : constant Source_Ptr := Sloc (N);
375       Orig_Node : constant Node_Id := Original_Node (N);
376       Dtyp      : Entity_Id;
377       Etyp      : Entity_Id;
378       PtrT      : Entity_Id;
379
380    begin
381       --  Do nothing in case of VM targets: the virtual machine will handle
382       --  interfaces directly.
383
384       if not Tagged_Type_Expansion then
385          return;
386       end if;
387
388       pragma Assert (Nkind (N) = N_Identifier
389         and then Nkind (Orig_Node) = N_Allocator);
390
391       PtrT := Etype (Orig_Node);
392       Dtyp := Available_View (Designated_Type (PtrT));
393       Etyp := Etype (Expression (Orig_Node));
394
395       if Is_Class_Wide_Type (Dtyp)
396         and then Is_Interface (Dtyp)
397       then
398          --  If the type of the allocator expression is not an interface type
399          --  we can generate code to reference the record component containing
400          --  the pointer to the secondary dispatch table.
401
402          if not Is_Interface (Etyp) then
403             declare
404                Saved_Typ : constant Entity_Id := Etype (Orig_Node);
405
406             begin
407                --  1) Get access to the allocated object
408
409                Rewrite (N,
410                  Make_Explicit_Dereference (Loc,
411                    Relocate_Node (N)));
412                Set_Etype (N, Etyp);
413                Set_Analyzed (N);
414
415                --  2) Add the conversion to displace the pointer to reference
416                --     the secondary dispatch table.
417
418                Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
419                Analyze_And_Resolve (N, Dtyp);
420
421                --  3) The 'access to the secondary dispatch table will be used
422                --     as the value returned by the allocator.
423
424                Rewrite (N,
425                  Make_Attribute_Reference (Loc,
426                    Prefix         => Relocate_Node (N),
427                    Attribute_Name => Name_Access));
428                Set_Etype (N, Saved_Typ);
429                Set_Analyzed (N);
430             end;
431
432          --  If the type of the allocator expression is an interface type we
433          --  generate a run-time call to displace "this" to reference the
434          --  component containing the pointer to the secondary dispatch table
435          --  or else raise Constraint_Error if the actual object does not
436          --  implement the target interface. This case corresponds with the
437          --  following example:
438
439          --   function Op (Obj : Iface_1'Class) return access Iface_2'Class is
440          --   begin
441          --      return new Iface_2'Class'(Obj);
442          --   end Op;
443
444          else
445             Rewrite (N,
446               Unchecked_Convert_To (PtrT,
447                 Make_Function_Call (Loc,
448                   Name => New_Reference_To (RTE (RE_Displace), Loc),
449                   Parameter_Associations => New_List (
450                     Unchecked_Convert_To (RTE (RE_Address),
451                       Relocate_Node (N)),
452
453                     New_Occurrence_Of
454                       (Elists.Node
455                         (First_Elmt
456                           (Access_Disp_Table (Etype (Base_Type (Dtyp))))),
457                        Loc)))));
458             Analyze_And_Resolve (N, PtrT);
459          end if;
460       end if;
461    end Displace_Allocator_Pointer;
462
463    ---------------------------------
464    -- Expand_Allocator_Expression --
465    ---------------------------------
466
467    procedure Expand_Allocator_Expression (N : Node_Id) is
468       Loc    : constant Source_Ptr := Sloc (N);
469       Exp    : constant Node_Id    := Expression (Expression (N));
470       PtrT   : constant Entity_Id  := Etype (N);
471       DesigT : constant Entity_Id  := Designated_Type (PtrT);
472
473       procedure Apply_Accessibility_Check
474         (Ref            : Node_Id;
475          Built_In_Place : Boolean := False);
476       --  Ada 2005 (AI-344): For an allocator with a class-wide designated
477       --  type, generate an accessibility check to verify that the level of the
478       --  type of the created object is not deeper than the level of the access
479       --  type. If the type of the qualified expression is class- wide, then
480       --  always generate the check (except in the case where it is known to be
481       --  unnecessary, see comment below). Otherwise, only generate the check
482       --  if the level of the qualified expression type is statically deeper
483       --  than the access type.
484       --
485       --  Although the static accessibility will generally have been performed
486       --  as a legality check, it won't have been done in cases where the
487       --  allocator appears in generic body, so a run-time check is needed in
488       --  general. One special case is when the access type is declared in the
489       --  same scope as the class-wide allocator, in which case the check can
490       --  never fail, so it need not be generated.
491       --
492       --  As an open issue, there seem to be cases where the static level
493       --  associated with the class-wide object's underlying type is not
494       --  sufficient to perform the proper accessibility check, such as for
495       --  allocators in nested subprograms or accept statements initialized by
496       --  class-wide formals when the actual originates outside at a deeper
497       --  static level. The nested subprogram case might require passing
498       --  accessibility levels along with class-wide parameters, and the task
499       --  case seems to be an actual gap in the language rules that needs to
500       --  be fixed by the ARG. ???
501
502       -------------------------------
503       -- Apply_Accessibility_Check --
504       -------------------------------
505
506       procedure Apply_Accessibility_Check
507         (Ref            : Node_Id;
508          Built_In_Place : Boolean := False)
509       is
510          Ref_Node : Node_Id;
511
512       begin
513          --  Note: we skip the accessibility check for the VM case, since
514          --  there does not seem to be any practical way of implementing it.
515
516          if Ada_Version >= Ada_05
517            and then Tagged_Type_Expansion
518            and then Is_Class_Wide_Type (DesigT)
519            and then not Scope_Suppress (Accessibility_Check)
520            and then
521              (Type_Access_Level (Etype (Exp)) > Type_Access_Level (PtrT)
522                or else
523                  (Is_Class_Wide_Type (Etype (Exp))
524                    and then Scope (PtrT) /= Current_Scope))
525          then
526             --  If the allocator was built in place Ref is already a reference
527             --  to the access object initialized to the result of the allocator
528             --  (see Exp_Ch6.Make_Build_In_Place_Call_In_Allocator). Otherwise
529             --  it is the entity associated with the object containing the
530             --  address of the allocated object.
531
532             if Built_In_Place then
533                Ref_Node := New_Copy (Ref);
534             else
535                Ref_Node := New_Reference_To (Ref, Loc);
536             end if;
537
538             Insert_Action (N,
539                Make_Raise_Program_Error (Loc,
540                  Condition =>
541                    Make_Op_Gt (Loc,
542                      Left_Opnd  =>
543                        Build_Get_Access_Level (Loc,
544                          Make_Attribute_Reference (Loc,
545                            Prefix => Ref_Node,
546                            Attribute_Name => Name_Tag)),
547                      Right_Opnd =>
548                        Make_Integer_Literal (Loc,
549                          Type_Access_Level (PtrT))),
550                  Reason => PE_Accessibility_Check_Failed));
551          end if;
552       end Apply_Accessibility_Check;
553
554       --  Local variables
555
556       Indic : constant Node_Id   := Subtype_Mark (Expression (N));
557       T     : constant Entity_Id := Entity (Indic);
558       Flist : Node_Id;
559       Node  : Node_Id;
560       Temp  : Entity_Id;
561
562       TagT : Entity_Id := Empty;
563       --  Type used as source for tag assignment
564
565       TagR : Node_Id := Empty;
566       --  Target reference for tag assignment
567
568       Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
569
570       Tag_Assign : Node_Id;
571       Tmp_Node   : Node_Id;
572
573    --  Start of processing for Expand_Allocator_Expression
574
575    begin
576       if Is_Tagged_Type (T) or else Needs_Finalization (T) then
577
578          if Is_CPP_Constructor_Call (Exp) then
579
580             --  Generate:
581             --  Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn
582
583             --  Allocate the object with no expression
584
585             Node := Relocate_Node (N);
586             Set_Expression (Node, New_Reference_To (Etype (Exp), Loc));
587
588             --  Avoid its expansion to avoid generating a call to the default
589             --  C++ constructor
590
591             Set_Analyzed (Node);
592
593             Temp := Make_Temporary (Loc, 'P', N);
594
595             Insert_Action (N,
596               Make_Object_Declaration (Loc,
597                 Defining_Identifier => Temp,
598                 Constant_Present    => True,
599                 Object_Definition   => New_Reference_To (PtrT, Loc),
600                 Expression          => Node));
601
602             Apply_Accessibility_Check (Temp);
603
604             --  Locate the enclosing list and insert the C++ constructor call
605
606             declare
607                P : Node_Id;
608
609             begin
610                P := Parent (Node);
611                while not Is_List_Member (P) loop
612                   P := Parent (P);
613                end loop;
614
615                Insert_List_After_And_Analyze (P,
616                  Build_Initialization_Call (Loc,
617                    Id_Ref =>
618                      Make_Explicit_Dereference (Loc,
619                        Prefix => New_Reference_To (Temp, Loc)),
620                    Typ => Etype (Exp),
621                    Constructor_Ref => Exp));
622             end;
623
624             Rewrite (N, New_Reference_To (Temp, Loc));
625             Analyze_And_Resolve (N, PtrT);
626             return;
627          end if;
628
629          --  Ada 2005 (AI-318-02): If the initialization expression is a call
630          --  to a build-in-place function, then access to the allocated object
631          --  must be passed to the function. Currently we limit such functions
632          --  to those with constrained limited result subtypes, but eventually
633          --  we plan to expand the allowed forms of functions that are treated
634          --  as build-in-place.
635
636          if Ada_Version >= Ada_05
637            and then Is_Build_In_Place_Function_Call (Exp)
638          then
639             Make_Build_In_Place_Call_In_Allocator (N, Exp);
640             Apply_Accessibility_Check (N, Built_In_Place => True);
641             return;
642          end if;
643
644          --    Actions inserted before:
645          --              Temp : constant ptr_T := new T'(Expression);
646          --   <no CW>    Temp._tag := T'tag;
647          --   <CTRL>     Adjust (Finalizable (Temp.all));
648          --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
649
650          --  We analyze by hand the new internal allocator to avoid
651          --  any recursion and inappropriate call to Initialize
652
653          --  We don't want to remove side effects when the expression must be
654          --  built in place. In the case of a build-in-place function call,
655          --  that could lead to a duplication of the call, which was already
656          --  substituted for the allocator.
657
658          if not Aggr_In_Place then
659             Remove_Side_Effects (Exp);
660          end if;
661
662          Temp := Make_Temporary (Loc, 'P', N);
663
664          --  For a class wide allocation generate the following code:
665
666          --    type Equiv_Record is record ... end record;
667          --    implicit subtype CW is <Class_Wide_Subytpe>;
668          --    temp : PtrT := new CW'(CW!(expr));
669
670          if Is_Class_Wide_Type (T) then
671             Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
672
673             --  Ada 2005 (AI-251): If the expression is a class-wide interface
674             --  object we generate code to move up "this" to reference the
675             --  base of the object before allocating the new object.
676
677             --  Note that Exp'Address is recursively expanded into a call
678             --  to Base_Address (Exp.Tag)
679
680             if Is_Class_Wide_Type (Etype (Exp))
681               and then Is_Interface (Etype (Exp))
682               and then Tagged_Type_Expansion
683             then
684                Set_Expression
685                  (Expression (N),
686                   Unchecked_Convert_To (Entity (Indic),
687                     Make_Explicit_Dereference (Loc,
688                       Unchecked_Convert_To (RTE (RE_Tag_Ptr),
689                         Make_Attribute_Reference (Loc,
690                           Prefix         => Exp,
691                           Attribute_Name => Name_Address)))));
692
693             else
694                Set_Expression
695                  (Expression (N),
696                   Unchecked_Convert_To (Entity (Indic), Exp));
697             end if;
698
699             Analyze_And_Resolve (Expression (N), Entity (Indic));
700          end if;
701
702          --  Keep separate the management of allocators returning interfaces
703
704          if not Is_Interface (Directly_Designated_Type (PtrT)) then
705             if Aggr_In_Place then
706                Tmp_Node :=
707                  Make_Object_Declaration (Loc,
708                    Defining_Identifier => Temp,
709                    Object_Definition   => New_Reference_To (PtrT, Loc),
710                    Expression          =>
711                      Make_Allocator (Loc,
712                        New_Reference_To (Etype (Exp), Loc)));
713
714                --  Copy the Comes_From_Source flag for the allocator we just
715                --  built, since logically this allocator is a replacement of
716                --  the original allocator node. This is for proper handling of
717                --  restriction No_Implicit_Heap_Allocations.
718
719                Set_Comes_From_Source
720                  (Expression (Tmp_Node), Comes_From_Source (N));
721
722                Set_No_Initialization (Expression (Tmp_Node));
723                Insert_Action (N, Tmp_Node);
724
725                if Needs_Finalization (T)
726                  and then Ekind (PtrT) = E_Anonymous_Access_Type
727                then
728                   --  Create local finalization list for access parameter
729
730                   Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
731                end if;
732
733                Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
734
735             else
736                Node := Relocate_Node (N);
737                Set_Analyzed (Node);
738                Insert_Action (N,
739                  Make_Object_Declaration (Loc,
740                    Defining_Identifier => Temp,
741                    Constant_Present    => True,
742                    Object_Definition   => New_Reference_To (PtrT, Loc),
743                    Expression          => Node));
744             end if;
745
746          --  Ada 2005 (AI-251): Handle allocators whose designated type is an
747          --  interface type. In this case we use the type of the qualified
748          --  expression to allocate the object.
749
750          else
751             declare
752                Def_Id   : constant Entity_Id := Make_Temporary (Loc, 'T');
753                New_Decl : Node_Id;
754
755             begin
756                New_Decl :=
757                  Make_Full_Type_Declaration (Loc,
758                    Defining_Identifier => Def_Id,
759                    Type_Definition =>
760                      Make_Access_To_Object_Definition (Loc,
761                        All_Present            => True,
762                        Null_Exclusion_Present => False,
763                        Constant_Present       => False,
764                        Subtype_Indication     =>
765                          New_Reference_To (Etype (Exp), Loc)));
766
767                Insert_Action (N, New_Decl);
768
769                --  Inherit the final chain to ensure that the expansion of the
770                --  aggregate is correct in case of controlled types
771
772                if Needs_Finalization (Directly_Designated_Type (PtrT)) then
773                   Set_Associated_Final_Chain (Def_Id,
774                     Associated_Final_Chain (PtrT));
775                end if;
776
777                --  Declare the object using the previous type declaration
778
779                if Aggr_In_Place then
780                   Tmp_Node :=
781                     Make_Object_Declaration (Loc,
782                       Defining_Identifier => Temp,
783                       Object_Definition   => New_Reference_To (Def_Id, Loc),
784                       Expression          =>
785                         Make_Allocator (Loc,
786                           New_Reference_To (Etype (Exp), Loc)));
787
788                   --  Copy the Comes_From_Source flag for the allocator we just
789                   --  built, since logically this allocator is a replacement of
790                   --  the original allocator node. This is for proper handling
791                   --  of restriction No_Implicit_Heap_Allocations.
792
793                   Set_Comes_From_Source
794                     (Expression (Tmp_Node), Comes_From_Source (N));
795
796                   Set_No_Initialization (Expression (Tmp_Node));
797                   Insert_Action (N, Tmp_Node);
798
799                   if Needs_Finalization (T)
800                     and then Ekind (PtrT) = E_Anonymous_Access_Type
801                   then
802                      --  Create local finalization list for access parameter
803
804                      Flist :=
805                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
806                   end if;
807
808                   Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
809                else
810                   Node := Relocate_Node (N);
811                   Set_Analyzed (Node);
812                   Insert_Action (N,
813                     Make_Object_Declaration (Loc,
814                       Defining_Identifier => Temp,
815                       Constant_Present    => True,
816                       Object_Definition   => New_Reference_To (Def_Id, Loc),
817                       Expression          => Node));
818                end if;
819
820                --  Generate an additional object containing the address of the
821                --  returned object. The type of this second object declaration
822                --  is the correct type required for the common processing that
823                --  is still performed by this subprogram. The displacement of
824                --  this pointer to reference the component associated with the
825                --  interface type will be done at the end of common processing.
826
827                New_Decl :=
828                  Make_Object_Declaration (Loc,
829                    Defining_Identifier => Make_Temporary (Loc, 'P'),
830                    Object_Definition   => New_Reference_To (PtrT, Loc),
831                    Expression          => Unchecked_Convert_To (PtrT,
832                                             New_Reference_To (Temp, Loc)));
833
834                Insert_Action (N, New_Decl);
835
836                Tmp_Node := New_Decl;
837                Temp     := Defining_Identifier (New_Decl);
838             end;
839          end if;
840
841          Apply_Accessibility_Check (Temp);
842
843          --  Generate the tag assignment
844
845          --  Suppress the tag assignment when VM_Target because VM tags are
846          --  represented implicitly in objects.
847
848          if not Tagged_Type_Expansion then
849             null;
850
851          --  Ada 2005 (AI-251): Suppress the tag assignment with class-wide
852          --  interface objects because in this case the tag does not change.
853
854          elsif Is_Interface (Directly_Designated_Type (Etype (N))) then
855             pragma Assert (Is_Class_Wide_Type
856                             (Directly_Designated_Type (Etype (N))));
857             null;
858
859          elsif Is_Tagged_Type (T) and then not Is_Class_Wide_Type (T) then
860             TagT := T;
861             TagR := New_Reference_To (Temp, Loc);
862
863          elsif Is_Private_Type (T)
864            and then Is_Tagged_Type (Underlying_Type (T))
865          then
866             TagT := Underlying_Type (T);
867             TagR :=
868               Unchecked_Convert_To (Underlying_Type (T),
869                 Make_Explicit_Dereference (Loc,
870                   Prefix => New_Reference_To (Temp, Loc)));
871          end if;
872
873          if Present (TagT) then
874             Tag_Assign :=
875               Make_Assignment_Statement (Loc,
876                 Name =>
877                   Make_Selected_Component (Loc,
878                     Prefix => TagR,
879                     Selector_Name =>
880                       New_Reference_To (First_Tag_Component (TagT), Loc)),
881
882                 Expression =>
883                   Unchecked_Convert_To (RTE (RE_Tag),
884                     New_Reference_To
885                       (Elists.Node (First_Elmt (Access_Disp_Table (TagT))),
886                        Loc)));
887
888             --  The previous assignment has to be done in any case
889
890             Set_Assignment_OK (Name (Tag_Assign));
891             Insert_Action (N, Tag_Assign);
892          end if;
893
894          if Needs_Finalization (DesigT)
895             and then Needs_Finalization (T)
896          then
897             declare
898                Attach : Node_Id;
899                Apool  : constant Entity_Id :=
900                           Associated_Storage_Pool (PtrT);
901
902             begin
903                --  If it is an allocation on the secondary stack (i.e. a value
904                --  returned from a function), the object is attached on the
905                --  caller side as soon as the call is completed (see
906                --  Expand_Ctrl_Function_Call)
907
908                if Is_RTE (Apool, RE_SS_Pool) then
909                   declare
910                      F : constant Entity_Id := Make_Temporary (Loc, 'F');
911                   begin
912                      Insert_Action (N,
913                        Make_Object_Declaration (Loc,
914                          Defining_Identifier => F,
915                          Object_Definition   =>
916                            New_Reference_To (RTE (RE_Finalizable_Ptr), Loc)));
917                      Flist := New_Reference_To (F, Loc);
918                      Attach :=  Make_Integer_Literal (Loc, 1);
919                   end;
920
921                --  Normal case, not a secondary stack allocation
922
923                else
924                   if Needs_Finalization (T)
925                     and then Ekind (PtrT) = E_Anonymous_Access_Type
926                   then
927                      --  Create local finalization list for access parameter
928
929                      Flist :=
930                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
931                   else
932                      Flist := Find_Final_List (PtrT);
933                   end if;
934
935                   Attach :=  Make_Integer_Literal (Loc, 2);
936                end if;
937
938                --  Generate an Adjust call if the object will be moved. In Ada
939                --  2005, the object may be inherently limited, in which case
940                --  there is no Adjust procedure, and the object is built in
941                --  place. In Ada 95, the object can be limited but not
942                --  inherently limited if this allocator came from a return
943                --  statement (we're allocating the result on the secondary
944                --  stack). In that case, the object will be moved, so we _do_
945                --  want to Adjust.
946
947                if not Aggr_In_Place
948                  and then not Is_Inherently_Limited_Type (T)
949                then
950                   Insert_Actions (N,
951                     Make_Adjust_Call (
952                       Ref          =>
953
954                      --  An unchecked conversion is needed in the classwide
955                      --  case because the designated type can be an ancestor of
956                      --  the subtype mark of the allocator.
957
958                       Unchecked_Convert_To (T,
959                         Make_Explicit_Dereference (Loc,
960                           Prefix => New_Reference_To (Temp, Loc))),
961
962                       Typ          => T,
963                       Flist_Ref    => Flist,
964                       With_Attach  => Attach,
965                       Allocator    => True));
966                end if;
967             end;
968          end if;
969
970          Rewrite (N, New_Reference_To (Temp, Loc));
971          Analyze_And_Resolve (N, PtrT);
972
973          --  Ada 2005 (AI-251): Displace the pointer to reference the record
974          --  component containing the secondary dispatch table of the interface
975          --  type.
976
977          if Is_Interface (Directly_Designated_Type (PtrT)) then
978             Displace_Allocator_Pointer (N);
979          end if;
980
981       elsif Aggr_In_Place then
982          Temp := Make_Temporary (Loc, 'P', N);
983          Tmp_Node :=
984            Make_Object_Declaration (Loc,
985              Defining_Identifier => Temp,
986              Object_Definition   => New_Reference_To (PtrT, Loc),
987              Expression          => Make_Allocator (Loc,
988                  New_Reference_To (Etype (Exp), Loc)));
989
990          --  Copy the Comes_From_Source flag for the allocator we just built,
991          --  since logically this allocator is a replacement of the original
992          --  allocator node. This is for proper handling of restriction
993          --  No_Implicit_Heap_Allocations.
994
995          Set_Comes_From_Source
996            (Expression (Tmp_Node), Comes_From_Source (N));
997
998          Set_No_Initialization (Expression (Tmp_Node));
999          Insert_Action (N, Tmp_Node);
1000          Convert_Aggr_In_Allocator (N, Tmp_Node, Exp);
1001          Rewrite (N, New_Reference_To (Temp, Loc));
1002          Analyze_And_Resolve (N, PtrT);
1003
1004       elsif Is_Access_Type (T)
1005         and then Can_Never_Be_Null (T)
1006       then
1007          Install_Null_Excluding_Check (Exp);
1008
1009       elsif Is_Access_Type (DesigT)
1010         and then Nkind (Exp) = N_Allocator
1011         and then Nkind (Expression (Exp)) /= N_Qualified_Expression
1012       then
1013          --  Apply constraint to designated subtype indication
1014
1015          Apply_Constraint_Check (Expression (Exp),
1016            Designated_Type (DesigT),
1017            No_Sliding => True);
1018
1019          if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
1020
1021             --  Propagate constraint_error to enclosing allocator
1022
1023             Rewrite (Exp, New_Copy (Expression (Exp)));
1024          end if;
1025       else
1026          --  If we have:
1027          --    type A is access T1;
1028          --    X : A := new T2'(...);
1029          --  T1 and T2 can be different subtypes, and we might need to check
1030          --  both constraints. First check against the type of the qualified
1031          --  expression.
1032
1033          Apply_Constraint_Check (Exp, T, No_Sliding => True);
1034
1035          if Do_Range_Check (Exp) then
1036             Set_Do_Range_Check (Exp, False);
1037             Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1038          end if;
1039
1040          --  A check is also needed in cases where the designated subtype is
1041          --  constrained and differs from the subtype given in the qualified
1042          --  expression. Note that the check on the qualified expression does
1043          --  not allow sliding, but this check does (a relaxation from Ada 83).
1044
1045          if Is_Constrained (DesigT)
1046            and then not Subtypes_Statically_Match (T, DesigT)
1047          then
1048             Apply_Constraint_Check
1049               (Exp, DesigT, No_Sliding => False);
1050
1051             if Do_Range_Check (Exp) then
1052                Set_Do_Range_Check (Exp, False);
1053                Generate_Range_Check (Exp, DesigT, CE_Range_Check_Failed);
1054             end if;
1055          end if;
1056
1057          --  For an access to unconstrained packed array, GIGI needs to see an
1058          --  expression with a constrained subtype in order to compute the
1059          --  proper size for the allocator.
1060
1061          if Is_Array_Type (T)
1062            and then not Is_Constrained (T)
1063            and then Is_Packed (T)
1064          then
1065             declare
1066                ConstrT      : constant Entity_Id := Make_Temporary (Loc, 'A');
1067                Internal_Exp : constant Node_Id   := Relocate_Node (Exp);
1068             begin
1069                Insert_Action (Exp,
1070                  Make_Subtype_Declaration (Loc,
1071                    Defining_Identifier => ConstrT,
1072                    Subtype_Indication  =>
1073                      Make_Subtype_From_Expr (Exp, T)));
1074                Freeze_Itype (ConstrT, Exp);
1075                Rewrite (Exp, OK_Convert_To (ConstrT, Internal_Exp));
1076             end;
1077          end if;
1078
1079          --  Ada 2005 (AI-318-02): If the initialization expression is a call
1080          --  to a build-in-place function, then access to the allocated object
1081          --  must be passed to the function. Currently we limit such functions
1082          --  to those with constrained limited result subtypes, but eventually
1083          --  we plan to expand the allowed forms of functions that are treated
1084          --  as build-in-place.
1085
1086          if Ada_Version >= Ada_05
1087            and then Is_Build_In_Place_Function_Call (Exp)
1088          then
1089             Make_Build_In_Place_Call_In_Allocator (N, Exp);
1090          end if;
1091       end if;
1092
1093    exception
1094       when RE_Not_Available =>
1095          return;
1096    end Expand_Allocator_Expression;
1097
1098    -----------------------------
1099    -- Expand_Array_Comparison --
1100    -----------------------------
1101
1102    --  Expansion is only required in the case of array types. For the unpacked
1103    --  case, an appropriate runtime routine is called. For packed cases, and
1104    --  also in some other cases where a runtime routine cannot be called, the
1105    --  form of the expansion is:
1106
1107    --     [body for greater_nn; boolean_expression]
1108
1109    --  The body is built by Make_Array_Comparison_Op, and the form of the
1110    --  Boolean expression depends on the operator involved.
1111
1112    procedure Expand_Array_Comparison (N : Node_Id) is
1113       Loc  : constant Source_Ptr := Sloc (N);
1114       Op1  : Node_Id             := Left_Opnd (N);
1115       Op2  : Node_Id             := Right_Opnd (N);
1116       Typ1 : constant Entity_Id  := Base_Type (Etype (Op1));
1117       Ctyp : constant Entity_Id  := Component_Type (Typ1);
1118
1119       Expr      : Node_Id;
1120       Func_Body : Node_Id;
1121       Func_Name : Entity_Id;
1122
1123       Comp : RE_Id;
1124
1125       Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
1126       --  True for byte addressable target
1127
1128       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
1129       --  Returns True if the length of the given operand is known to be less
1130       --  than 4. Returns False if this length is known to be four or greater
1131       --  or is not known at compile time.
1132
1133       ------------------------
1134       -- Length_Less_Than_4 --
1135       ------------------------
1136
1137       function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
1138          Otyp : constant Entity_Id := Etype (Opnd);
1139
1140       begin
1141          if Ekind (Otyp) = E_String_Literal_Subtype then
1142             return String_Literal_Length (Otyp) < 4;
1143
1144          else
1145             declare
1146                Ityp : constant Entity_Id := Etype (First_Index (Otyp));
1147                Lo   : constant Node_Id   := Type_Low_Bound (Ityp);
1148                Hi   : constant Node_Id   := Type_High_Bound (Ityp);
1149                Lov  : Uint;
1150                Hiv  : Uint;
1151
1152             begin
1153                if Compile_Time_Known_Value (Lo) then
1154                   Lov := Expr_Value (Lo);
1155                else
1156                   return False;
1157                end if;
1158
1159                if Compile_Time_Known_Value (Hi) then
1160                   Hiv := Expr_Value (Hi);
1161                else
1162                   return False;
1163                end if;
1164
1165                return Hiv < Lov + 3;
1166             end;
1167          end if;
1168       end Length_Less_Than_4;
1169
1170    --  Start of processing for Expand_Array_Comparison
1171
1172    begin
1173       --  Deal first with unpacked case, where we can call a runtime routine
1174       --  except that we avoid this for targets for which are not addressable
1175       --  by bytes, and for the JVM/CIL, since they do not support direct
1176       --  addressing of array components.
1177
1178       if not Is_Bit_Packed_Array (Typ1)
1179         and then Byte_Addressable
1180         and then VM_Target = No_VM
1181       then
1182          --  The call we generate is:
1183
1184          --  Compare_Array_xn[_Unaligned]
1185          --    (left'address, right'address, left'length, right'length) <op> 0
1186
1187          --  x = U for unsigned, S for signed
1188          --  n = 8,16,32,64 for component size
1189          --  Add _Unaligned if length < 4 and component size is 8.
1190          --  <op> is the standard comparison operator
1191
1192          if Component_Size (Typ1) = 8 then
1193             if Length_Less_Than_4 (Op1)
1194                  or else
1195                Length_Less_Than_4 (Op2)
1196             then
1197                if Is_Unsigned_Type (Ctyp) then
1198                   Comp := RE_Compare_Array_U8_Unaligned;
1199                else
1200                   Comp := RE_Compare_Array_S8_Unaligned;
1201                end if;
1202
1203             else
1204                if Is_Unsigned_Type (Ctyp) then
1205                   Comp := RE_Compare_Array_U8;
1206                else
1207                   Comp := RE_Compare_Array_S8;
1208                end if;
1209             end if;
1210
1211          elsif Component_Size (Typ1) = 16 then
1212             if Is_Unsigned_Type (Ctyp) then
1213                Comp := RE_Compare_Array_U16;
1214             else
1215                Comp := RE_Compare_Array_S16;
1216             end if;
1217
1218          elsif Component_Size (Typ1) = 32 then
1219             if Is_Unsigned_Type (Ctyp) then
1220                Comp := RE_Compare_Array_U32;
1221             else
1222                Comp := RE_Compare_Array_S32;
1223             end if;
1224
1225          else pragma Assert (Component_Size (Typ1) = 64);
1226             if Is_Unsigned_Type (Ctyp) then
1227                Comp := RE_Compare_Array_U64;
1228             else
1229                Comp := RE_Compare_Array_S64;
1230             end if;
1231          end if;
1232
1233          Remove_Side_Effects (Op1, Name_Req => True);
1234          Remove_Side_Effects (Op2, Name_Req => True);
1235
1236          Rewrite (Op1,
1237            Make_Function_Call (Sloc (Op1),
1238              Name => New_Occurrence_Of (RTE (Comp), Loc),
1239
1240              Parameter_Associations => New_List (
1241                Make_Attribute_Reference (Loc,
1242                  Prefix         => Relocate_Node (Op1),
1243                  Attribute_Name => Name_Address),
1244
1245                Make_Attribute_Reference (Loc,
1246                  Prefix         => Relocate_Node (Op2),
1247                  Attribute_Name => Name_Address),
1248
1249                Make_Attribute_Reference (Loc,
1250                  Prefix         => Relocate_Node (Op1),
1251                  Attribute_Name => Name_Length),
1252
1253                Make_Attribute_Reference (Loc,
1254                  Prefix         => Relocate_Node (Op2),
1255                  Attribute_Name => Name_Length))));
1256
1257          Rewrite (Op2,
1258            Make_Integer_Literal (Sloc (Op2),
1259              Intval => Uint_0));
1260
1261          Analyze_And_Resolve (Op1, Standard_Integer);
1262          Analyze_And_Resolve (Op2, Standard_Integer);
1263          return;
1264       end if;
1265
1266       --  Cases where we cannot make runtime call
1267
1268       --  For (a <= b) we convert to not (a > b)
1269
1270       if Chars (N) = Name_Op_Le then
1271          Rewrite (N,
1272            Make_Op_Not (Loc,
1273              Right_Opnd =>
1274                 Make_Op_Gt (Loc,
1275                  Left_Opnd  => Op1,
1276                  Right_Opnd => Op2)));
1277          Analyze_And_Resolve (N, Standard_Boolean);
1278          return;
1279
1280       --  For < the Boolean expression is
1281       --    greater__nn (op2, op1)
1282
1283       elsif Chars (N) = Name_Op_Lt then
1284          Func_Body := Make_Array_Comparison_Op (Typ1, N);
1285
1286          --  Switch operands
1287
1288          Op1 := Right_Opnd (N);
1289          Op2 := Left_Opnd  (N);
1290
1291       --  For (a >= b) we convert to not (a < b)
1292
1293       elsif Chars (N) = Name_Op_Ge then
1294          Rewrite (N,
1295            Make_Op_Not (Loc,
1296              Right_Opnd =>
1297                Make_Op_Lt (Loc,
1298                  Left_Opnd  => Op1,
1299                  Right_Opnd => Op2)));
1300          Analyze_And_Resolve (N, Standard_Boolean);
1301          return;
1302
1303       --  For > the Boolean expression is
1304       --    greater__nn (op1, op2)
1305
1306       else
1307          pragma Assert (Chars (N) = Name_Op_Gt);
1308          Func_Body := Make_Array_Comparison_Op (Typ1, N);
1309       end if;
1310
1311       Func_Name := Defining_Unit_Name (Specification (Func_Body));
1312       Expr :=
1313         Make_Function_Call (Loc,
1314           Name => New_Reference_To (Func_Name, Loc),
1315           Parameter_Associations => New_List (Op1, Op2));
1316
1317       Insert_Action (N, Func_Body);
1318       Rewrite (N, Expr);
1319       Analyze_And_Resolve (N, Standard_Boolean);
1320
1321    exception
1322       when RE_Not_Available =>
1323          return;
1324    end Expand_Array_Comparison;
1325
1326    ---------------------------
1327    -- Expand_Array_Equality --
1328    ---------------------------
1329
1330    --  Expand an equality function for multi-dimensional arrays. Here is an
1331    --  example of such a function for Nb_Dimension = 2
1332
1333    --  function Enn (A : atyp; B : btyp) return boolean is
1334    --  begin
1335    --     if (A'length (1) = 0 or else A'length (2) = 0)
1336    --          and then
1337    --        (B'length (1) = 0 or else B'length (2) = 0)
1338    --     then
1339    --        return True;    -- RM 4.5.2(22)
1340    --     end if;
1341
1342    --     if A'length (1) /= B'length (1)
1343    --               or else
1344    --           A'length (2) /= B'length (2)
1345    --     then
1346    --        return False;   -- RM 4.5.2(23)
1347    --     end if;
1348
1349    --     declare
1350    --        A1 : Index_T1 := A'first (1);
1351    --        B1 : Index_T1 := B'first (1);
1352    --     begin
1353    --        loop
1354    --           declare
1355    --              A2 : Index_T2 := A'first (2);
1356    --              B2 : Index_T2 := B'first (2);
1357    --           begin
1358    --              loop
1359    --                 if A (A1, A2) /= B (B1, B2) then
1360    --                    return False;
1361    --                 end if;
1362
1363    --                 exit when A2 = A'last (2);
1364    --                 A2 := Index_T2'succ (A2);
1365    --                 B2 := Index_T2'succ (B2);
1366    --              end loop;
1367    --           end;
1368
1369    --           exit when A1 = A'last (1);
1370    --           A1 := Index_T1'succ (A1);
1371    --           B1 := Index_T1'succ (B1);
1372    --        end loop;
1373    --     end;
1374
1375    --     return true;
1376    --  end Enn;
1377
1378    --  Note on the formal types used (atyp and btyp). If either of the arrays
1379    --  is of a private type, we use the underlying type, and do an unchecked
1380    --  conversion of the actual. If either of the arrays has a bound depending
1381    --  on a discriminant, then we use the base type since otherwise we have an
1382    --  escaped discriminant in the function.
1383
1384    --  If both arrays are constrained and have the same bounds, we can generate
1385    --  a loop with an explicit iteration scheme using a 'Range attribute over
1386    --  the first array.
1387
1388    function Expand_Array_Equality
1389      (Nod    : Node_Id;
1390       Lhs    : Node_Id;
1391       Rhs    : Node_Id;
1392       Bodies : List_Id;
1393       Typ    : Entity_Id) return Node_Id
1394    is
1395       Loc         : constant Source_Ptr := Sloc (Nod);
1396       Decls       : constant List_Id    := New_List;
1397       Index_List1 : constant List_Id    := New_List;
1398       Index_List2 : constant List_Id    := New_List;
1399
1400       Actuals   : List_Id;
1401       Formals   : List_Id;
1402       Func_Name : Entity_Id;
1403       Func_Body : Node_Id;
1404
1405       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
1406       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
1407
1408       Ltyp : Entity_Id;
1409       Rtyp : Entity_Id;
1410       --  The parameter types to be used for the formals
1411
1412       function Arr_Attr
1413         (Arr : Entity_Id;
1414          Nam : Name_Id;
1415          Num : Int) return Node_Id;
1416       --  This builds the attribute reference Arr'Nam (Expr)
1417
1418       function Component_Equality (Typ : Entity_Id) return Node_Id;
1419       --  Create one statement to compare corresponding components, designated
1420       --  by a full set of indices.
1421
1422       function Get_Arg_Type (N : Node_Id) return Entity_Id;
1423       --  Given one of the arguments, computes the appropriate type to be used
1424       --  for that argument in the corresponding function formal
1425
1426       function Handle_One_Dimension
1427         (N     : Int;
1428          Index : Node_Id) return Node_Id;
1429       --  This procedure returns the following code
1430       --
1431       --    declare
1432       --       Bn : Index_T := B'First (N);
1433       --    begin
1434       --       loop
1435       --          xxx
1436       --          exit when An = A'Last (N);
1437       --          An := Index_T'Succ (An)
1438       --          Bn := Index_T'Succ (Bn)
1439       --       end loop;
1440       --    end;
1441       --
1442       --  If both indices are constrained and identical, the procedure
1443       --  returns a simpler loop:
1444       --
1445       --      for An in A'Range (N) loop
1446       --         xxx
1447       --      end loop
1448       --
1449       --  N is the dimension for which we are generating a loop. Index is the
1450       --  N'th index node, whose Etype is Index_Type_n in the above code. The
1451       --  xxx statement is either the loop or declare for the next dimension
1452       --  or if this is the last dimension the comparison of corresponding
1453       --  components of the arrays.
1454       --
1455       --  The actual way the code works is to return the comparison of
1456       --  corresponding components for the N+1 call. That's neater!
1457
1458       function Test_Empty_Arrays return Node_Id;
1459       --  This function constructs the test for both arrays being empty
1460       --    (A'length (1) = 0 or else A'length (2) = 0 or else ...)
1461       --      and then
1462       --    (B'length (1) = 0 or else B'length (2) = 0 or else ...)
1463
1464       function Test_Lengths_Correspond return Node_Id;
1465       --  This function constructs the test for arrays having different lengths
1466       --  in at least one index position, in which case the resulting code is:
1467
1468       --     A'length (1) /= B'length (1)
1469       --       or else
1470       --     A'length (2) /= B'length (2)
1471       --       or else
1472       --       ...
1473
1474       --------------
1475       -- Arr_Attr --
1476       --------------
1477
1478       function Arr_Attr
1479         (Arr : Entity_Id;
1480          Nam : Name_Id;
1481          Num : Int) return Node_Id
1482       is
1483       begin
1484          return
1485            Make_Attribute_Reference (Loc,
1486             Attribute_Name => Nam,
1487             Prefix => New_Reference_To (Arr, Loc),
1488             Expressions => New_List (Make_Integer_Literal (Loc, Num)));
1489       end Arr_Attr;
1490
1491       ------------------------
1492       -- Component_Equality --
1493       ------------------------
1494
1495       function Component_Equality (Typ : Entity_Id) return Node_Id is
1496          Test : Node_Id;
1497          L, R : Node_Id;
1498
1499       begin
1500          --  if a(i1...) /= b(j1...) then return false; end if;
1501
1502          L :=
1503            Make_Indexed_Component (Loc,
1504              Prefix => Make_Identifier (Loc, Chars (A)),
1505              Expressions => Index_List1);
1506
1507          R :=
1508            Make_Indexed_Component (Loc,
1509              Prefix => Make_Identifier (Loc, Chars (B)),
1510              Expressions => Index_List2);
1511
1512          Test := Expand_Composite_Equality
1513                    (Nod, Component_Type (Typ), L, R, Decls);
1514
1515          --  If some (sub)component is an unchecked_union, the whole operation
1516          --  will raise program error.
1517
1518          if Nkind (Test) = N_Raise_Program_Error then
1519
1520             --  This node is going to be inserted at a location where a
1521             --  statement is expected: clear its Etype so analysis will set
1522             --  it to the expected Standard_Void_Type.
1523
1524             Set_Etype (Test, Empty);
1525             return Test;
1526
1527          else
1528             return
1529               Make_Implicit_If_Statement (Nod,
1530                 Condition => Make_Op_Not (Loc, Right_Opnd => Test),
1531                 Then_Statements => New_List (
1532                   Make_Simple_Return_Statement (Loc,
1533                     Expression => New_Occurrence_Of (Standard_False, Loc))));
1534          end if;
1535       end Component_Equality;
1536
1537       ------------------
1538       -- Get_Arg_Type --
1539       ------------------
1540
1541       function Get_Arg_Type (N : Node_Id) return Entity_Id is
1542          T : Entity_Id;
1543          X : Node_Id;
1544
1545       begin
1546          T := Etype (N);
1547
1548          if No (T) then
1549             return Typ;
1550
1551          else
1552             T := Underlying_Type (T);
1553
1554             X := First_Index (T);
1555             while Present (X) loop
1556                if Denotes_Discriminant (Type_Low_Bound (Etype (X)))
1557                  or else
1558                    Denotes_Discriminant (Type_High_Bound (Etype (X)))
1559                then
1560                   T := Base_Type (T);
1561                   exit;
1562                end if;
1563
1564                Next_Index (X);
1565             end loop;
1566
1567             return T;
1568          end if;
1569       end Get_Arg_Type;
1570
1571       --------------------------
1572       -- Handle_One_Dimension --
1573       ---------------------------
1574
1575       function Handle_One_Dimension
1576         (N     : Int;
1577          Index : Node_Id) return Node_Id
1578       is
1579          Need_Separate_Indexes : constant Boolean :=
1580                                    Ltyp /= Rtyp
1581                                      or else not Is_Constrained (Ltyp);
1582          --  If the index types are identical, and we are working with
1583          --  constrained types, then we can use the same index for both
1584          --  of the arrays.
1585
1586          An : constant Entity_Id := Make_Temporary (Loc, 'A');
1587
1588          Bn       : Entity_Id;
1589          Index_T  : Entity_Id;
1590          Stm_List : List_Id;
1591          Loop_Stm : Node_Id;
1592
1593       begin
1594          if N > Number_Dimensions (Ltyp) then
1595             return Component_Equality (Ltyp);
1596          end if;
1597
1598          --  Case where we generate a loop
1599
1600          Index_T := Base_Type (Etype (Index));
1601
1602          if Need_Separate_Indexes then
1603             Bn := Make_Temporary (Loc, 'B');
1604          else
1605             Bn := An;
1606          end if;
1607
1608          Append (New_Reference_To (An, Loc), Index_List1);
1609          Append (New_Reference_To (Bn, Loc), Index_List2);
1610
1611          Stm_List := New_List (
1612            Handle_One_Dimension (N + 1, Next_Index (Index)));
1613
1614          if Need_Separate_Indexes then
1615
1616             --  Generate guard for loop, followed by increments of indices
1617
1618             Append_To (Stm_List,
1619                Make_Exit_Statement (Loc,
1620                  Condition =>
1621                    Make_Op_Eq (Loc,
1622                       Left_Opnd => New_Reference_To (An, Loc),
1623                       Right_Opnd => Arr_Attr (A, Name_Last, N))));
1624
1625             Append_To (Stm_List,
1626               Make_Assignment_Statement (Loc,
1627                 Name       => New_Reference_To (An, Loc),
1628                 Expression =>
1629                   Make_Attribute_Reference (Loc,
1630                     Prefix         => New_Reference_To (Index_T, Loc),
1631                     Attribute_Name => Name_Succ,
1632                     Expressions    => New_List (New_Reference_To (An, Loc)))));
1633
1634             Append_To (Stm_List,
1635               Make_Assignment_Statement (Loc,
1636                 Name       => New_Reference_To (Bn, Loc),
1637                 Expression =>
1638                   Make_Attribute_Reference (Loc,
1639                     Prefix         => New_Reference_To (Index_T, Loc),
1640                     Attribute_Name => Name_Succ,
1641                     Expressions    => New_List (New_Reference_To (Bn, Loc)))));
1642          end if;
1643
1644          --  If separate indexes, we need a declare block for An and Bn, and a
1645          --  loop without an iteration scheme.
1646
1647          if Need_Separate_Indexes then
1648             Loop_Stm :=
1649               Make_Implicit_Loop_Statement (Nod, Statements => Stm_List);
1650
1651             return
1652               Make_Block_Statement (Loc,
1653                 Declarations => New_List (
1654                   Make_Object_Declaration (Loc,
1655                     Defining_Identifier => An,
1656                     Object_Definition   => New_Reference_To (Index_T, Loc),
1657                     Expression          => Arr_Attr (A, Name_First, N)),
1658
1659                   Make_Object_Declaration (Loc,
1660                     Defining_Identifier => Bn,
1661                     Object_Definition   => New_Reference_To (Index_T, Loc),
1662                     Expression          => Arr_Attr (B, Name_First, N))),
1663
1664                 Handled_Statement_Sequence =>
1665                   Make_Handled_Sequence_Of_Statements (Loc,
1666                     Statements => New_List (Loop_Stm)));
1667
1668          --  If no separate indexes, return loop statement with explicit
1669          --  iteration scheme on its own
1670
1671          else
1672             Loop_Stm :=
1673               Make_Implicit_Loop_Statement (Nod,
1674                 Statements       => Stm_List,
1675                 Iteration_Scheme =>
1676                   Make_Iteration_Scheme (Loc,
1677                     Loop_Parameter_Specification =>
1678                       Make_Loop_Parameter_Specification (Loc,
1679                         Defining_Identifier         => An,
1680                         Discrete_Subtype_Definition =>
1681                           Arr_Attr (A, Name_Range, N))));
1682             return Loop_Stm;
1683          end if;
1684       end Handle_One_Dimension;
1685
1686       -----------------------
1687       -- Test_Empty_Arrays --
1688       -----------------------
1689
1690       function Test_Empty_Arrays return Node_Id is
1691          Alist : Node_Id;
1692          Blist : Node_Id;
1693
1694          Atest : Node_Id;
1695          Btest : Node_Id;
1696
1697       begin
1698          Alist := Empty;
1699          Blist := Empty;
1700          for J in 1 .. Number_Dimensions (Ltyp) loop
1701             Atest :=
1702               Make_Op_Eq (Loc,
1703                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1704                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1705
1706             Btest :=
1707               Make_Op_Eq (Loc,
1708                 Left_Opnd  => Arr_Attr (B, Name_Length, J),
1709                 Right_Opnd => Make_Integer_Literal (Loc, 0));
1710
1711             if No (Alist) then
1712                Alist := Atest;
1713                Blist := Btest;
1714
1715             else
1716                Alist :=
1717                  Make_Or_Else (Loc,
1718                    Left_Opnd  => Relocate_Node (Alist),
1719                    Right_Opnd => Atest);
1720
1721                Blist :=
1722                  Make_Or_Else (Loc,
1723                    Left_Opnd  => Relocate_Node (Blist),
1724                    Right_Opnd => Btest);
1725             end if;
1726          end loop;
1727
1728          return
1729            Make_And_Then (Loc,
1730              Left_Opnd  => Alist,
1731              Right_Opnd => Blist);
1732       end Test_Empty_Arrays;
1733
1734       -----------------------------
1735       -- Test_Lengths_Correspond --
1736       -----------------------------
1737
1738       function Test_Lengths_Correspond return Node_Id is
1739          Result : Node_Id;
1740          Rtest  : Node_Id;
1741
1742       begin
1743          Result := Empty;
1744          for J in 1 .. Number_Dimensions (Ltyp) loop
1745             Rtest :=
1746               Make_Op_Ne (Loc,
1747                 Left_Opnd  => Arr_Attr (A, Name_Length, J),
1748                 Right_Opnd => Arr_Attr (B, Name_Length, J));
1749
1750             if No (Result) then
1751                Result := Rtest;
1752             else
1753                Result :=
1754                  Make_Or_Else (Loc,
1755                    Left_Opnd  => Relocate_Node (Result),
1756                    Right_Opnd => Rtest);
1757             end if;
1758          end loop;
1759
1760          return Result;
1761       end Test_Lengths_Correspond;
1762
1763    --  Start of processing for Expand_Array_Equality
1764
1765    begin
1766       Ltyp := Get_Arg_Type (Lhs);
1767       Rtyp := Get_Arg_Type (Rhs);
1768
1769       --  For now, if the argument types are not the same, go to the base type,
1770       --  since the code assumes that the formals have the same type. This is
1771       --  fixable in future ???
1772
1773       if Ltyp /= Rtyp then
1774          Ltyp := Base_Type (Ltyp);
1775          Rtyp := Base_Type (Rtyp);
1776          pragma Assert (Ltyp = Rtyp);
1777       end if;
1778
1779       --  Build list of formals for function
1780
1781       Formals := New_List (
1782         Make_Parameter_Specification (Loc,
1783           Defining_Identifier => A,
1784           Parameter_Type      => New_Reference_To (Ltyp, Loc)),
1785
1786         Make_Parameter_Specification (Loc,
1787           Defining_Identifier => B,
1788           Parameter_Type      => New_Reference_To (Rtyp, Loc)));
1789
1790       Func_Name := Make_Temporary (Loc, 'E');
1791
1792       --  Build statement sequence for function
1793
1794       Func_Body :=
1795         Make_Subprogram_Body (Loc,
1796           Specification =>
1797             Make_Function_Specification (Loc,
1798               Defining_Unit_Name       => Func_Name,
1799               Parameter_Specifications => Formals,
1800               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
1801
1802           Declarations =>  Decls,
1803
1804           Handled_Statement_Sequence =>
1805             Make_Handled_Sequence_Of_Statements (Loc,
1806               Statements => New_List (
1807
1808                 Make_Implicit_If_Statement (Nod,
1809                   Condition => Test_Empty_Arrays,
1810                   Then_Statements => New_List (
1811                     Make_Simple_Return_Statement (Loc,
1812                       Expression =>
1813                         New_Occurrence_Of (Standard_True, Loc)))),
1814
1815                 Make_Implicit_If_Statement (Nod,
1816                   Condition => Test_Lengths_Correspond,
1817                   Then_Statements => New_List (
1818                     Make_Simple_Return_Statement (Loc,
1819                       Expression =>
1820                         New_Occurrence_Of (Standard_False, Loc)))),
1821
1822                 Handle_One_Dimension (1, First_Index (Ltyp)),
1823
1824                 Make_Simple_Return_Statement (Loc,
1825                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
1826
1827          Set_Has_Completion (Func_Name, True);
1828          Set_Is_Inlined (Func_Name);
1829
1830          --  If the array type is distinct from the type of the arguments, it
1831          --  is the full view of a private type. Apply an unchecked conversion
1832          --  to insure that analysis of the call succeeds.
1833
1834          declare
1835             L, R : Node_Id;
1836
1837          begin
1838             L := Lhs;
1839             R := Rhs;
1840
1841             if No (Etype (Lhs))
1842               or else Base_Type (Etype (Lhs)) /= Base_Type (Ltyp)
1843             then
1844                L := OK_Convert_To (Ltyp, Lhs);
1845             end if;
1846
1847             if No (Etype (Rhs))
1848               or else Base_Type (Etype (Rhs)) /= Base_Type (Rtyp)
1849             then
1850                R := OK_Convert_To (Rtyp, Rhs);
1851             end if;
1852
1853             Actuals := New_List (L, R);
1854          end;
1855
1856          Append_To (Bodies, Func_Body);
1857
1858          return
1859            Make_Function_Call (Loc,
1860              Name                   => New_Reference_To (Func_Name, Loc),
1861              Parameter_Associations => Actuals);
1862    end Expand_Array_Equality;
1863
1864    -----------------------------
1865    -- Expand_Boolean_Operator --
1866    -----------------------------
1867
1868    --  Note that we first get the actual subtypes of the operands, since we
1869    --  always want to deal with types that have bounds.
1870
1871    procedure Expand_Boolean_Operator (N : Node_Id) is
1872       Typ : constant Entity_Id  := Etype (N);
1873
1874    begin
1875       --  Special case of bit packed array where both operands are known to be
1876       --  properly aligned. In this case we use an efficient run time routine
1877       --  to carry out the operation (see System.Bit_Ops).
1878
1879       if Is_Bit_Packed_Array (Typ)
1880         and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
1881         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
1882       then
1883          Expand_Packed_Boolean_Operator (N);
1884          return;
1885       end if;
1886
1887       --  For the normal non-packed case, the general expansion is to build
1888       --  function for carrying out the comparison (use Make_Boolean_Array_Op)
1889       --  and then inserting it into the tree. The original operator node is
1890       --  then rewritten as a call to this function. We also use this in the
1891       --  packed case if either operand is a possibly unaligned object.
1892
1893       declare
1894          Loc       : constant Source_Ptr := Sloc (N);
1895          L         : constant Node_Id    := Relocate_Node (Left_Opnd  (N));
1896          R         : constant Node_Id    := Relocate_Node (Right_Opnd (N));
1897          Func_Body : Node_Id;
1898          Func_Name : Entity_Id;
1899
1900       begin
1901          Convert_To_Actual_Subtype (L);
1902          Convert_To_Actual_Subtype (R);
1903          Ensure_Defined (Etype (L), N);
1904          Ensure_Defined (Etype (R), N);
1905          Apply_Length_Check (R, Etype (L));
1906
1907          if Nkind (N) = N_Op_Xor then
1908             Silly_Boolean_Array_Xor_Test (N, Etype (L));
1909          end if;
1910
1911          if Nkind (Parent (N)) = N_Assignment_Statement
1912            and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
1913          then
1914             Build_Boolean_Array_Proc_Call (Parent (N), L, R);
1915
1916          elsif Nkind (Parent (N)) = N_Op_Not
1917            and then Nkind (N) = N_Op_And
1918            and then
1919              Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
1920          then
1921             return;
1922          else
1923
1924             Func_Body := Make_Boolean_Array_Op (Etype (L), N);
1925             Func_Name := Defining_Unit_Name (Specification (Func_Body));
1926             Insert_Action (N, Func_Body);
1927
1928             --  Now rewrite the expression with a call
1929
1930             Rewrite (N,
1931               Make_Function_Call (Loc,
1932                 Name                   => New_Reference_To (Func_Name, Loc),
1933                 Parameter_Associations =>
1934                   New_List (
1935                     L,
1936                     Make_Type_Conversion
1937                       (Loc, New_Reference_To (Etype (L), Loc), R))));
1938
1939             Analyze_And_Resolve (N, Typ);
1940          end if;
1941       end;
1942    end Expand_Boolean_Operator;
1943
1944    -------------------------------
1945    -- Expand_Composite_Equality --
1946    -------------------------------
1947
1948    --  This function is only called for comparing internal fields of composite
1949    --  types when these fields are themselves composites. This is a special
1950    --  case because it is not possible to respect normal Ada visibility rules.
1951
1952    function Expand_Composite_Equality
1953      (Nod    : Node_Id;
1954       Typ    : Entity_Id;
1955       Lhs    : Node_Id;
1956       Rhs    : Node_Id;
1957       Bodies : List_Id) return Node_Id
1958    is
1959       Loc       : constant Source_Ptr := Sloc (Nod);
1960       Full_Type : Entity_Id;
1961       Prim      : Elmt_Id;
1962       Eq_Op     : Entity_Id;
1963
1964    begin
1965       if Is_Private_Type (Typ) then
1966          Full_Type := Underlying_Type (Typ);
1967       else
1968          Full_Type := Typ;
1969       end if;
1970
1971       --  Defense against malformed private types with no completion the error
1972       --  will be diagnosed later by check_completion
1973
1974       if No (Full_Type) then
1975          return New_Reference_To (Standard_False, Loc);
1976       end if;
1977
1978       Full_Type := Base_Type (Full_Type);
1979
1980       if Is_Array_Type (Full_Type) then
1981
1982          --  If the operand is an elementary type other than a floating-point
1983          --  type, then we can simply use the built-in block bitwise equality,
1984          --  since the predefined equality operators always apply and bitwise
1985          --  equality is fine for all these cases.
1986
1987          if Is_Elementary_Type (Component_Type (Full_Type))
1988            and then not Is_Floating_Point_Type (Component_Type (Full_Type))
1989          then
1990             return Make_Op_Eq (Loc, Left_Opnd  => Lhs, Right_Opnd => Rhs);
1991
1992          --  For composite component types, and floating-point types, use the
1993          --  expansion. This deals with tagged component types (where we use
1994          --  the applicable equality routine) and floating-point, (where we
1995          --  need to worry about negative zeroes), and also the case of any
1996          --  composite type recursively containing such fields.
1997
1998          else
1999             return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
2000          end if;
2001
2002       elsif Is_Tagged_Type (Full_Type) then
2003
2004          --  Call the primitive operation "=" of this type
2005
2006          if Is_Class_Wide_Type (Full_Type) then
2007             Full_Type := Root_Type (Full_Type);
2008          end if;
2009
2010          --  If this is derived from an untagged private type completed with a
2011          --  tagged type, it does not have a full view, so we use the primitive
2012          --  operations of the private type. This check should no longer be
2013          --  necessary when these types receive their full views ???
2014
2015          if Is_Private_Type (Typ)
2016            and then not Is_Tagged_Type (Typ)
2017            and then not Is_Controlled (Typ)
2018            and then Is_Derived_Type (Typ)
2019            and then No (Full_View (Typ))
2020          then
2021             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
2022          else
2023             Prim := First_Elmt (Primitive_Operations (Full_Type));
2024          end if;
2025
2026          loop
2027             Eq_Op := Node (Prim);
2028             exit when Chars (Eq_Op) = Name_Op_Eq
2029               and then Etype (First_Formal (Eq_Op)) =
2030                        Etype (Next_Formal (First_Formal (Eq_Op)))
2031               and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
2032             Next_Elmt (Prim);
2033             pragma Assert (Present (Prim));
2034          end loop;
2035
2036          Eq_Op := Node (Prim);
2037
2038          return
2039            Make_Function_Call (Loc,
2040              Name => New_Reference_To (Eq_Op, Loc),
2041              Parameter_Associations =>
2042                New_List
2043                  (Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
2044                   Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
2045
2046       elsif Is_Record_Type (Full_Type) then
2047          Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
2048
2049          if Present (Eq_Op) then
2050             if Etype (First_Formal (Eq_Op)) /= Full_Type then
2051
2052                --  Inherited equality from parent type. Convert the actuals to
2053                --  match signature of operation.
2054
2055                declare
2056                   T : constant Entity_Id := Etype (First_Formal (Eq_Op));
2057
2058                begin
2059                   return
2060                     Make_Function_Call (Loc,
2061                       Name => New_Reference_To (Eq_Op, Loc),
2062                       Parameter_Associations =>
2063                         New_List (OK_Convert_To (T, Lhs),
2064                                   OK_Convert_To (T, Rhs)));
2065                end;
2066
2067             else
2068                --  Comparison between Unchecked_Union components
2069
2070                if Is_Unchecked_Union (Full_Type) then
2071                   declare
2072                      Lhs_Type      : Node_Id := Full_Type;
2073                      Rhs_Type      : Node_Id := Full_Type;
2074                      Lhs_Discr_Val : Node_Id;
2075                      Rhs_Discr_Val : Node_Id;
2076
2077                   begin
2078                      --  Lhs subtype
2079
2080                      if Nkind (Lhs) = N_Selected_Component then
2081                         Lhs_Type := Etype (Entity (Selector_Name (Lhs)));
2082                      end if;
2083
2084                      --  Rhs subtype
2085
2086                      if Nkind (Rhs) = N_Selected_Component then
2087                         Rhs_Type := Etype (Entity (Selector_Name (Rhs)));
2088                      end if;
2089
2090                      --  Lhs of the composite equality
2091
2092                      if Is_Constrained (Lhs_Type) then
2093
2094                         --  Since the enclosing record type can never be an
2095                         --  Unchecked_Union (this code is executed for records
2096                         --  that do not have variants), we may reference its
2097                         --  discriminant(s).
2098
2099                         if Nkind (Lhs) = N_Selected_Component
2100                           and then Has_Per_Object_Constraint (
2101                                      Entity (Selector_Name (Lhs)))
2102                         then
2103                            Lhs_Discr_Val :=
2104                              Make_Selected_Component (Loc,
2105                                Prefix => Prefix (Lhs),
2106                                Selector_Name =>
2107                                  New_Copy (
2108                                    Get_Discriminant_Value (
2109                                      First_Discriminant (Lhs_Type),
2110                                      Lhs_Type,
2111                                      Stored_Constraint (Lhs_Type))));
2112
2113                         else
2114                            Lhs_Discr_Val := New_Copy (
2115                              Get_Discriminant_Value (
2116                                First_Discriminant (Lhs_Type),
2117                                Lhs_Type,
2118                                Stored_Constraint (Lhs_Type)));
2119
2120                         end if;
2121                      else
2122                         --  It is not possible to infer the discriminant since
2123                         --  the subtype is not constrained.
2124
2125                         return
2126                           Make_Raise_Program_Error (Loc,
2127                             Reason => PE_Unchecked_Union_Restriction);
2128                      end if;
2129
2130                      --  Rhs of the composite equality
2131
2132                      if Is_Constrained (Rhs_Type) then
2133                         if Nkind (Rhs) = N_Selected_Component
2134                           and then Has_Per_Object_Constraint (
2135                                      Entity (Selector_Name (Rhs)))
2136                         then
2137                            Rhs_Discr_Val :=
2138                              Make_Selected_Component (Loc,
2139                                Prefix => Prefix (Rhs),
2140                                Selector_Name =>
2141                                  New_Copy (
2142                                    Get_Discriminant_Value (
2143                                      First_Discriminant (Rhs_Type),
2144                                      Rhs_Type,
2145                                      Stored_Constraint (Rhs_Type))));
2146
2147                         else
2148                            Rhs_Discr_Val := New_Copy (
2149                              Get_Discriminant_Value (
2150                                First_Discriminant (Rhs_Type),
2151                                Rhs_Type,
2152                                Stored_Constraint (Rhs_Type)));
2153
2154                         end if;
2155                      else
2156                         return
2157                           Make_Raise_Program_Error (Loc,
2158                             Reason => PE_Unchecked_Union_Restriction);
2159                      end if;
2160
2161                      --  Call the TSS equality function with the inferred
2162                      --  discriminant values.
2163
2164                      return
2165                        Make_Function_Call (Loc,
2166                          Name => New_Reference_To (Eq_Op, Loc),
2167                          Parameter_Associations => New_List (
2168                            Lhs,
2169                            Rhs,
2170                            Lhs_Discr_Val,
2171                            Rhs_Discr_Val));
2172                   end;
2173                end if;
2174
2175                --  Shouldn't this be an else, we can't fall through the above
2176                --  IF, right???
2177
2178                return
2179                  Make_Function_Call (Loc,
2180                    Name => New_Reference_To (Eq_Op, Loc),
2181                    Parameter_Associations => New_List (Lhs, Rhs));
2182             end if;
2183
2184          else
2185             return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
2186          end if;
2187
2188       else
2189          --  It can be a simple record or the full view of a scalar private
2190
2191          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
2192       end if;
2193    end Expand_Composite_Equality;
2194
2195    ------------------------
2196    -- Expand_Concatenate --
2197    ------------------------
2198
2199    procedure Expand_Concatenate (Cnode : Node_Id; Opnds : List_Id) is
2200       Loc : constant Source_Ptr := Sloc (Cnode);
2201
2202       Atyp : constant Entity_Id := Base_Type (Etype (Cnode));
2203       --  Result type of concatenation
2204
2205       Ctyp : constant Entity_Id := Base_Type (Component_Type (Etype (Cnode)));
2206       --  Component type. Elements of this component type can appear as one
2207       --  of the operands of concatenation as well as arrays.
2208
2209       Istyp : constant Entity_Id := Etype (First_Index (Atyp));
2210       --  Index subtype
2211
2212       Ityp : constant Entity_Id := Base_Type (Istyp);
2213       --  Index type. This is the base type of the index subtype, and is used
2214       --  for all computed bounds (which may be out of range of Istyp in the
2215       --  case of null ranges).
2216
2217       Artyp : Entity_Id;
2218       --  This is the type we use to do arithmetic to compute the bounds and
2219       --  lengths of operands. The choice of this type is a little subtle and
2220       --  is discussed in a separate section at the start of the body code.
2221
2222       Concatenation_Error : exception;
2223       --  Raised if concatenation is sure to raise a CE
2224
2225       Result_May_Be_Null : Boolean := True;
2226       --  Reset to False if at least one operand is encountered which is known
2227       --  at compile time to be non-null. Used for handling the special case
2228       --  of setting the high bound to the last operand high bound for a null
2229       --  result, thus ensuring a proper high bound in the super-flat case.
2230
2231       N : constant Nat := List_Length (Opnds);
2232       --  Number of concatenation operands including possibly null operands
2233
2234       NN : Nat := 0;
2235       --  Number of operands excluding any known to be null, except that the
2236       --  last operand is always retained, in case it provides the bounds for
2237       --  a null result.
2238
2239       Opnd : Node_Id;
2240       --  Current operand being processed in the loop through operands. After
2241       --  this loop is complete, always contains the last operand (which is not
2242       --  the same as Operands (NN), since null operands are skipped).
2243
2244       --  Arrays describing the operands, only the first NN entries of each
2245       --  array are set (NN < N when we exclude known null operands).
2246
2247       Is_Fixed_Length : array (1 .. N) of Boolean;
2248       --  True if length of corresponding operand known at compile time
2249
2250       Operands : array (1 .. N) of Node_Id;
2251       --  Set to the corresponding entry in the Opnds list (but note that null
2252       --  operands are excluded, so not all entries in the list are stored).
2253
2254       Fixed_Length : array (1 .. N) of Uint;
2255       --  Set to length of operand. Entries in this array are set only if the
2256       --  corresponding entry in Is_Fixed_Length is True.
2257
2258       Opnd_Low_Bound : array (1 .. N) of Node_Id;
2259       --  Set to lower bound of operand. Either an integer literal in the case
2260       --  where the bound is known at compile time, else actual lower bound.
2261       --  The operand low bound is of type Ityp.
2262
2263       Var_Length : array (1 .. N) of Entity_Id;
2264       --  Set to an entity of type Natural that contains the length of an
2265       --  operand whose length is not known at compile time. Entries in this
2266       --  array are set only if the corresponding entry in Is_Fixed_Length
2267       --  is False. The entity is of type Artyp.
2268
2269       Aggr_Length : array (0 .. N) of Node_Id;
2270       --  The J'th entry in an expression node that represents the total length
2271       --  of operands 1 through J. It is either an integer literal node, or a
2272       --  reference to a constant entity with the right value, so it is fine
2273       --  to just do a Copy_Node to get an appropriate copy. The extra zero'th
2274       --  entry always is set to zero. The length is of type Artyp.
2275
2276       Low_Bound : Node_Id;
2277       --  A tree node representing the low bound of the result (of type Ityp).
2278       --  This is either an integer literal node, or an identifier reference to
2279       --  a constant entity initialized to the appropriate value.
2280
2281       Last_Opnd_High_Bound : Node_Id;
2282       --  A tree node representing the high bound of the last operand. This
2283       --  need only be set if the result could be null. It is used for the
2284       --  special case of setting the right high bound for a null result.
2285       --  This is of type Ityp.
2286
2287       High_Bound : Node_Id;
2288       --  A tree node representing the high bound of the result (of type Ityp)
2289
2290       Result : Node_Id;
2291       --  Result of the concatenation (of type Ityp)
2292
2293       Actions : constant List_Id := New_List;
2294       --  Collect actions to be inserted if Save_Space is False
2295
2296       Save_Space : Boolean;
2297       pragma Warnings (Off, Save_Space);
2298       --  Set to True if we are saving generated code space by calling routines
2299       --  in packages System.Concat_n.
2300
2301       Known_Non_Null_Operand_Seen : Boolean;
2302       --  Set True during generation of the assignements of operands into
2303       --  result once an operand known to be non-null has been seen.
2304
2305       function Make_Artyp_Literal (Val : Nat) return Node_Id;
2306       --  This function makes an N_Integer_Literal node that is returned in
2307       --  analyzed form with the type set to Artyp. Importantly this literal
2308       --  is not flagged as static, so that if we do computations with it that
2309       --  result in statically detected out of range conditions, we will not
2310       --  generate error messages but instead warning messages.
2311
2312       function To_Artyp (X : Node_Id) return Node_Id;
2313       --  Given a node of type Ityp, returns the corresponding value of type
2314       --  Artyp. For non-enumeration types, this is a plain integer conversion.
2315       --  For enum types, the Pos of the value is returned.
2316
2317       function To_Ityp (X : Node_Id) return Node_Id;
2318       --  The inverse function (uses Val in the case of enumeration types)
2319
2320       ------------------------
2321       -- Make_Artyp_Literal --
2322       ------------------------
2323
2324       function Make_Artyp_Literal (Val : Nat) return Node_Id is
2325          Result : constant Node_Id := Make_Integer_Literal (Loc, Val);
2326       begin
2327          Set_Etype (Result, Artyp);
2328          Set_Analyzed (Result, True);
2329          Set_Is_Static_Expression (Result, False);
2330          return Result;
2331       end Make_Artyp_Literal;
2332
2333       --------------
2334       -- To_Artyp --
2335       --------------
2336
2337       function To_Artyp (X : Node_Id) return Node_Id is
2338       begin
2339          if Ityp = Base_Type (Artyp) then
2340             return X;
2341
2342          elsif Is_Enumeration_Type (Ityp) then
2343             return
2344               Make_Attribute_Reference (Loc,
2345                 Prefix         => New_Occurrence_Of (Ityp, Loc),
2346                 Attribute_Name => Name_Pos,
2347                 Expressions    => New_List (X));
2348
2349          else
2350             return Convert_To (Artyp, X);
2351          end if;
2352       end To_Artyp;
2353
2354       -------------
2355       -- To_Ityp --
2356       -------------
2357
2358       function To_Ityp (X : Node_Id) return Node_Id is
2359       begin
2360          if Is_Enumeration_Type (Ityp) then
2361             return
2362               Make_Attribute_Reference (Loc,
2363                 Prefix         => New_Occurrence_Of (Ityp, Loc),
2364                 Attribute_Name => Name_Val,
2365                 Expressions    => New_List (X));
2366
2367          --  Case where we will do a type conversion
2368
2369          else
2370             if Ityp = Base_Type (Artyp) then
2371                return X;
2372             else
2373                return Convert_To (Ityp, X);
2374             end if;
2375          end if;
2376       end To_Ityp;
2377
2378       --  Local Declarations
2379
2380       Opnd_Typ : Entity_Id;
2381       Ent      : Entity_Id;
2382       Len      : Uint;
2383       J        : Nat;
2384       Clen     : Node_Id;
2385       Set      : Boolean;
2386
2387    begin
2388       --  Choose an appropriate computational type
2389
2390       --  We will be doing calculations of lengths and bounds in this routine
2391       --  and computing one from the other in some cases, e.g. getting the high
2392       --  bound by adding the length-1 to the low bound.
2393
2394       --  We can't just use the index type, or even its base type for this
2395       --  purpose for two reasons. First it might be an enumeration type which
2396       --  is not suitable fo computations of any kind, and second it may simply
2397       --  not have enough range. For example if the index type is -128..+127
2398       --  then lengths can be up to 256, which is out of range of the type.
2399
2400       --  For enumeration types, we can simply use Standard_Integer, this is
2401       --  sufficient since the actual number of enumeration literals cannot
2402       --  possibly exceed the range of integer (remember we will be doing the
2403       --  arithmetic with POS values, not representation values).
2404
2405       if Is_Enumeration_Type (Ityp) then
2406          Artyp := Standard_Integer;
2407
2408       --  If index type is Positive, we use the standard unsigned type, to give
2409       --  more room on the top of the range, obviating the need for an overflow
2410       --  check when creating the upper bound. This is needed to avoid junk
2411       --  overflow checks in the common case of String types.
2412
2413       --  ??? Disabled for now
2414
2415       --  elsif Istyp = Standard_Positive then
2416       --     Artyp := Standard_Unsigned;
2417
2418       --  For modular types, we use a 32-bit modular type for types whose size
2419       --  is in the range 1-31 bits. For 32-bit unsigned types, we use the
2420       --  identity type, and for larger unsigned types we use 64-bits.
2421
2422       elsif Is_Modular_Integer_Type (Ityp) then
2423          if RM_Size (Ityp) < RM_Size (Standard_Unsigned) then
2424             Artyp := Standard_Unsigned;
2425          elsif RM_Size (Ityp) = RM_Size (Standard_Unsigned) then
2426             Artyp := Ityp;
2427          else
2428             Artyp := RTE (RE_Long_Long_Unsigned);
2429          end if;
2430
2431       --  Similar treatment for signed types
2432
2433       else
2434          if RM_Size (Ityp) < RM_Size (Standard_Integer) then
2435             Artyp := Standard_Integer;
2436          elsif RM_Size (Ityp) = RM_Size (Standard_Integer) then
2437             Artyp := Ityp;
2438          else
2439             Artyp := Standard_Long_Long_Integer;
2440          end if;
2441       end if;
2442
2443       --  Supply dummy entry at start of length array
2444
2445       Aggr_Length (0) := Make_Artyp_Literal (0);
2446
2447       --  Go through operands setting up the above arrays
2448
2449       J := 1;
2450       while J <= N loop
2451          Opnd := Remove_Head (Opnds);
2452          Opnd_Typ := Etype (Opnd);
2453
2454          --  The parent got messed up when we put the operands in a list,
2455          --  so now put back the proper parent for the saved operand.
2456
2457          Set_Parent (Opnd, Parent (Cnode));
2458
2459          --  Set will be True when we have setup one entry in the array
2460
2461          Set := False;
2462
2463          --  Singleton element (or character literal) case
2464
2465          if Base_Type (Opnd_Typ) = Ctyp then
2466             NN := NN + 1;
2467             Operands (NN) := Opnd;
2468             Is_Fixed_Length (NN) := True;
2469             Fixed_Length (NN) := Uint_1;
2470             Result_May_Be_Null := False;
2471
2472             --  Set low bound of operand (no need to set Last_Opnd_High_Bound
2473             --  since we know that the result cannot be null).
2474
2475             Opnd_Low_Bound (NN) :=
2476               Make_Attribute_Reference (Loc,
2477                 Prefix         => New_Reference_To (Istyp, Loc),
2478                 Attribute_Name => Name_First);
2479
2480             Set := True;
2481
2482          --  String literal case (can only occur for strings of course)
2483
2484          elsif Nkind (Opnd) = N_String_Literal then
2485             Len := String_Literal_Length (Opnd_Typ);
2486
2487             if Len /= 0 then
2488                Result_May_Be_Null := False;
2489             end if;
2490
2491             --  Capture last operand high bound if result could be null
2492
2493             if J = N and then Result_May_Be_Null then
2494                Last_Opnd_High_Bound :=
2495                  Make_Op_Add (Loc,
2496                    Left_Opnd  =>
2497                      New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)),
2498                    Right_Opnd => Make_Integer_Literal (Loc, 1));
2499             end if;
2500
2501             --  Skip null string literal
2502
2503             if J < N and then Len = 0 then
2504                goto Continue;
2505             end if;
2506
2507             NN := NN + 1;
2508             Operands (NN) := Opnd;
2509             Is_Fixed_Length (NN) := True;
2510
2511             --  Set length and bounds
2512
2513             Fixed_Length (NN) := Len;
2514
2515             Opnd_Low_Bound (NN) :=
2516               New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ));
2517
2518             Set := True;
2519
2520          --  All other cases
2521
2522          else
2523             --  Check constrained case with known bounds
2524
2525             if Is_Constrained (Opnd_Typ) then
2526                declare
2527                   Index    : constant Node_Id   := First_Index (Opnd_Typ);
2528                   Indx_Typ : constant Entity_Id := Etype (Index);
2529                   Lo       : constant Node_Id   := Type_Low_Bound  (Indx_Typ);
2530                   Hi       : constant Node_Id   := Type_High_Bound (Indx_Typ);
2531
2532                begin
2533                   --  Fixed length constrained array type with known at compile
2534                   --  time bounds is last case of fixed length operand.
2535
2536                   if Compile_Time_Known_Value (Lo)
2537                        and then
2538                      Compile_Time_Known_Value (Hi)
2539                   then
2540                      declare
2541                         Loval : constant Uint := Expr_Value (Lo);
2542                         Hival : constant Uint := Expr_Value (Hi);
2543                         Len   : constant Uint :=
2544                                   UI_Max (Hival - Loval + 1, Uint_0);
2545
2546                      begin
2547                         if Len > 0 then
2548                            Result_May_Be_Null := False;
2549                         end if;
2550
2551                         --  Capture last operand bound if result could be null
2552
2553                         if J = N and then Result_May_Be_Null then
2554                            Last_Opnd_High_Bound :=
2555                              Convert_To (Ityp,
2556                                Make_Integer_Literal (Loc,
2557                                  Intval => Expr_Value (Hi)));
2558                         end if;
2559
2560                         --  Exclude null length case unless last operand
2561
2562                         if J < N and then Len = 0 then
2563                            goto Continue;
2564                         end if;
2565
2566                         NN := NN + 1;
2567                         Operands (NN) := Opnd;
2568                         Is_Fixed_Length (NN) := True;
2569                         Fixed_Length (NN)    := Len;
2570
2571                         Opnd_Low_Bound (NN) := To_Ityp (
2572                           Make_Integer_Literal (Loc,
2573                             Intval => Expr_Value (Lo)));
2574
2575                         Set := True;
2576                      end;
2577                   end if;
2578                end;
2579             end if;
2580
2581             --  All cases where the length is not known at compile time, or the
2582             --  special case of an operand which is known to be null but has a
2583             --  lower bound other than 1 or is other than a string type.
2584
2585             if not Set then
2586                NN := NN + 1;
2587
2588                --  Capture operand bounds
2589
2590                Opnd_Low_Bound (NN) :=
2591                  Make_Attribute_Reference (Loc,
2592                    Prefix         =>
2593                      Duplicate_Subexpr (Opnd, Name_Req => True),
2594                    Attribute_Name => Name_First);
2595
2596                if J = N and Result_May_Be_Null then
2597                   Last_Opnd_High_Bound :=
2598                     Convert_To (Ityp,
2599                       Make_Attribute_Reference (Loc,
2600                         Prefix         =>
2601                           Duplicate_Subexpr (Opnd, Name_Req => True),
2602                         Attribute_Name => Name_Last));
2603                end if;
2604
2605                --  Capture length of operand in entity
2606
2607                Operands (NN) := Opnd;
2608                Is_Fixed_Length (NN) := False;
2609
2610                Var_Length (NN) := Make_Temporary (Loc, 'L');
2611
2612                Append_To (Actions,
2613                  Make_Object_Declaration (Loc,
2614                    Defining_Identifier => Var_Length (NN),
2615                    Constant_Present    => True,
2616
2617                    Object_Definition   =>
2618                      New_Occurrence_Of (Artyp, Loc),
2619
2620                    Expression          =>
2621                      Make_Attribute_Reference (Loc,
2622                        Prefix         =>
2623                          Duplicate_Subexpr (Opnd, Name_Req => True),
2624                        Attribute_Name => Name_Length)));
2625             end if;
2626          end if;
2627
2628          --  Set next entry in aggregate length array
2629
2630          --  For first entry, make either integer literal for fixed length
2631          --  or a reference to the saved length for variable length.
2632
2633          if NN = 1 then
2634             if Is_Fixed_Length (1) then
2635                Aggr_Length (1) :=
2636                  Make_Integer_Literal (Loc,
2637                    Intval => Fixed_Length (1));
2638             else
2639                Aggr_Length (1) :=
2640                  New_Reference_To (Var_Length (1), Loc);
2641             end if;
2642
2643          --  If entry is fixed length and only fixed lengths so far, make
2644          --  appropriate new integer literal adding new length.
2645
2646          elsif Is_Fixed_Length (NN)
2647            and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal
2648          then
2649             Aggr_Length (NN) :=
2650               Make_Integer_Literal (Loc,
2651                 Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1)));
2652
2653          --  All other cases, construct an addition node for the length and
2654          --  create an entity initialized to this length.
2655
2656          else
2657             Ent := Make_Temporary (Loc, 'L');
2658
2659             if Is_Fixed_Length (NN) then
2660                Clen := Make_Integer_Literal (Loc, Fixed_Length (NN));
2661             else
2662                Clen := New_Reference_To (Var_Length (NN), Loc);
2663             end if;
2664
2665             Append_To (Actions,
2666               Make_Object_Declaration (Loc,
2667                 Defining_Identifier => Ent,
2668                 Constant_Present    => True,
2669
2670                 Object_Definition   =>
2671                   New_Occurrence_Of (Artyp, Loc),
2672
2673                 Expression          =>
2674                   Make_Op_Add (Loc,
2675                     Left_Opnd  => New_Copy (Aggr_Length (NN - 1)),
2676                     Right_Opnd => Clen)));
2677
2678             Aggr_Length (NN) := Make_Identifier (Loc, Chars => Chars (Ent));
2679          end if;
2680
2681       <<Continue>>
2682          J := J + 1;
2683       end loop;
2684
2685       --  If we have only skipped null operands, return the last operand
2686
2687       if NN = 0 then
2688          Result := Opnd;
2689          goto Done;
2690       end if;
2691
2692       --  If we have only one non-null operand, return it and we are done.
2693       --  There is one case in which this cannot be done, and that is when
2694       --  the sole operand is of the element type, in which case it must be
2695       --  converted to an array, and the easiest way of doing that is to go
2696       --  through the normal general circuit.
2697
2698       if NN = 1
2699         and then Base_Type (Etype (Operands (1))) /= Ctyp
2700       then
2701          Result := Operands (1);
2702          goto Done;
2703       end if;
2704
2705       --  Cases where we have a real concatenation
2706
2707       --  Next step is to find the low bound for the result array that we
2708       --  will allocate. The rules for this are in (RM 4.5.6(5-7)).
2709
2710       --  If the ultimate ancestor of the index subtype is a constrained array
2711       --  definition, then the lower bound is that of the index subtype as
2712       --  specified by (RM 4.5.3(6)).
2713
2714       --  The right test here is to go to the root type, and then the ultimate
2715       --  ancestor is the first subtype of this root type.
2716
2717       if Is_Constrained (First_Subtype (Root_Type (Atyp))) then
2718          Low_Bound :=
2719            Make_Attribute_Reference (Loc,
2720              Prefix         =>
2721                New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc),
2722              Attribute_Name => Name_First);
2723
2724       --  If the first operand in the list has known length we know that
2725       --  the lower bound of the result is the lower bound of this operand.
2726
2727       elsif Is_Fixed_Length (1) then
2728          Low_Bound := Opnd_Low_Bound (1);
2729
2730       --  OK, we don't know the lower bound, we have to build a horrible
2731       --  expression actions node of the form
2732
2733       --     if Cond1'Length /= 0 then
2734       --        Opnd1 low bound
2735       --     else
2736       --        if Opnd2'Length /= 0 then
2737       --          Opnd2 low bound
2738       --        else
2739       --           ...
2740
2741       --  The nesting ends either when we hit an operand whose length is known
2742       --  at compile time, or on reaching the last operand, whose low bound we
2743       --  take unconditionally whether or not it is null. It's easiest to do
2744       --  this with a recursive procedure:
2745
2746       else
2747          declare
2748             function Get_Known_Bound (J : Nat) return Node_Id;
2749             --  Returns the lower bound determined by operands J .. NN
2750
2751             ---------------------
2752             -- Get_Known_Bound --
2753             ---------------------
2754
2755             function Get_Known_Bound (J : Nat) return Node_Id is
2756             begin
2757                if Is_Fixed_Length (J) or else J = NN then
2758                   return New_Copy (Opnd_Low_Bound (J));
2759
2760                else
2761                   return
2762                     Make_Conditional_Expression (Loc,
2763                       Expressions => New_List (
2764
2765                         Make_Op_Ne (Loc,
2766                           Left_Opnd  => New_Reference_To (Var_Length (J), Loc),
2767                           Right_Opnd => Make_Integer_Literal (Loc, 0)),
2768
2769                         New_Copy (Opnd_Low_Bound (J)),
2770                         Get_Known_Bound (J + 1)));
2771                end if;
2772             end Get_Known_Bound;
2773
2774          begin
2775             Ent := Make_Temporary (Loc, 'L');
2776
2777             Append_To (Actions,
2778               Make_Object_Declaration (Loc,
2779                 Defining_Identifier => Ent,
2780                 Constant_Present    => True,
2781                 Object_Definition   => New_Occurrence_Of (Ityp, Loc),
2782                 Expression          => Get_Known_Bound (1)));
2783
2784             Low_Bound := New_Reference_To (Ent, Loc);
2785          end;
2786       end if;
2787
2788       --  Now we can safely compute the upper bound, normally
2789       --  Low_Bound + Length - 1.
2790
2791       High_Bound :=
2792         To_Ityp (
2793           Make_Op_Add (Loc,
2794             Left_Opnd  => To_Artyp (New_Copy (Low_Bound)),
2795             Right_Opnd =>
2796               Make_Op_Subtract (Loc,
2797                 Left_Opnd  => New_Copy (Aggr_Length (NN)),
2798                 Right_Opnd => Make_Artyp_Literal (1))));
2799
2800       --  Note that calculation of the high bound may cause overflow in some
2801       --  very weird cases, so in the general case we need an overflow check on
2802       --  the high bound. We can avoid this for the common case of string types
2803       --  and other types whose index is Positive, since we chose a wider range
2804       --  for the arithmetic type.
2805
2806       if Istyp /= Standard_Positive then
2807          Activate_Overflow_Check (High_Bound);
2808       end if;
2809
2810       --  Handle the exceptional case where the result is null, in which case
2811       --  case the bounds come from the last operand (so that we get the proper
2812       --  bounds if the last operand is super-flat).
2813
2814       if Result_May_Be_Null then
2815          High_Bound :=
2816            Make_Conditional_Expression (Loc,
2817              Expressions => New_List (
2818                Make_Op_Eq (Loc,
2819                  Left_Opnd  => New_Copy (Aggr_Length (NN)),
2820                  Right_Opnd => Make_Artyp_Literal (0)),
2821                Last_Opnd_High_Bound,
2822                High_Bound));
2823       end if;
2824
2825       --  Here is where we insert the saved up actions
2826
2827       Insert_Actions (Cnode, Actions, Suppress => All_Checks);
2828
2829       --  Now we construct an array object with appropriate bounds. We mark
2830       --  the target as internal to prevent useless initialization when
2831       --  Initialize_Scalars is enabled.
2832
2833       Ent := Make_Temporary (Loc, 'S');
2834       Set_Is_Internal (Ent);
2835
2836       --  If the bound is statically known to be out of range, we do not want
2837       --  to abort, we want a warning and a runtime constraint error. Note that
2838       --  we have arranged that the result will not be treated as a static
2839       --  constant, so we won't get an illegality during this insertion.
2840
2841       Insert_Action (Cnode,
2842         Make_Object_Declaration (Loc,
2843           Defining_Identifier => Ent,
2844           Object_Definition   =>
2845             Make_Subtype_Indication (Loc,
2846               Subtype_Mark => New_Occurrence_Of (Atyp, Loc),
2847               Constraint   =>
2848                 Make_Index_Or_Discriminant_Constraint (Loc,
2849                   Constraints => New_List (
2850                     Make_Range (Loc,
2851                       Low_Bound  => Low_Bound,
2852                       High_Bound => High_Bound))))),
2853         Suppress => All_Checks);
2854
2855       --  If the result of the concatenation appears as the initializing
2856       --  expression of an object declaration, we can just rename the
2857       --  result, rather than copying it.
2858
2859       Set_OK_To_Rename (Ent);
2860
2861       --  Catch the static out of range case now
2862
2863       if Raises_Constraint_Error (High_Bound) then
2864          raise Concatenation_Error;
2865       end if;
2866
2867       --  Now we will generate the assignments to do the actual concatenation
2868
2869       --  There is one case in which we will not do this, namely when all the
2870       --  following conditions are met:
2871
2872       --    The result type is Standard.String
2873
2874       --    There are nine or fewer retained (non-null) operands
2875
2876       --    The optimization level is -O0
2877
2878       --    The corresponding System.Concat_n.Str_Concat_n routine is
2879       --    available in the run time.
2880
2881       --    The debug flag gnatd.c is not set
2882
2883       --  If all these conditions are met then we generate a call to the
2884       --  relevant concatenation routine. The purpose of this is to avoid
2885       --  undesirable code bloat at -O0.
2886
2887       if Atyp = Standard_String
2888         and then NN in 2 .. 9
2889         and then (Opt.Optimization_Level = 0 or else Debug_Flag_Dot_CC)
2890         and then not Debug_Flag_Dot_C
2891       then
2892          declare
2893             RR : constant array (Nat range 2 .. 9) of RE_Id :=
2894                    (RE_Str_Concat_2,
2895                     RE_Str_Concat_3,
2896                     RE_Str_Concat_4,
2897                     RE_Str_Concat_5,
2898                     RE_Str_Concat_6,
2899                     RE_Str_Concat_7,
2900                     RE_Str_Concat_8,
2901                     RE_Str_Concat_9);
2902
2903          begin
2904             if RTE_Available (RR (NN)) then
2905                declare
2906                   Opnds : constant List_Id :=
2907                             New_List (New_Occurrence_Of (Ent, Loc));
2908
2909                begin
2910                   for J in 1 .. NN loop
2911                      if Is_List_Member (Operands (J)) then
2912                         Remove (Operands (J));
2913                      end if;
2914
2915                      if Base_Type (Etype (Operands (J))) = Ctyp then
2916                         Append_To (Opnds,
2917                           Make_Aggregate (Loc,
2918                             Component_Associations => New_List (
2919                               Make_Component_Association (Loc,
2920                                 Choices => New_List (
2921                                   Make_Integer_Literal (Loc, 1)),
2922                                 Expression => Operands (J)))));
2923
2924                      else
2925                         Append_To (Opnds, Operands (J));
2926                      end if;
2927                   end loop;
2928
2929                   Insert_Action (Cnode,
2930                     Make_Procedure_Call_Statement (Loc,
2931                       Name => New_Reference_To (RTE (RR (NN)), Loc),
2932                       Parameter_Associations => Opnds));
2933
2934                   Result := New_Reference_To (Ent, Loc);
2935                   goto Done;
2936                end;
2937             end if;
2938          end;
2939       end if;
2940
2941       --  Not special case so generate the assignments
2942
2943       Known_Non_Null_Operand_Seen := False;
2944
2945       for J in 1 .. NN loop
2946          declare
2947             Lo : constant Node_Id :=
2948                    Make_Op_Add (Loc,
2949                      Left_Opnd  => To_Artyp (New_Copy (Low_Bound)),
2950                      Right_Opnd => Aggr_Length (J - 1));
2951
2952             Hi : constant Node_Id :=
2953                    Make_Op_Add (Loc,
2954                      Left_Opnd  => To_Artyp (New_Copy (Low_Bound)),
2955                      Right_Opnd =>
2956                        Make_Op_Subtract (Loc,
2957                          Left_Opnd  => Aggr_Length (J),
2958                          Right_Opnd => Make_Artyp_Literal (1)));
2959
2960          begin
2961             --  Singleton case, simple assignment
2962
2963             if Base_Type (Etype (Operands (J))) = Ctyp then
2964                Known_Non_Null_Operand_Seen := True;
2965                Insert_Action (Cnode,
2966                  Make_Assignment_Statement (Loc,
2967                    Name       =>
2968                      Make_Indexed_Component (Loc,
2969                        Prefix      => New_Occurrence_Of (Ent, Loc),
2970                        Expressions => New_List (To_Ityp (Lo))),
2971                    Expression => Operands (J)),
2972                  Suppress => All_Checks);
2973
2974             --  Array case, slice assignment, skipped when argument is fixed
2975             --  length and known to be null.
2976
2977             elsif (not Is_Fixed_Length (J)) or else (Fixed_Length (J) > 0) then
2978                declare
2979                   Assign : Node_Id :=
2980                              Make_Assignment_Statement (Loc,
2981                                Name       =>
2982                                  Make_Slice (Loc,
2983                                    Prefix         =>
2984                                      New_Occurrence_Of (Ent, Loc),
2985                                    Discrete_Range =>
2986                                      Make_Range (Loc,
2987                                        Low_Bound  => To_Ityp (Lo),
2988                                        High_Bound => To_Ityp (Hi))),
2989                                Expression => Operands (J));
2990                begin
2991                   if Is_Fixed_Length (J) then
2992                      Known_Non_Null_Operand_Seen := True;
2993
2994                   elsif not Known_Non_Null_Operand_Seen then
2995
2996                      --  Here if operand length is not statically known and no
2997                      --  operand known to be non-null has been processed yet.
2998                      --  If operand length is 0, we do not need to perform the
2999                      --  assignment, and we must avoid the evaluation of the
3000                      --  high bound of the slice, since it may underflow if the
3001                      --  low bound is Ityp'First.
3002
3003                      Assign :=
3004                        Make_Implicit_If_Statement (Cnode,
3005                          Condition =>
3006                            Make_Op_Ne (Loc,
3007                              Left_Opnd =>
3008                                New_Occurrence_Of (Var_Length (J), Loc),
3009                              Right_Opnd => Make_Integer_Literal (Loc, 0)),
3010                          Then_Statements =>
3011                            New_List (Assign));
3012                   end if;
3013
3014                   Insert_Action (Cnode, Assign, Suppress => All_Checks);
3015                end;
3016             end if;
3017          end;
3018       end loop;
3019
3020       --  Finally we build the result, which is a reference to the array object
3021
3022       Result := New_Reference_To (Ent, Loc);
3023
3024    <<Done>>
3025       Rewrite (Cnode, Result);
3026       Analyze_And_Resolve (Cnode, Atyp);
3027
3028    exception
3029       when Concatenation_Error =>
3030
3031          --  Kill warning generated for the declaration of the static out of
3032          --  range high bound, and instead generate a Constraint_Error with
3033          --  an appropriate specific message.
3034
3035          Kill_Dead_Code (Declaration_Node (Entity (High_Bound)));
3036          Apply_Compile_Time_Constraint_Error
3037            (N      => Cnode,
3038             Msg    => "concatenation result upper bound out of range?",
3039             Reason => CE_Range_Check_Failed);
3040          --  Set_Etype (Cnode, Atyp);
3041    end Expand_Concatenate;
3042
3043    ------------------------
3044    -- Expand_N_Allocator --
3045    ------------------------
3046
3047    procedure Expand_N_Allocator (N : Node_Id) is
3048       PtrT  : constant Entity_Id  := Etype (N);
3049       Dtyp  : constant Entity_Id  := Available_View (Designated_Type (PtrT));
3050       Etyp  : constant Entity_Id  := Etype (Expression (N));
3051       Loc   : constant Source_Ptr := Sloc (N);
3052       Desig : Entity_Id;
3053       Temp  : Entity_Id;
3054       Nod   : Node_Id;
3055
3056       procedure Complete_Coextension_Finalization;
3057       --  Generate finalization calls for all nested coextensions of N. This
3058       --  routine may allocate list controllers if necessary.
3059
3060       procedure Rewrite_Coextension (N : Node_Id);
3061       --  Static coextensions have the same lifetime as the entity they
3062       --  constrain. Such occurrences can be rewritten as aliased objects
3063       --  and their unrestricted access used instead of the coextension.
3064
3065       function Size_In_Storage_Elements (E : Entity_Id) return Node_Id;
3066       --  Given a constrained array type E, returns a node representing the
3067       --  code to compute the size in storage elements for the given type.
3068       --  This is done without using the attribute (which malfunctions for
3069       --  large sizes ???)
3070
3071       ---------------------------------------
3072       -- Complete_Coextension_Finalization --
3073       ---------------------------------------
3074
3075       procedure Complete_Coextension_Finalization is
3076          Coext      : Node_Id;
3077          Coext_Elmt : Elmt_Id;
3078          Flist      : Node_Id;
3079          Ref        : Node_Id;
3080
3081          function Inside_A_Return_Statement (N : Node_Id) return Boolean;
3082          --  Determine whether node N is part of a return statement
3083
3084          function Needs_Initialization_Call (N : Node_Id) return Boolean;
3085          --  Determine whether node N is a subtype indicator allocator which
3086          --  acts a coextension. Such coextensions need initialization.
3087
3088          -------------------------------
3089          -- Inside_A_Return_Statement --
3090          -------------------------------
3091
3092          function Inside_A_Return_Statement (N : Node_Id) return Boolean is
3093             P : Node_Id;
3094
3095          begin
3096             P := Parent (N);
3097             while Present (P) loop
3098                if Nkind_In
3099                    (P, N_Extended_Return_Statement, N_Simple_Return_Statement)
3100                then
3101                   return True;
3102
3103                --  Stop the traversal when we reach a subprogram body
3104
3105                elsif Nkind (P) = N_Subprogram_Body then
3106                   return False;
3107                end if;
3108
3109                P := Parent (P);
3110             end loop;
3111
3112             return False;
3113          end Inside_A_Return_Statement;
3114
3115          -------------------------------
3116          -- Needs_Initialization_Call --
3117          -------------------------------
3118
3119          function Needs_Initialization_Call (N : Node_Id) return Boolean is
3120             Obj_Decl : Node_Id;
3121
3122          begin
3123             if Nkind (N) = N_Explicit_Dereference
3124               and then Nkind (Prefix (N)) = N_Identifier
3125               and then Nkind (Parent (Entity (Prefix (N)))) =
3126                          N_Object_Declaration
3127             then
3128                Obj_Decl := Parent (Entity (Prefix (N)));
3129
3130                return
3131                  Present (Expression (Obj_Decl))
3132                    and then Nkind (Expression (Obj_Decl)) = N_Allocator
3133                    and then Nkind (Expression (Expression (Obj_Decl))) /=
3134                               N_Qualified_Expression;
3135             end if;
3136
3137             return False;
3138          end Needs_Initialization_Call;
3139
3140       --  Start of processing for Complete_Coextension_Finalization
3141
3142       begin
3143          --  When a coextension root is inside a return statement, we need to
3144          --  use the finalization chain of the function's scope. This does not
3145          --  apply for controlled named access types because in those cases we
3146          --  can use the finalization chain of the type itself.
3147
3148          if Inside_A_Return_Statement (N)
3149            and then
3150              (Ekind (PtrT) = E_Anonymous_Access_Type
3151                 or else
3152                   (Ekind (PtrT) = E_Access_Type
3153                      and then No (Associated_Final_Chain (PtrT))))
3154          then
3155             declare
3156                Decl    : Node_Id;
3157                Outer_S : Entity_Id;
3158                S       : Entity_Id;
3159
3160             begin
3161                S := Current_Scope;
3162                while Present (S) and then S /= Standard_Standard loop
3163                   if Ekind (S) = E_Function then
3164                      Outer_S := Scope (S);
3165
3166                      --  Retrieve the declaration of the body
3167
3168                      Decl :=
3169                        Parent
3170                          (Parent
3171                             (Corresponding_Body (Parent (Parent (S)))));
3172                      exit;
3173                   end if;
3174
3175                   S := Scope (S);
3176                end loop;
3177
3178                --  Push the scope of the function body since we are inserting
3179                --  the list before the body, but we are currently in the body
3180                --  itself. Override the finalization list of PtrT since the
3181                --  finalization context is now different.
3182
3183                Push_Scope (Outer_S);
3184                Build_Final_List (Decl, PtrT);
3185                Pop_Scope;
3186             end;
3187
3188          --  The root allocator may not be controlled, but it still needs a
3189          --  finalization list for all nested coextensions.
3190
3191          elsif No (Associated_Final_Chain (PtrT)) then
3192             Build_Final_List (N, PtrT);
3193          end if;
3194
3195          Flist :=
3196            Make_Selected_Component (Loc,
3197              Prefix =>
3198                New_Reference_To (Associated_Final_Chain (PtrT), Loc),
3199              Selector_Name =>
3200                Make_Identifier (Loc, Name_F));
3201
3202          Coext_Elmt := First_Elmt (Coextensions (N));
3203          while Present (Coext_Elmt) loop
3204             Coext := Node (Coext_Elmt);
3205
3206             --  Generate:
3207             --    typ! (coext.all)
3208
3209             if Nkind (Coext) = N_Identifier then
3210                Ref :=
3211                  Make_Unchecked_Type_Conversion (Loc,
3212                    Subtype_Mark => New_Reference_To (Etype (Coext), Loc),
3213                    Expression   =>
3214                      Make_Explicit_Dereference (Loc,
3215                        Prefix => New_Copy_Tree (Coext)));
3216             else
3217                Ref := New_Copy_Tree (Coext);
3218             end if;
3219
3220             --  No initialization call if not allowed
3221
3222             Check_Restriction (No_Default_Initialization, N);
3223
3224             if not Restriction_Active (No_Default_Initialization) then
3225
3226                --  Generate:
3227                --    initialize (Ref)
3228                --    attach_to_final_list (Ref, Flist, 2)
3229
3230                if Needs_Initialization_Call (Coext) then
3231                   Insert_Actions (N,
3232                     Make_Init_Call (
3233                       Ref         => Ref,
3234                       Typ         => Etype (Coext),
3235                       Flist_Ref   => Flist,
3236                       With_Attach => Make_Integer_Literal (Loc, Uint_2)));
3237
3238                --  Generate:
3239                --    attach_to_final_list (Ref, Flist, 2)
3240
3241                else
3242                   Insert_Action (N,
3243                     Make_Attach_Call (
3244                       Obj_Ref     => Ref,
3245                       Flist_Ref   => New_Copy_Tree (Flist),
3246                       With_Attach => Make_Integer_Literal (Loc, Uint_2)));
3247                end if;
3248             end if;
3249
3250             Next_Elmt (Coext_Elmt);
3251          end loop;
3252       end Complete_Coextension_Finalization;
3253
3254       -------------------------
3255       -- Rewrite_Coextension --
3256       -------------------------
3257
3258       procedure Rewrite_Coextension (N : Node_Id) is
3259          Temp : constant Node_Id := Make_Temporary (Loc, 'C');
3260
3261          --  Generate:
3262          --    Cnn : aliased Etyp;
3263
3264          Decl : constant Node_Id :=
3265                   Make_Object_Declaration (Loc,
3266                     Defining_Identifier => Temp,
3267                     Aliased_Present     => True,
3268                     Object_Definition   =>
3269                       New_Occurrence_Of (Etyp, Loc));
3270          Nod  : Node_Id;
3271
3272       begin
3273          if Nkind (Expression (N)) = N_Qualified_Expression then
3274             Set_Expression (Decl, Expression (Expression (N)));
3275          end if;
3276
3277          --  Find the proper insertion node for the declaration
3278
3279          Nod := Parent (N);
3280          while Present (Nod) loop
3281             exit when Nkind (Nod) in N_Statement_Other_Than_Procedure_Call
3282               or else Nkind (Nod) = N_Procedure_Call_Statement
3283               or else Nkind (Nod) in N_Declaration;
3284             Nod := Parent (Nod);
3285          end loop;
3286
3287          Insert_Before (Nod, Decl);
3288          Analyze (Decl);
3289
3290          Rewrite (N,
3291            Make_Attribute_Reference (Loc,
3292              Prefix         => New_Occurrence_Of (Temp, Loc),
3293              Attribute_Name => Name_Unrestricted_Access));
3294
3295          Analyze_And_Resolve (N, PtrT);
3296       end Rewrite_Coextension;
3297
3298       ------------------------------
3299       -- Size_In_Storage_Elements --
3300       ------------------------------
3301
3302       function Size_In_Storage_Elements (E : Entity_Id) return Node_Id is
3303       begin
3304          --  Logically this just returns E'Max_Size_In_Storage_Elements.
3305          --  However, the reason for the existence of this function is
3306          --  to construct a test for sizes too large, which means near the
3307          --  32-bit limit on a 32-bit machine, and precisely the trouble
3308          --  is that we get overflows when sizes are greater than 2**31.
3309
3310          --  So what we end up doing for array types is to use the expression:
3311
3312          --    number-of-elements * component_type'Max_Size_In_Storage_Elements
3313
3314          --  which avoids this problem. All this is a big bogus, but it does
3315          --  mean we catch common cases of trying to allocate arrays that
3316          --  are too large, and which in the absence of a check results in
3317          --  undetected chaos ???
3318
3319          declare
3320             Len : Node_Id;
3321             Res : Node_Id;
3322
3323          begin
3324             for J in 1 .. Number_Dimensions (E) loop
3325                Len :=
3326                  Make_Attribute_Reference (Loc,
3327                    Prefix         => New_Occurrence_Of (E, Loc),
3328                    Attribute_Name => Name_Length,
3329                    Expressions    => New_List (
3330                      Make_Integer_Literal (Loc, J)));
3331
3332                if J = 1 then
3333                   Res := Len;
3334
3335                else
3336                   Res :=
3337                     Make_Op_Multiply (Loc,
3338                       Left_Opnd  => Res,
3339                       Right_Opnd => Len);
3340                end if;
3341             end loop;
3342
3343             return
3344               Make_Op_Multiply (Loc,
3345                 Left_Opnd  => Len,
3346                 Right_Opnd =>
3347                   Make_Attribute_Reference (Loc,
3348                     Prefix => New_Occurrence_Of (Component_Type (E), Loc),
3349                     Attribute_Name => Name_Max_Size_In_Storage_Elements));
3350          end;
3351       end Size_In_Storage_Elements;
3352
3353    --  Start of processing for Expand_N_Allocator
3354
3355    begin
3356       --  RM E.2.3(22). We enforce that the expected type of an allocator
3357       --  shall not be a remote access-to-class-wide-limited-private type
3358
3359       --  Why is this being done at expansion time, seems clearly wrong ???
3360
3361       Validate_Remote_Access_To_Class_Wide_Type (N);
3362
3363       --  Set the Storage Pool
3364
3365       Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
3366
3367       if Present (Storage_Pool (N)) then
3368          if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
3369             if VM_Target = No_VM then
3370                Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
3371             end if;
3372
3373          elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
3374             Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
3375
3376          else
3377             Set_Procedure_To_Call (N,
3378               Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
3379          end if;
3380       end if;
3381
3382       --  Under certain circumstances we can replace an allocator by an access
3383       --  to statically allocated storage. The conditions, as noted in AARM
3384       --  3.10 (10c) are as follows:
3385
3386       --    Size and initial value is known at compile time
3387       --    Access type is access-to-constant
3388
3389       --  The allocator is not part of a constraint on a record component,
3390       --  because in that case the inserted actions are delayed until the
3391       --  record declaration is fully analyzed, which is too late for the
3392       --  analysis of the rewritten allocator.
3393
3394       if Is_Access_Constant (PtrT)
3395         and then Nkind (Expression (N)) = N_Qualified_Expression
3396         and then Compile_Time_Known_Value (Expression (Expression (N)))
3397         and then Size_Known_At_Compile_Time (Etype (Expression
3398                                                     (Expression (N))))
3399         and then not Is_Record_Type (Current_Scope)
3400       then
3401          --  Here we can do the optimization. For the allocator
3402
3403          --    new x'(y)
3404
3405          --  We insert an object declaration
3406
3407          --    Tnn : aliased x := y;
3408
3409          --  and replace the allocator by Tnn'Unrestricted_Access. Tnn is
3410          --  marked as requiring static allocation.
3411
3412          Temp := Make_Temporary (Loc, 'T', Expression (Expression (N)));
3413          Desig := Subtype_Mark (Expression (N));
3414
3415          --  If context is constrained, use constrained subtype directly,
3416          --  so that the constant is not labelled as having a nominally
3417          --  unconstrained subtype.
3418
3419          if Entity (Desig) = Base_Type (Dtyp) then
3420             Desig := New_Occurrence_Of (Dtyp, Loc);
3421          end if;
3422
3423          Insert_Action (N,
3424            Make_Object_Declaration (Loc,
3425              Defining_Identifier => Temp,
3426              Aliased_Present     => True,
3427              Constant_Present    => Is_Access_Constant (PtrT),
3428              Object_Definition   => Desig,
3429              Expression          => Expression (Expression (N))));
3430
3431          Rewrite (N,
3432            Make_Attribute_Reference (Loc,
3433              Prefix => New_Occurrence_Of (Temp, Loc),
3434              Attribute_Name => Name_Unrestricted_Access));
3435
3436          Analyze_And_Resolve (N, PtrT);
3437
3438          --  We set the variable as statically allocated, since we don't want
3439          --  it going on the stack of the current procedure!
3440
3441          Set_Is_Statically_Allocated (Temp);
3442          return;
3443       end if;
3444
3445       --  Same if the allocator is an access discriminant for a local object:
3446       --  instead of an allocator we create a local value and constrain the
3447       --  the enclosing object with the corresponding access attribute.
3448
3449       if Is_Static_Coextension (N) then
3450          Rewrite_Coextension (N);
3451          return;
3452       end if;
3453
3454       --  The current allocator creates an object which may contain nested
3455       --  coextensions. Use the current allocator's finalization list to
3456       --  generate finalization call for all nested coextensions.
3457
3458       if Is_Coextension_Root (N) then
3459          Complete_Coextension_Finalization;
3460       end if;
3461
3462       --  Check for size too large, we do this because the back end misses
3463       --  proper checks here and can generate rubbish allocation calls when
3464       --  we are near the limit. We only do this for the 32-bit address case
3465       --  since that is from a practical point of view where we see a problem.
3466
3467       if System_Address_Size = 32
3468         and then not Storage_Checks_Suppressed (PtrT)
3469         and then not Storage_Checks_Suppressed (Dtyp)
3470         and then not Storage_Checks_Suppressed (Etyp)
3471       then
3472          --  The check we want to generate should look like
3473
3474          --  if Etyp'Max_Size_In_Storage_Elements > 3.5 gigabytes then
3475          --    raise Storage_Error;
3476          --  end if;
3477
3478          --  where 3.5 gigabytes is a constant large enough to accomodate any
3479          --  reasonable request for. But we can't do it this way because at
3480          --  least at the moment we don't compute this attribute right, and
3481          --  can silently give wrong results when the result gets large. Since
3482          --  this is all about large results, that's bad, so instead we only
3483          --  apply the check for constrained arrays, and manually compute the
3484          --  value of the attribute ???
3485
3486          if Is_Array_Type (Etyp) and then Is_Constrained (Etyp) then
3487             Insert_Action (N,
3488               Make_Raise_Storage_Error (Loc,
3489                 Condition =>
3490                   Make_Op_Gt (Loc,
3491                     Left_Opnd  => Size_In_Storage_Elements (Etyp),
3492                     Right_Opnd =>
3493                       Make_Integer_Literal (Loc,
3494                         Intval => Uint_7 * (Uint_2 ** 29))),
3495                 Reason    => SE_Object_Too_Large));
3496          end if;
3497       end if;
3498
3499       --  Handle case of qualified expression (other than optimization above)
3500       --  First apply constraint checks, because the bounds or discriminants
3501       --  in the aggregate might not match the subtype mark in the allocator.
3502
3503       if Nkind (Expression (N)) = N_Qualified_Expression then
3504          Apply_Constraint_Check
3505            (Expression (Expression (N)), Etype (Expression (N)));
3506
3507          Expand_Allocator_Expression (N);
3508          return;
3509       end if;
3510
3511       --  If the allocator is for a type which requires initialization, and
3512       --  there is no initial value (i.e. operand is a subtype indication
3513       --  rather than a qualified expression), then we must generate a call to
3514       --  the initialization routine using an expressions action node:
3515
3516       --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
3517
3518       --  Here ptr_T is the pointer type for the allocator, and T is the
3519       --  subtype of the allocator. A special case arises if the designated
3520       --  type of the access type is a task or contains tasks. In this case
3521       --  the call to Init (Temp.all ...) is replaced by code that ensures
3522       --  that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
3523       --  for details). In addition, if the type T is a task T, then the
3524       --  first argument to Init must be converted to the task record type.
3525
3526       declare
3527          T            : constant Entity_Id := Entity (Expression (N));
3528          Init         : Entity_Id;
3529          Arg1         : Node_Id;
3530          Args         : List_Id;
3531          Decls        : List_Id;
3532          Decl         : Node_Id;
3533          Discr        : Elmt_Id;
3534          Flist        : Node_Id;
3535          Temp_Decl    : Node_Id;
3536          Temp_Type    : Entity_Id;
3537          Attach_Level : Uint;
3538
3539       begin
3540          if No_Initialization (N) then
3541             null;
3542
3543          --  Case of no initialization procedure present
3544
3545          elsif not Has_Non_Null_Base_Init_Proc (T) then
3546
3547             --  Case of simple initialization required
3548
3549             if Needs_Simple_Initialization (T) then
3550                Check_Restriction (No_Default_Initialization, N);
3551                Rewrite (Expression (N),
3552                  Make_Qualified_Expression (Loc,
3553                    Subtype_Mark => New_Occurrence_Of (T, Loc),
3554                    Expression   => Get_Simple_Init_Val (T, N)));
3555
3556                Analyze_And_Resolve (Expression (Expression (N)), T);
3557                Analyze_And_Resolve (Expression (N), T);
3558                Set_Paren_Count     (Expression (Expression (N)), 1);
3559                Expand_N_Allocator  (N);
3560
3561             --  No initialization required
3562
3563             else
3564                null;
3565             end if;
3566
3567          --  Case of initialization procedure present, must be called
3568
3569          else
3570             Check_Restriction (No_Default_Initialization, N);
3571
3572             if not Restriction_Active (No_Default_Initialization) then
3573                Init := Base_Init_Proc (T);
3574                Nod  := N;
3575                Temp := Make_Temporary (Loc, 'P');
3576
3577                --  Construct argument list for the initialization routine call
3578
3579                Arg1 :=
3580                  Make_Explicit_Dereference (Loc,
3581                    Prefix => New_Reference_To (Temp, Loc));
3582                Set_Assignment_OK (Arg1);
3583                Temp_Type := PtrT;
3584
3585                --  The initialization procedure expects a specific type. if the
3586                --  context is access to class wide, indicate that the object
3587                --  being allocated has the right specific type.
3588
3589                if Is_Class_Wide_Type (Dtyp) then
3590                   Arg1 := Unchecked_Convert_To (T, Arg1);
3591                end if;
3592
3593                --  If designated type is a concurrent type or if it is private
3594                --  type whose definition is a concurrent type, the first
3595                --  argument in the Init routine has to be unchecked conversion
3596                --  to the corresponding record type. If the designated type is
3597                --  a derived type, we also convert the argument to its root
3598                --  type.
3599
3600                if Is_Concurrent_Type (T) then
3601                   Arg1 :=
3602                     Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
3603
3604                elsif Is_Private_Type (T)
3605                  and then Present (Full_View (T))
3606                  and then Is_Concurrent_Type (Full_View (T))
3607                then
3608                   Arg1 :=
3609                     Unchecked_Convert_To
3610                       (Corresponding_Record_Type (Full_View (T)), Arg1);
3611
3612                elsif Etype (First_Formal (Init)) /= Base_Type (T) then
3613                   declare
3614                      Ftyp : constant Entity_Id := Etype (First_Formal (Init));
3615                   begin
3616                      Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
3617                      Set_Etype (Arg1, Ftyp);
3618                   end;
3619                end if;
3620
3621                Args := New_List (Arg1);
3622
3623                --  For the task case, pass the Master_Id of the access type as
3624                --  the value of the _Master parameter, and _Chain as the value
3625                --  of the _Chain parameter (_Chain will be defined as part of
3626                --  the generated code for the allocator).
3627
3628                --  In Ada 2005, the context may be a function that returns an
3629                --  anonymous access type. In that case the Master_Id has been
3630                --  created when expanding the function declaration.
3631
3632                if Has_Task (T) then
3633                   if No (Master_Id (Base_Type (PtrT))) then
3634
3635                      --  If we have a non-library level task with restriction
3636                      --  No_Task_Hierarchy set, then no point in expanding.
3637
3638                      if not Is_Library_Level_Entity (T)
3639                        and then Restriction_Active (No_Task_Hierarchy)
3640                      then
3641                         return;
3642                      end if;
3643
3644                      --  The designated type was an incomplete type, and the
3645                      --  access type did not get expanded. Salvage it now.
3646
3647                      if not Restriction_Active (No_Task_Hierarchy) then
3648                         pragma Assert (Present (Parent (Base_Type (PtrT))));
3649                         Expand_N_Full_Type_Declaration
3650                           (Parent (Base_Type (PtrT)));
3651                      end if;
3652                   end if;
3653
3654                   --  If the context of the allocator is a declaration or an
3655                   --  assignment, we can generate a meaningful image for it,
3656                   --  even though subsequent assignments might remove the
3657                   --  connection between task and entity. We build this image
3658                   --  when the left-hand side is a simple variable, a simple
3659                   --  indexed assignment or a simple selected component.
3660
3661                   if Nkind (Parent (N)) = N_Assignment_Statement then
3662                      declare
3663                         Nam : constant Node_Id := Name (Parent (N));
3664
3665                      begin
3666                         if Is_Entity_Name (Nam) then
3667                            Decls :=
3668                              Build_Task_Image_Decls
3669                                (Loc,
3670                                 New_Occurrence_Of
3671                                   (Entity (Nam), Sloc (Nam)), T);
3672
3673                         elsif Nkind_In
3674                           (Nam, N_Indexed_Component, N_Selected_Component)
3675                           and then Is_Entity_Name (Prefix (Nam))
3676                         then
3677                            Decls :=
3678                              Build_Task_Image_Decls
3679                                (Loc, Nam, Etype (Prefix (Nam)));
3680                         else
3681                            Decls := Build_Task_Image_Decls (Loc, T, T);
3682                         end if;
3683                      end;
3684
3685                   elsif Nkind (Parent (N)) = N_Object_Declaration then
3686                      Decls :=
3687                        Build_Task_Image_Decls
3688                          (Loc, Defining_Identifier (Parent (N)), T);
3689
3690                   else
3691                      Decls := Build_Task_Image_Decls (Loc, T, T);
3692                   end if;
3693
3694                   if Restriction_Active (No_Task_Hierarchy) then
3695                      --  3 is System.Tasking.Library_Task_Level
3696                      Append_To (Args, Make_Integer_Literal (Loc, 3));
3697                   else
3698                      Append_To (Args,
3699                        New_Reference_To
3700                          (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
3701                   end if;
3702
3703                   Append_To (Args, Make_Identifier (Loc, Name_uChain));
3704
3705                   Decl := Last (Decls);
3706                   Append_To (Args,
3707                     New_Occurrence_Of (Defining_Identifier (Decl), Loc));
3708
3709                --  Has_Task is false, Decls not used
3710
3711                else
3712                   Decls := No_List;
3713                end if;
3714
3715                --  Add discriminants if discriminated type
3716
3717                declare
3718                   Dis : Boolean := False;
3719                   Typ : Entity_Id;
3720
3721                begin
3722                   if Has_Discriminants (T) then
3723                      Dis := True;
3724                      Typ := T;
3725
3726                   elsif Is_Private_Type (T)
3727                     and then Present (Full_View (T))
3728                     and then Has_Discriminants (Full_View (T))
3729                   then
3730                      Dis := True;
3731                      Typ := Full_View (T);
3732                   end if;
3733
3734                   if Dis then
3735
3736                      --  If the allocated object will be constrained by the
3737                      --  default values for discriminants, then build a subtype
3738                      --  with those defaults, and change the allocated subtype
3739                      --  to that. Note that this happens in fewer cases in Ada
3740                      --  2005 (AI-363).
3741
3742                      if not Is_Constrained (Typ)
3743                        and then Present (Discriminant_Default_Value
3744                                          (First_Discriminant (Typ)))
3745                        and then (Ada_Version < Ada_05
3746                                   or else
3747                                     not Has_Constrained_Partial_View (Typ))
3748                      then
3749                         Typ := Build_Default_Subtype (Typ, N);
3750                         Set_Expression (N, New_Reference_To (Typ, Loc));
3751                      end if;
3752
3753                      Discr := First_Elmt (Discriminant_Constraint (Typ));
3754                      while Present (Discr) loop
3755                         Nod := Node (Discr);
3756                         Append (New_Copy_Tree (Node (Discr)), Args);
3757
3758                         --  AI-416: when the discriminant constraint is an
3759                         --  anonymous access type make sure an accessibility
3760                         --  check is inserted if necessary (3.10.2(22.q/2))
3761
3762                         if Ada_Version >= Ada_05
3763                           and then
3764                             Ekind (Etype (Nod)) = E_Anonymous_Access_Type
3765                         then
3766                            Apply_Accessibility_Check
3767                              (Nod, Typ, Insert_Node => Nod);
3768                         end if;
3769
3770                         Next_Elmt (Discr);
3771                      end loop;
3772                   end if;
3773                end;
3774
3775                --  We set the allocator as analyzed so that when we analyze the
3776                --  expression actions node, we do not get an unwanted recursive
3777                --  expansion of the allocator expression.
3778
3779                Set_Analyzed (N, True);
3780                Nod := Relocate_Node (N);
3781
3782                --  Here is the transformation:
3783                --    input:  new T
3784                --    output: Temp : constant ptr_T := new T;
3785                --            Init (Temp.all, ...);
3786                --    <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
3787                --    <CTRL>  Initialize (Finalizable (Temp.all));
3788
3789                --  Here ptr_T is the pointer type for the allocator, and is the
3790                --  subtype of the allocator.
3791
3792                Temp_Decl :=
3793                  Make_Object_Declaration (Loc,
3794                    Defining_Identifier => Temp,
3795                    Constant_Present    => True,
3796                    Object_Definition   => New_Reference_To (Temp_Type, Loc),
3797                    Expression          => Nod);
3798
3799                Set_Assignment_OK (Temp_Decl);
3800                Insert_Action (N, Temp_Decl, Suppress => All_Checks);
3801
3802                --  If the designated type is a task type or contains tasks,
3803                --  create block to activate created tasks, and insert
3804                --  declaration for Task_Image variable ahead of call.
3805
3806                if Has_Task (T) then
3807                   declare
3808                      L   : constant List_Id := New_List;
3809                      Blk : Node_Id;
3810                   begin
3811                      Build_Task_Allocate_Block (L, Nod, Args);
3812                      Blk := Last (L);
3813                      Insert_List_Before (First (Declarations (Blk)), Decls);
3814                      Insert_Actions (N, L);
3815                   end;
3816
3817                else
3818                   Insert_Action (N,
3819                     Make_Procedure_Call_Statement (Loc,
3820                       Name                   => New_Reference_To (Init, Loc),
3821                       Parameter_Associations => Args));
3822                end if;
3823
3824                if Needs_Finalization (T) then
3825
3826                   --  Postpone the generation of a finalization call for the
3827                   --  current allocator if it acts as a coextension.
3828
3829                   if Is_Dynamic_Coextension (N) then
3830                      if No (Coextensions (N)) then
3831                         Set_Coextensions (N, New_Elmt_List);
3832                      end if;
3833
3834                      Append_Elmt (New_Copy_Tree (Arg1), Coextensions (N));
3835
3836                   else
3837                      Flist :=
3838                        Get_Allocator_Final_List (N, Base_Type (T), PtrT);
3839
3840                      --  Anonymous access types created for access parameters
3841                      --  are attached to an explicitly constructed controller,
3842                      --  which ensures that they can be finalized properly,
3843                      --  even if their deallocation might not happen. The list
3844                      --  associated with the controller is doubly-linked. For
3845                      --  other anonymous access types, the object may end up
3846                      --  on the global final list which is singly-linked.
3847                      --  Work needed for access discriminants in Ada 2005 ???
3848
3849                      if Ekind (PtrT) = E_Anonymous_Access_Type then
3850                         Attach_Level := Uint_1;
3851                      else
3852                         Attach_Level := Uint_2;
3853                      end if;
3854
3855                      Insert_Actions (N,
3856                        Make_Init_Call (
3857                          Ref          => New_Copy_Tree (Arg1),
3858                          Typ          => T,
3859                          Flist_Ref    => Flist,
3860                          With_Attach  => Make_Integer_Literal (Loc,
3861                                            Intval => Attach_Level)));
3862                   end if;
3863                end if;
3864
3865                Rewrite (N, New_Reference_To (Temp, Loc));
3866                Analyze_And_Resolve (N, PtrT);
3867             end if;
3868          end if;
3869       end;
3870
3871       --  Ada 2005 (AI-251): If the allocator is for a class-wide interface
3872       --  object that has been rewritten as a reference, we displace "this"
3873       --  to reference properly its secondary dispatch table.
3874
3875       if Nkind (N) = N_Identifier
3876         and then Is_Interface (Dtyp)
3877       then
3878          Displace_Allocator_Pointer (N);
3879       end if;
3880
3881    exception
3882       when RE_Not_Available =>
3883          return;
3884    end Expand_N_Allocator;
3885
3886    -----------------------
3887    -- Expand_N_And_Then --
3888    -----------------------
3889
3890    procedure Expand_N_And_Then (N : Node_Id)
3891      renames Expand_Short_Circuit_Operator;
3892
3893    ------------------------------
3894    -- Expand_N_Case_Expression --
3895    ------------------------------
3896
3897    procedure Expand_N_Case_Expression (N : Node_Id) is
3898       Loc     : constant Source_Ptr := Sloc (N);
3899       Typ     : constant Entity_Id  := Etype (N);
3900       Cstmt   : Node_Id;
3901       Tnn     : Entity_Id;
3902       Pnn     : Entity_Id;
3903       Actions : List_Id;
3904       Ttyp    : Entity_Id;
3905       Alt     : Node_Id;
3906       Fexp    : Node_Id;
3907
3908    begin
3909       --  We expand
3910
3911       --    case X is when A => AX, when B => BX ...
3912
3913       --  to
3914
3915       --    do
3916       --       Tnn : typ;
3917       --       case X is
3918       --          when A =>
3919       --             Tnn := AX;
3920       --          when B =>
3921       --             Tnn := BX;
3922       --          ...
3923       --       end case;
3924       --    in Tnn end;
3925
3926       --  However, this expansion is wrong for limited types, and also
3927       --  wrong for unconstrained types (since the bounds may not be the
3928       --  same in all branches). Furthermore it involves an extra copy
3929       --  for large objects. So we take care of this by using the following
3930       --  modified expansion for non-scalar types:
3931
3932       --    do
3933       --       type Pnn is access all typ;
3934       --       Tnn : Pnn;
3935       --       case X is
3936       --          when A =>
3937       --             T := AX'Unrestricted_Access;
3938       --          when B =>
3939       --             T := BX'Unrestricted_Access;
3940       --          ...
3941       --       end case;
3942       --    in Tnn.all end;
3943
3944       Cstmt :=
3945         Make_Case_Statement (Loc,
3946           Expression   => Expression (N),
3947           Alternatives => New_List);
3948
3949       Actions := New_List;
3950
3951       --  Scalar case
3952
3953       if Is_Scalar_Type (Typ) then
3954          Ttyp := Typ;
3955
3956       else
3957          Pnn := Make_Temporary (Loc, 'P');
3958          Append_To (Actions,
3959            Make_Full_Type_Declaration (Loc,
3960              Defining_Identifier => Pnn,
3961              Type_Definition =>
3962                Make_Access_To_Object_Definition (Loc,
3963                  All_Present => True,
3964                  Subtype_Indication =>
3965                    New_Reference_To (Typ, Loc))));
3966          Ttyp := Pnn;
3967       end if;
3968
3969       Tnn := Make_Temporary (Loc, 'T');
3970       Append_To (Actions,
3971         Make_Object_Declaration (Loc,
3972           Defining_Identifier => Tnn,
3973           Object_Definition   => New_Occurrence_Of (Ttyp, Loc)));
3974
3975       --  Now process the alternatives
3976
3977       Alt := First (Alternatives (N));
3978       while Present (Alt) loop
3979          declare
3980             Aexp : Node_Id             := Expression (Alt);
3981             Aloc : constant Source_Ptr := Sloc (Aexp);
3982
3983          begin
3984             if not Is_Scalar_Type (Typ) then
3985                Aexp :=
3986                  Make_Attribute_Reference (Aloc,
3987                    Prefix         => Relocate_Node (Aexp),
3988                    Attribute_Name => Name_Unrestricted_Access);
3989             end if;
3990
3991             Append_To
3992               (Alternatives (Cstmt),
3993                Make_Case_Statement_Alternative (Sloc (Alt),
3994                  Discrete_Choices => Discrete_Choices (Alt),
3995                  Statements       => New_List (
3996                    Make_Assignment_Statement (Aloc,
3997                      Name       => New_Occurrence_Of (Tnn, Loc),
3998                      Expression => Aexp))));
3999          end;
4000
4001          Next (Alt);
4002       end loop;
4003
4004       Append_To (Actions, Cstmt);
4005
4006       --  Construct and return final expression with actions
4007
4008       if Is_Scalar_Type (Typ) then
4009          Fexp := New_Occurrence_Of (Tnn, Loc);
4010       else
4011          Fexp :=
4012            Make_Explicit_Dereference (Loc,
4013              Prefix => New_Occurrence_Of (Tnn, Loc));
4014       end if;
4015
4016       Rewrite (N,
4017         Make_Expression_With_Actions (Loc,
4018           Expression => Fexp,
4019           Actions    => Actions));
4020
4021       Analyze_And_Resolve (N, Typ);
4022    end Expand_N_Case_Expression;
4023
4024    -------------------------------------
4025    -- Expand_N_Conditional_Expression --
4026    -------------------------------------
4027
4028    --  Deal with limited types and expression actions
4029
4030    procedure Expand_N_Conditional_Expression (N : Node_Id) is
4031       Loc    : constant Source_Ptr := Sloc (N);
4032       Cond   : constant Node_Id    := First (Expressions (N));
4033       Thenx  : constant Node_Id    := Next (Cond);
4034       Elsex  : constant Node_Id    := Next (Thenx);
4035       Typ    : constant Entity_Id  := Etype (N);
4036
4037       Cnn     : Entity_Id;
4038       Decl    : Node_Id;
4039       New_If  : Node_Id;
4040       New_N   : Node_Id;
4041       P_Decl  : Node_Id;
4042       Expr    : Node_Id;
4043       Actions : List_Id;
4044
4045    begin
4046       --  Fold at compile time if condition known. We have already folded
4047       --  static conditional expressions, but it is possible to fold any
4048       --  case in which the condition is known at compile time, even though
4049       --  the result is non-static.
4050
4051       --  Note that we don't do the fold of such cases in Sem_Elab because
4052       --  it can cause infinite loops with the expander adding a conditional
4053       --  expression, and Sem_Elab circuitry removing it repeatedly.
4054
4055       if Compile_Time_Known_Value (Cond) then
4056          if Is_True (Expr_Value (Cond)) then
4057             Expr := Thenx;
4058             Actions := Then_Actions (N);
4059          else
4060             Expr := Elsex;
4061             Actions := Else_Actions (N);
4062          end if;
4063
4064          Remove (Expr);
4065
4066          if Present (Actions) then
4067
4068             --  If we are not allowed to use Expression_With_Actions, just
4069             --  skip the optimization, it is not critical for correctness.
4070
4071             if not Use_Expression_With_Actions then
4072                goto Skip_Optimization;
4073             end if;
4074
4075             Rewrite (N,
4076               Make_Expression_With_Actions (Loc,
4077                 Expression => Relocate_Node (Expr),
4078                 Actions    => Actions));
4079             Analyze_And_Resolve (N, Typ);
4080
4081          else
4082             Rewrite (N, Relocate_Node (Expr));
4083          end if;
4084
4085          --  Note that the result is never static (legitimate cases of static
4086          --  conditional expressions were folded in Sem_Eval).
4087
4088          Set_Is_Static_Expression (N, False);
4089          return;
4090       end if;
4091
4092       <<Skip_Optimization>>
4093
4094       --  If the type is limited or unconstrained, we expand as follows to
4095       --  avoid any possibility of improper copies.
4096
4097       --  Note: it may be possible to avoid this special processing if the
4098       --  back end uses its own mechanisms for handling by-reference types ???
4099
4100       --      type Ptr is access all Typ;
4101       --      Cnn : Ptr;
4102       --      if cond then
4103       --         <<then actions>>
4104       --         Cnn := then-expr'Unrestricted_Access;
4105       --      else
4106       --         <<else actions>>
4107       --         Cnn := else-expr'Unrestricted_Access;
4108       --      end if;
4109
4110       --  and replace the conditional expresion by a reference to Cnn.all.
4111
4112       --  This special case can be skipped if the back end handles limited
4113       --  types properly and ensures that no incorrect copies are made.
4114
4115       if Is_By_Reference_Type (Typ)
4116         and then not Back_End_Handles_Limited_Types
4117       then
4118          Cnn := Make_Temporary (Loc, 'C', N);
4119
4120          P_Decl :=
4121            Make_Full_Type_Declaration (Loc,
4122              Defining_Identifier => Make_Temporary (Loc, 'A'),
4123              Type_Definition =>
4124                Make_Access_To_Object_Definition (Loc,
4125                  All_Present => True,
4126                  Subtype_Indication =>
4127                    New_Reference_To (Typ, Loc)));
4128
4129          Insert_Action (N, P_Decl);
4130
4131          Decl :=
4132             Make_Object_Declaration (Loc,
4133               Defining_Identifier => Cnn,
4134               Object_Definition   =>
4135                    New_Occurrence_Of (Defining_Identifier (P_Decl), Loc));
4136
4137          New_If :=
4138            Make_Implicit_If_Statement (N,
4139              Condition => Relocate_Node (Cond),
4140
4141              Then_Statements => New_List (
4142                Make_Assignment_Statement (Sloc (Thenx),
4143                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
4144                  Expression =>
4145                    Make_Attribute_Reference (Loc,
4146                      Attribute_Name => Name_Unrestricted_Access,
4147                      Prefix =>  Relocate_Node (Thenx)))),
4148
4149              Else_Statements => New_List (
4150                Make_Assignment_Statement (Sloc (Elsex),
4151                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
4152                  Expression =>
4153                    Make_Attribute_Reference (Loc,
4154                      Attribute_Name => Name_Unrestricted_Access,
4155                      Prefix => Relocate_Node (Elsex)))));
4156
4157          New_N :=
4158            Make_Explicit_Dereference (Loc,
4159              Prefix => New_Occurrence_Of (Cnn, Loc));
4160
4161       --  For other types, we only need to expand if there are other actions
4162       --  associated with either branch.
4163
4164       elsif Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
4165
4166          --  We have two approaches to handling this. If we are allowed to use
4167          --  N_Expression_With_Actions, then we can just wrap the actions into
4168          --  the appropriate expression.
4169
4170          if Use_Expression_With_Actions then
4171             if Present (Then_Actions (N)) then
4172                Rewrite (Thenx,
4173                  Make_Expression_With_Actions (Sloc (Thenx),
4174                    Actions    => Then_Actions (N),
4175                    Expression => Relocate_Node (Thenx)));
4176                Set_Then_Actions (N, No_List);
4177                Analyze_And_Resolve (Thenx, Typ);
4178             end if;
4179
4180             if Present (Else_Actions (N)) then
4181                Rewrite (Elsex,
4182                  Make_Expression_With_Actions (Sloc (Elsex),
4183                    Actions    => Else_Actions (N),
4184                    Expression => Relocate_Node (Elsex)));
4185                Set_Else_Actions (N, No_List);
4186                Analyze_And_Resolve (Elsex, Typ);
4187             end if;
4188
4189             return;
4190
4191             --  if we can't use N_Expression_With_Actions nodes, then we insert
4192             --  the following sequence of actions (using Insert_Actions):
4193
4194             --      Cnn : typ;
4195             --      if cond then
4196             --         <<then actions>>
4197             --         Cnn := then-expr;
4198             --      else
4199             --         <<else actions>>
4200             --         Cnn := else-expr
4201             --      end if;
4202
4203             --  and replace the conditional expression by a reference to Cnn
4204
4205          else
4206             Cnn := Make_Temporary (Loc, 'C', N);
4207
4208             Decl :=
4209               Make_Object_Declaration (Loc,
4210                 Defining_Identifier => Cnn,
4211                 Object_Definition   => New_Occurrence_Of (Typ, Loc));
4212
4213             New_If :=
4214               Make_Implicit_If_Statement (N,
4215                 Condition       => Relocate_Node (Cond),
4216
4217                 Then_Statements => New_List (
4218                   Make_Assignment_Statement (Sloc (Thenx),
4219                     Name       => New_Occurrence_Of (Cnn, Sloc (Thenx)),
4220                     Expression => Relocate_Node (Thenx))),
4221
4222                 Else_Statements => New_List (
4223                   Make_Assignment_Statement (Sloc (Elsex),
4224                     Name       => New_Occurrence_Of (Cnn, Sloc (Elsex)),
4225                     Expression => Relocate_Node (Elsex))));
4226
4227             Set_Assignment_OK (Name (First (Then_Statements (New_If))));
4228             Set_Assignment_OK (Name (First (Else_Statements (New_If))));
4229
4230             New_N := New_Occurrence_Of (Cnn, Loc);
4231          end if;
4232
4233          --  If no actions then no expansion needed, gigi will handle it using
4234          --  the same approach as a C conditional expression.
4235
4236       else
4237          return;
4238       end if;
4239
4240       --  Fall through here for either the limited expansion, or the case of
4241       --  inserting actions for non-limited types. In both these cases, we must
4242       --  move the SLOC of the parent If statement to the newly created one and
4243       --  change it to the SLOC of the expression which, after expansion, will
4244       --  correspond to what is being evaluated.
4245
4246       if Present (Parent (N))
4247         and then Nkind (Parent (N)) = N_If_Statement
4248       then
4249          Set_Sloc (New_If, Sloc (Parent (N)));
4250          Set_Sloc (Parent (N), Loc);
4251       end if;
4252
4253       --  Make sure Then_Actions and Else_Actions are appropriately moved
4254       --  to the new if statement.
4255
4256       if Present (Then_Actions (N)) then
4257          Insert_List_Before
4258            (First (Then_Statements (New_If)), Then_Actions (N));
4259       end if;
4260
4261       if Present (Else_Actions (N)) then
4262          Insert_List_Before
4263            (First (Else_Statements (New_If)), Else_Actions (N));
4264       end if;
4265
4266       Insert_Action (N, Decl);
4267       Insert_Action (N, New_If);
4268       Rewrite (N, New_N);
4269       Analyze_And_Resolve (N, Typ);
4270    end Expand_N_Conditional_Expression;
4271
4272    -----------------------------------
4273    -- Expand_N_Explicit_Dereference --
4274    -----------------------------------
4275
4276    procedure Expand_N_Explicit_Dereference (N : Node_Id) is
4277    begin
4278       --  Insert explicit dereference call for the checked storage pool case
4279
4280       Insert_Dereference_Action (Prefix (N));
4281    end Expand_N_Explicit_Dereference;
4282
4283    -----------------
4284    -- Expand_N_In --
4285    -----------------
4286
4287    procedure Expand_N_In (N : Node_Id) is
4288       Loc    : constant Source_Ptr := Sloc (N);
4289       Rtyp   : constant Entity_Id  := Etype (N);
4290       Lop    : constant Node_Id    := Left_Opnd (N);
4291       Rop    : constant Node_Id    := Right_Opnd (N);
4292       Static : constant Boolean    := Is_OK_Static_Expression (N);
4293
4294       procedure Expand_Set_Membership;
4295       --  For each disjunct we create a simple equality or membership test.
4296       --  The whole membership is rewritten as a short-circuit disjunction.
4297
4298       ---------------------------
4299       -- Expand_Set_Membership --
4300       ---------------------------
4301
4302       procedure Expand_Set_Membership is
4303          Alt  : Node_Id;
4304          Res  : Node_Id;
4305
4306          function Make_Cond (Alt : Node_Id) return Node_Id;
4307          --  If the alternative is a subtype mark, create a simple membership
4308          --  test. Otherwise create an equality test for it.
4309
4310          ---------------
4311          -- Make_Cond --
4312          ---------------
4313
4314          function Make_Cond (Alt : Node_Id) return Node_Id is
4315             Cond : Node_Id;
4316             L    : constant Node_Id := New_Copy (Lop);
4317             R    : constant Node_Id := Relocate_Node (Alt);
4318
4319          begin
4320             if Is_Entity_Name (Alt)
4321               and then Is_Type (Entity (Alt))
4322             then
4323                Cond :=
4324                  Make_In (Sloc (Alt),
4325                    Left_Opnd  => L,
4326                    Right_Opnd => R);
4327             else
4328                Cond := Make_Op_Eq (Sloc (Alt),
4329                  Left_Opnd  => L,
4330                  Right_Opnd => R);
4331             end if;
4332
4333             return Cond;
4334          end Make_Cond;
4335
4336       --  Start of proessing for Expand_N_In
4337
4338       begin
4339          Alt := Last (Alternatives (N));
4340          Res := Make_Cond (Alt);
4341
4342          Prev (Alt);
4343          while Present (Alt) loop
4344             Res :=
4345               Make_Or_Else (Sloc (Alt),
4346                 Left_Opnd  => Make_Cond (Alt),
4347                 Right_Opnd => Res);
4348             Prev (Alt);
4349          end loop;
4350
4351          Rewrite (N, Res);
4352          Analyze_And_Resolve (N, Standard_Boolean);
4353       end Expand_Set_Membership;
4354
4355       procedure Substitute_Valid_Check;
4356       --  Replaces node N by Lop'Valid. This is done when we have an explicit
4357       --  test for the left operand being in range of its subtype.
4358
4359       ----------------------------
4360       -- Substitute_Valid_Check --
4361       ----------------------------
4362
4363       procedure Substitute_Valid_Check is
4364       begin
4365          Rewrite (N,
4366            Make_Attribute_Reference (Loc,
4367              Prefix         => Relocate_Node (Lop),
4368              Attribute_Name => Name_Valid));
4369
4370          Analyze_And_Resolve (N, Rtyp);
4371
4372          Error_Msg_N ("?explicit membership test may be optimized away", N);
4373          Error_Msg_N -- CODEFIX
4374            ("\?use ''Valid attribute instead", N);
4375          return;
4376       end Substitute_Valid_Check;
4377
4378    --  Start of processing for Expand_N_In
4379
4380    begin
4381       if Present (Alternatives (N)) then
4382          Remove_Side_Effects (Lop);
4383          Expand_Set_Membership;
4384          return;
4385       end if;
4386
4387       --  Check case of explicit test for an expression in range of its
4388       --  subtype. This is suspicious usage and we replace it with a 'Valid
4389       --  test and give a warning. For floating point types however, this is a
4390       --  standard way to check for finite numbers, and using 'Valid vould
4391       --  typically be a pessimization.
4392
4393       if Is_Scalar_Type (Etype (Lop))
4394         and then not Is_Floating_Point_Type (Etype (Lop))
4395         and then Nkind (Rop) in N_Has_Entity
4396         and then Etype (Lop) = Entity (Rop)
4397         and then Comes_From_Source (N)
4398         and then VM_Target = No_VM
4399       then
4400          Substitute_Valid_Check;
4401          return;
4402       end if;
4403
4404       --  Do validity check on operands
4405
4406       if Validity_Checks_On and Validity_Check_Operands then
4407          Ensure_Valid (Left_Opnd (N));
4408          Validity_Check_Range (Right_Opnd (N));
4409       end if;
4410
4411       --  Case of explicit range
4412
4413       if Nkind (Rop) = N_Range then
4414          declare
4415             Lo : constant Node_Id := Low_Bound (Rop);
4416             Hi : constant Node_Id := High_Bound (Rop);
4417
4418             Ltyp : constant Entity_Id := Etype (Lop);
4419
4420             Lo_Orig : constant Node_Id := Original_Node (Lo);
4421             Hi_Orig : constant Node_Id := Original_Node (Hi);
4422
4423             Lcheck : Compare_Result;
4424             Ucheck : Compare_Result;
4425
4426             Warn1 : constant Boolean :=
4427                       Constant_Condition_Warnings
4428                         and then Comes_From_Source (N)
4429                         and then not In_Instance;
4430             --  This must be true for any of the optimization warnings, we
4431             --  clearly want to give them only for source with the flag on. We
4432             --  also skip these warnings in an instance since it may be the
4433             --  case that different instantiations have different ranges.
4434
4435             Warn2 : constant Boolean :=
4436                       Warn1
4437                         and then Nkind (Original_Node (Rop)) = N_Range
4438                         and then Is_Integer_Type (Etype (Lo));
4439             --  For the case where only one bound warning is elided, we also
4440             --  insist on an explicit range and an integer type. The reason is
4441             --  that the use of enumeration ranges including an end point is
4442             --  common, as is the use of a subtype name, one of whose bounds is
4443             --  the same as the type of the expression.
4444
4445          begin
4446             --  If test is explicit x'first .. x'last, replace by valid check
4447
4448             if Is_Scalar_Type (Ltyp)
4449               and then Nkind (Lo_Orig) = N_Attribute_Reference
4450               and then Attribute_Name (Lo_Orig) = Name_First
4451               and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity
4452               and then Entity (Prefix (Lo_Orig)) = Ltyp
4453               and then Nkind (Hi_Orig) = N_Attribute_Reference
4454               and then Attribute_Name (Hi_Orig) = Name_Last
4455               and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity
4456               and then Entity (Prefix (Hi_Orig)) = Ltyp
4457               and then Comes_From_Source (N)
4458               and then VM_Target = No_VM
4459             then
4460                Substitute_Valid_Check;
4461                return;
4462             end if;
4463
4464             --  If bounds of type are known at compile time, and the end points
4465             --  are known at compile time and identical, this is another case
4466             --  for substituting a valid test. We only do this for discrete
4467             --  types, since it won't arise in practice for float types.
4468
4469             if Comes_From_Source (N)
4470               and then Is_Discrete_Type (Ltyp)
4471               and then Compile_Time_Known_Value (Type_High_Bound (Ltyp))
4472               and then Compile_Time_Known_Value (Type_Low_Bound  (Ltyp))
4473               and then Compile_Time_Known_Value (Lo)
4474               and then Compile_Time_Known_Value (Hi)
4475               and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi)
4476               and then Expr_Value (Type_Low_Bound  (Ltyp)) = Expr_Value (Lo)
4477
4478                --  Kill warnings in instances, since they may be cases where we
4479                --  have a test in the generic that makes sense with some types
4480                --  and not with other types.
4481
4482               and then not In_Instance
4483             then
4484                Substitute_Valid_Check;
4485                return;
4486             end if;
4487
4488             --  If we have an explicit range, do a bit of optimization based on
4489             --  range analysis (we may be able to kill one or both checks).
4490
4491             Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
4492             Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
4493
4494             --  If either check is known to fail, replace result by False since
4495             --  the other check does not matter. Preserve the static flag for
4496             --  legality checks, because we are constant-folding beyond RM 4.9.
4497
4498             if Lcheck = LT or else Ucheck = GT then
4499                if Warn1 then
4500                   Error_Msg_N ("?range test optimized away", N);
4501                   Error_Msg_N ("\?value is known to be out of range", N);
4502                end if;
4503
4504                Rewrite (N, New_Reference_To (Standard_False, Loc));
4505                Analyze_And_Resolve (N, Rtyp);
4506                Set_Is_Static_Expression (N, Static);
4507
4508                return;
4509
4510             --  If both checks are known to succeed, replace result by True,
4511             --  since we know we are in range.
4512
4513             elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
4514                if Warn1 then
4515                   Error_Msg_N ("?range test optimized away", N);
4516                   Error_Msg_N ("\?value is known to be in range", N);
4517                end if;
4518
4519                Rewrite (N, New_Reference_To (Standard_True, Loc));
4520                Analyze_And_Resolve (N, Rtyp);
4521                Set_Is_Static_Expression (N, Static);
4522
4523                return;
4524
4525             --  If lower bound check succeeds and upper bound check is not
4526             --  known to succeed or fail, then replace the range check with
4527             --  a comparison against the upper bound.
4528
4529             elsif Lcheck in Compare_GE then
4530                if Warn2 and then not In_Instance then
4531                   Error_Msg_N ("?lower bound test optimized away", Lo);
4532                   Error_Msg_N ("\?value is known to be in range", Lo);
4533                end if;
4534
4535                Rewrite (N,
4536                  Make_Op_Le (Loc,
4537                    Left_Opnd  => Lop,
4538                    Right_Opnd => High_Bound (Rop)));
4539                Analyze_And_Resolve (N, Rtyp);
4540
4541                return;
4542
4543             --  If upper bound check succeeds and lower bound check is not
4544             --  known to succeed or fail, then replace the range check with
4545             --  a comparison against the lower bound.
4546
4547             elsif Ucheck in Compare_LE then
4548                if Warn2 and then not In_Instance then
4549                   Error_Msg_N ("?upper bound test optimized away", Hi);
4550                   Error_Msg_N ("\?value is known to be in range", Hi);
4551                end if;
4552
4553                Rewrite (N,
4554                  Make_Op_Ge (Loc,
4555                    Left_Opnd  => Lop,
4556                    Right_Opnd => Low_Bound (Rop)));
4557                Analyze_And_Resolve (N, Rtyp);
4558
4559                return;
4560             end if;
4561
4562             --  We couldn't optimize away the range check, but there is one
4563             --  more issue. If we are checking constant conditionals, then we
4564             --  see if we can determine the outcome assuming everything is
4565             --  valid, and if so give an appropriate warning.
4566
4567             if Warn1 and then not Assume_No_Invalid_Values then
4568                Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
4569                Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
4570
4571                --  Result is out of range for valid value
4572
4573                if Lcheck = LT or else Ucheck = GT then
4574                   Error_Msg_N
4575                     ("?value can only be in range if it is invalid", N);
4576
4577                --  Result is in range for valid value
4578
4579                elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
4580                   Error_Msg_N
4581                     ("?value can only be out of range if it is invalid", N);
4582
4583                --  Lower bound check succeeds if value is valid
4584
4585                elsif Warn2 and then Lcheck in Compare_GE then
4586                   Error_Msg_N
4587                     ("?lower bound check only fails if it is invalid", Lo);
4588
4589                --  Upper bound  check succeeds if value is valid
4590
4591                elsif Warn2 and then Ucheck in Compare_LE then
4592                   Error_Msg_N
4593                     ("?upper bound check only fails for invalid values", Hi);
4594                end if;
4595             end if;
4596          end;
4597
4598          --  For all other cases of an explicit range, nothing to be done
4599
4600          return;
4601
4602       --  Here right operand is a subtype mark
4603
4604       else
4605          declare
4606             Typ       : Entity_Id        := Etype (Rop);
4607             Is_Acc    : constant Boolean := Is_Access_Type (Typ);
4608             Cond      : Node_Id          := Empty;
4609             New_N     : Node_Id;
4610             Obj       : Node_Id          := Lop;
4611             SCIL_Node : Node_Id;
4612
4613          begin
4614             Remove_Side_Effects (Obj);
4615
4616             --  For tagged type, do tagged membership operation
4617
4618             if Is_Tagged_Type (Typ) then
4619
4620                --  No expansion will be performed when VM_Target, as the VM
4621                --  back-ends will handle the membership tests directly (tags
4622                --  are not explicitly represented in Java objects, so the
4623                --  normal tagged membership expansion is not what we want).
4624
4625                if Tagged_Type_Expansion then
4626                   Tagged_Membership (N, SCIL_Node, New_N);
4627                   Rewrite (N, New_N);
4628                   Analyze_And_Resolve (N, Rtyp);
4629
4630                   --  Update decoration of relocated node referenced by the
4631                   --  SCIL node.
4632
4633                   if Generate_SCIL and then Present (SCIL_Node) then
4634                      Set_SCIL_Node (N, SCIL_Node);
4635                   end if;
4636                end if;
4637
4638                return;
4639
4640             --  If type is scalar type, rewrite as x in t'first .. t'last.
4641             --  This reason we do this is that the bounds may have the wrong
4642             --  type if they come from the original type definition. Also this
4643             --  way we get all the processing above for an explicit range.
4644
4645             elsif Is_Scalar_Type (Typ) then
4646                Rewrite (Rop,
4647                  Make_Range (Loc,
4648                    Low_Bound =>
4649                      Make_Attribute_Reference (Loc,
4650                        Attribute_Name => Name_First,
4651                        Prefix => New_Reference_To (Typ, Loc)),
4652
4653                    High_Bound =>
4654                      Make_Attribute_Reference (Loc,
4655                        Attribute_Name => Name_Last,
4656                        Prefix => New_Reference_To (Typ, Loc))));
4657                Analyze_And_Resolve (N, Rtyp);
4658                return;
4659
4660             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
4661             --  a membership test if the subtype mark denotes a constrained
4662             --  Unchecked_Union subtype and the expression lacks inferable
4663             --  discriminants.
4664
4665             elsif Is_Unchecked_Union (Base_Type (Typ))
4666               and then Is_Constrained (Typ)
4667               and then not Has_Inferable_Discriminants (Lop)
4668             then
4669                Insert_Action (N,
4670                  Make_Raise_Program_Error (Loc,
4671                    Reason => PE_Unchecked_Union_Restriction));
4672
4673                --  Prevent Gigi from generating incorrect code by rewriting the
4674                --  test as False.
4675
4676                Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
4677                return;
4678             end if;
4679
4680             --  Here we have a non-scalar type
4681
4682             if Is_Acc then
4683                Typ := Designated_Type (Typ);
4684             end if;
4685
4686             if not Is_Constrained (Typ) then
4687                Rewrite (N, New_Reference_To (Standard_True, Loc));
4688                Analyze_And_Resolve (N, Rtyp);
4689
4690             --  For the constrained array case, we have to check the subscripts
4691             --  for an exact match if the lengths are non-zero (the lengths
4692             --  must match in any case).
4693
4694             elsif Is_Array_Type (Typ) then
4695                Check_Subscripts : declare
4696                   function Build_Attribute_Reference
4697                     (E   : Node_Id;
4698                      Nam : Name_Id;
4699                      Dim : Nat) return Node_Id;
4700                   --  Build attribute reference E'Nam (Dim)
4701
4702                   -------------------------------
4703                   -- Build_Attribute_Reference --
4704                   -------------------------------
4705
4706                   function Build_Attribute_Reference
4707                     (E   : Node_Id;
4708                      Nam : Name_Id;
4709                      Dim : Nat) return Node_Id
4710                   is
4711                   begin
4712                      return
4713                        Make_Attribute_Reference (Loc,
4714                          Prefix         => E,
4715                          Attribute_Name => Nam,
4716                          Expressions    => New_List (
4717                            Make_Integer_Literal (Loc, Dim)));
4718                   end Build_Attribute_Reference;
4719
4720                --  Start of processing for Check_Subscripts
4721
4722                begin
4723                   for J in 1 .. Number_Dimensions (Typ) loop
4724                      Evolve_And_Then (Cond,
4725                        Make_Op_Eq (Loc,
4726                          Left_Opnd  =>
4727                            Build_Attribute_Reference
4728                              (Duplicate_Subexpr_No_Checks (Obj),
4729                               Name_First, J),
4730                          Right_Opnd =>
4731                            Build_Attribute_Reference
4732                              (New_Occurrence_Of (Typ, Loc), Name_First, J)));
4733
4734                      Evolve_And_Then (Cond,
4735                        Make_Op_Eq (Loc,
4736                          Left_Opnd  =>
4737                            Build_Attribute_Reference
4738                              (Duplicate_Subexpr_No_Checks (Obj),
4739                               Name_Last, J),
4740                          Right_Opnd =>
4741                            Build_Attribute_Reference
4742                              (New_Occurrence_Of (Typ, Loc), Name_Last, J)));
4743                   end loop;
4744
4745                   if Is_Acc then
4746                      Cond :=
4747                        Make_Or_Else (Loc,
4748                          Left_Opnd =>
4749                            Make_Op_Eq (Loc,
4750                              Left_Opnd  => Obj,
4751                              Right_Opnd => Make_Null (Loc)),
4752                          Right_Opnd => Cond);
4753                   end if;
4754
4755                   Rewrite (N, Cond);
4756                   Analyze_And_Resolve (N, Rtyp);
4757                end Check_Subscripts;
4758
4759             --  These are the cases where constraint checks may be required,
4760             --  e.g. records with possible discriminants
4761
4762             else
4763                --  Expand the test into a series of discriminant comparisons.
4764                --  The expression that is built is the negation of the one that
4765                --  is used for checking discriminant constraints.
4766
4767                Obj := Relocate_Node (Left_Opnd (N));
4768
4769                if Has_Discriminants (Typ) then
4770                   Cond := Make_Op_Not (Loc,
4771                     Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
4772
4773                   if Is_Acc then
4774                      Cond := Make_Or_Else (Loc,
4775                        Left_Opnd =>
4776                          Make_Op_Eq (Loc,
4777                            Left_Opnd  => Obj,
4778                            Right_Opnd => Make_Null (Loc)),
4779                        Right_Opnd => Cond);
4780                   end if;
4781
4782                else
4783                   Cond := New_Occurrence_Of (Standard_True, Loc);
4784                end if;
4785
4786                Rewrite (N, Cond);
4787                Analyze_And_Resolve (N, Rtyp);
4788             end if;
4789          end;
4790       end if;
4791    end Expand_N_In;
4792
4793    --------------------------------
4794    -- Expand_N_Indexed_Component --
4795    --------------------------------
4796
4797    procedure Expand_N_Indexed_Component (N : Node_Id) is
4798       Loc : constant Source_Ptr := Sloc (N);
4799       Typ : constant Entity_Id  := Etype (N);
4800       P   : constant Node_Id    := Prefix (N);
4801       T   : constant Entity_Id  := Etype (P);
4802
4803    begin
4804       --  A special optimization, if we have an indexed component that is
4805       --  selecting from a slice, then we can eliminate the slice, since, for
4806       --  example, x (i .. j)(k) is identical to x(k). The only difference is
4807       --  the range check required by the slice. The range check for the slice
4808       --  itself has already been generated. The range check for the
4809       --  subscripting operation is ensured by converting the subject to
4810       --  the subtype of the slice.
4811
4812       --  This optimization not only generates better code, avoiding slice
4813       --  messing especially in the packed case, but more importantly bypasses
4814       --  some problems in handling this peculiar case, for example, the issue
4815       --  of dealing specially with object renamings.
4816
4817       if Nkind (P) = N_Slice then
4818          Rewrite (N,
4819            Make_Indexed_Component (Loc,
4820              Prefix => Prefix (P),
4821              Expressions => New_List (
4822                Convert_To
4823                  (Etype (First_Index (Etype (P))),
4824                   First (Expressions (N))))));
4825          Analyze_And_Resolve (N, Typ);
4826          return;
4827       end if;
4828
4829       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
4830       --  function, then additional actuals must be passed.
4831
4832       if Ada_Version >= Ada_05
4833         and then Is_Build_In_Place_Function_Call (P)
4834       then
4835          Make_Build_In_Place_Call_In_Anonymous_Context (P);
4836       end if;
4837
4838       --  If the prefix is an access type, then we unconditionally rewrite if
4839       --  as an explicit dereference. This simplifies processing for several
4840       --  cases, including packed array cases and certain cases in which checks
4841       --  must be generated. We used to try to do this only when it was
4842       --  necessary, but it cleans up the code to do it all the time.
4843
4844       if Is_Access_Type (T) then
4845          Insert_Explicit_Dereference (P);
4846          Analyze_And_Resolve (P, Designated_Type (T));
4847       end if;
4848
4849       --  Generate index and validity checks
4850
4851       Generate_Index_Checks (N);
4852
4853       if Validity_Checks_On and then Validity_Check_Subscripts then
4854          Apply_Subscript_Validity_Checks (N);
4855       end if;
4856
4857       --  All done for the non-packed case
4858
4859       if not Is_Packed (Etype (Prefix (N))) then
4860          return;
4861       end if;
4862
4863       --  For packed arrays that are not bit-packed (i.e. the case of an array
4864       --  with one or more index types with a non-contiguous enumeration type),
4865       --  we can always use the normal packed element get circuit.
4866
4867       if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
4868          Expand_Packed_Element_Reference (N);
4869          return;
4870       end if;
4871
4872       --  For a reference to a component of a bit packed array, we have to
4873       --  convert it to a reference to the corresponding Packed_Array_Type.
4874       --  We only want to do this for simple references, and not for:
4875
4876       --    Left side of assignment, or prefix of left side of assignment, or
4877       --    prefix of the prefix, to handle packed arrays of packed arrays,
4878       --      This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
4879
4880       --    Renaming objects in renaming associations
4881       --      This case is handled when a use of the renamed variable occurs
4882
4883       --    Actual parameters for a procedure call
4884       --      This case is handled in Exp_Ch6.Expand_Actuals
4885
4886       --    The second expression in a 'Read attribute reference
4887
4888       --    The prefix of an address or bit or size attribute reference
4889
4890       --  The following circuit detects these exceptions
4891
4892       declare
4893          Child : Node_Id := N;
4894          Parnt : Node_Id := Parent (N);
4895
4896       begin
4897          loop
4898             if Nkind (Parnt) = N_Unchecked_Expression then
4899                null;
4900
4901             elsif Nkind_In (Parnt, N_Object_Renaming_Declaration,
4902                                    N_Procedure_Call_Statement)
4903               or else (Nkind (Parnt) = N_Parameter_Association
4904                         and then
4905                           Nkind (Parent (Parnt)) =  N_Procedure_Call_Statement)
4906             then
4907                return;
4908
4909             elsif Nkind (Parnt) = N_Attribute_Reference
4910               and then (Attribute_Name (Parnt) = Name_Address
4911                          or else
4912                         Attribute_Name (Parnt) = Name_Bit
4913                          or else
4914                         Attribute_Name (Parnt) = Name_Size)
4915               and then Prefix (Parnt) = Child
4916             then
4917                return;
4918
4919             elsif Nkind (Parnt) = N_Assignment_Statement
4920               and then Name (Parnt) = Child
4921             then
4922                return;
4923
4924             --  If the expression is an index of an indexed component, it must
4925             --  be expanded regardless of context.
4926
4927             elsif Nkind (Parnt) = N_Indexed_Component
4928               and then Child /= Prefix (Parnt)
4929             then
4930                Expand_Packed_Element_Reference (N);
4931                return;
4932
4933             elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
4934               and then Name (Parent (Parnt)) = Parnt
4935             then
4936                return;
4937
4938             elsif Nkind (Parnt) = N_Attribute_Reference
4939               and then Attribute_Name (Parnt) = Name_Read
4940               and then Next (First (Expressions (Parnt))) = Child
4941             then
4942                return;
4943
4944             elsif Nkind_In (Parnt, N_Indexed_Component, N_Selected_Component)
4945                and then Prefix (Parnt) = Child
4946             then
4947                null;
4948
4949             else
4950                Expand_Packed_Element_Reference (N);
4951                return;
4952             end if;
4953
4954             --  Keep looking up tree for unchecked expression, or if we are the
4955             --  prefix of a possible assignment left side.
4956
4957             Child := Parnt;
4958             Parnt := Parent (Child);
4959          end loop;
4960       end;
4961    end Expand_N_Indexed_Component;
4962
4963    ---------------------
4964    -- Expand_N_Not_In --
4965    ---------------------
4966
4967    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
4968    --  can be done. This avoids needing to duplicate this expansion code.
4969
4970    procedure Expand_N_Not_In (N : Node_Id) is
4971       Loc : constant Source_Ptr := Sloc (N);
4972       Typ : constant Entity_Id  := Etype (N);
4973       Cfs : constant Boolean    := Comes_From_Source (N);
4974
4975    begin
4976       Rewrite (N,
4977         Make_Op_Not (Loc,
4978           Right_Opnd =>
4979             Make_In (Loc,
4980               Left_Opnd  => Left_Opnd (N),
4981               Right_Opnd => Right_Opnd (N))));
4982
4983       --  If this is a set membership, preserve list of alternatives
4984
4985       Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N)));
4986
4987       --  We want this to appear as coming from source if original does (see
4988       --  transformations in Expand_N_In).
4989
4990       Set_Comes_From_Source (N, Cfs);
4991       Set_Comes_From_Source (Right_Opnd (N), Cfs);
4992
4993       --  Now analyze transformed node
4994
4995       Analyze_And_Resolve (N, Typ);
4996    end Expand_N_Not_In;
4997
4998    -------------------
4999    -- Expand_N_Null --
5000    -------------------
5001
5002    --  The only replacement required is for the case of a null of type that is
5003    --  an access to protected subprogram. We represent such access values as a
5004    --  record, and so we must replace the occurrence of null by the equivalent
5005    --  record (with a null address and a null pointer in it), so that the
5006    --  backend creates the proper value.
5007
5008    procedure Expand_N_Null (N : Node_Id) is
5009       Loc : constant Source_Ptr := Sloc (N);
5010       Typ : constant Entity_Id  := Etype (N);
5011       Agg : Node_Id;
5012
5013    begin
5014       if Is_Access_Protected_Subprogram_Type (Typ) then
5015          Agg :=
5016            Make_Aggregate (Loc,
5017              Expressions => New_List (
5018                New_Occurrence_Of (RTE (RE_Null_Address), Loc),
5019                Make_Null (Loc)));
5020
5021          Rewrite (N, Agg);
5022          Analyze_And_Resolve (N, Equivalent_Type (Typ));
5023
5024          --  For subsequent semantic analysis, the node must retain its type.
5025          --  Gigi in any case replaces this type by the corresponding record
5026          --  type before processing the node.
5027
5028          Set_Etype (N, Typ);
5029       end if;
5030
5031    exception
5032       when RE_Not_Available =>
5033          return;
5034    end Expand_N_Null;
5035
5036    ---------------------
5037    -- Expand_N_Op_Abs --
5038    ---------------------
5039
5040    procedure Expand_N_Op_Abs (N : Node_Id) is
5041       Loc  : constant Source_Ptr := Sloc (N);
5042       Expr : constant Node_Id := Right_Opnd (N);
5043
5044    begin
5045       Unary_Op_Validity_Checks (N);
5046
5047       --  Deal with software overflow checking
5048
5049       if not Backend_Overflow_Checks_On_Target
5050          and then Is_Signed_Integer_Type (Etype (N))
5051          and then Do_Overflow_Check (N)
5052       then
5053          --  The only case to worry about is when the argument is equal to the
5054          --  largest negative number, so what we do is to insert the check:
5055
5056          --     [constraint_error when Expr = typ'Base'First]
5057
5058          --  with the usual Duplicate_Subexpr use coding for expr
5059
5060          Insert_Action (N,
5061            Make_Raise_Constraint_Error (Loc,
5062              Condition =>
5063                Make_Op_Eq (Loc,
5064                  Left_Opnd  => Duplicate_Subexpr (Expr),
5065                  Right_Opnd =>
5066                    Make_Attribute_Reference (Loc,
5067                      Prefix =>
5068                        New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
5069                      Attribute_Name => Name_First)),
5070              Reason => CE_Overflow_Check_Failed));
5071       end if;
5072
5073       --  Vax floating-point types case
5074
5075       if Vax_Float (Etype (N)) then
5076          Expand_Vax_Arith (N);
5077       end if;
5078    end Expand_N_Op_Abs;
5079
5080    ---------------------
5081    -- Expand_N_Op_Add --
5082    ---------------------
5083
5084    procedure Expand_N_Op_Add (N : Node_Id) is
5085       Typ : constant Entity_Id := Etype (N);
5086
5087    begin
5088       Binary_Op_Validity_Checks (N);
5089
5090       --  N + 0 = 0 + N = N for integer types
5091
5092       if Is_Integer_Type (Typ) then
5093          if Compile_Time_Known_Value (Right_Opnd (N))
5094            and then Expr_Value (Right_Opnd (N)) = Uint_0
5095          then
5096             Rewrite (N, Left_Opnd (N));
5097             return;
5098
5099          elsif Compile_Time_Known_Value (Left_Opnd (N))
5100            and then Expr_Value (Left_Opnd (N)) = Uint_0
5101          then
5102             Rewrite (N, Right_Opnd (N));
5103             return;
5104          end if;
5105       end if;
5106
5107       --  Arithmetic overflow checks for signed integer/fixed point types
5108
5109       if Is_Signed_Integer_Type (Typ)
5110         or else Is_Fixed_Point_Type (Typ)
5111       then
5112          Apply_Arithmetic_Overflow_Check (N);
5113          return;
5114
5115       --  Vax floating-point types case
5116
5117       elsif Vax_Float (Typ) then
5118          Expand_Vax_Arith (N);
5119       end if;
5120    end Expand_N_Op_Add;
5121
5122    ---------------------
5123    -- Expand_N_Op_And --
5124    ---------------------
5125
5126    procedure Expand_N_Op_And (N : Node_Id) is
5127       Typ : constant Entity_Id := Etype (N);
5128
5129    begin
5130       Binary_Op_Validity_Checks (N);
5131
5132       if Is_Array_Type (Etype (N)) then
5133          Expand_Boolean_Operator (N);
5134
5135       elsif Is_Boolean_Type (Etype (N)) then
5136
5137          --  Replace AND by AND THEN if Short_Circuit_And_Or active and the
5138          --  type is standard Boolean (do not mess with AND that uses a non-
5139          --  standard Boolean type, because something strange is going on).
5140
5141          if Short_Circuit_And_Or and then Typ = Standard_Boolean then
5142             Rewrite (N,
5143               Make_And_Then (Sloc (N),
5144                 Left_Opnd  => Relocate_Node (Left_Opnd (N)),
5145                 Right_Opnd => Relocate_Node (Right_Opnd (N))));
5146             Analyze_And_Resolve (N, Typ);
5147
5148          --  Otherwise, adjust conditions
5149
5150          else
5151             Adjust_Condition (Left_Opnd (N));
5152             Adjust_Condition (Right_Opnd (N));
5153             Set_Etype (N, Standard_Boolean);
5154             Adjust_Result_Type (N, Typ);
5155          end if;
5156       end if;
5157    end Expand_N_Op_And;
5158
5159    ------------------------
5160    -- Expand_N_Op_Concat --
5161    ------------------------
5162
5163    procedure Expand_N_Op_Concat (N : Node_Id) is
5164       Opnds : List_Id;
5165       --  List of operands to be concatenated
5166
5167       Cnode : Node_Id;
5168       --  Node which is to be replaced by the result of concatenating the nodes
5169       --  in the list Opnds.
5170
5171    begin
5172       --  Ensure validity of both operands
5173
5174       Binary_Op_Validity_Checks (N);
5175
5176       --  If we are the left operand of a concatenation higher up the tree,
5177       --  then do nothing for now, since we want to deal with a series of
5178       --  concatenations as a unit.
5179
5180       if Nkind (Parent (N)) = N_Op_Concat
5181         and then N = Left_Opnd (Parent (N))
5182       then
5183          return;
5184       end if;
5185
5186       --  We get here with a concatenation whose left operand may be a
5187       --  concatenation itself with a consistent type. We need to process
5188       --  these concatenation operands from left to right, which means
5189       --  from the deepest node in the tree to the highest node.
5190
5191       Cnode := N;
5192       while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
5193          Cnode := Left_Opnd (Cnode);
5194       end loop;
5195
5196       --  Now Cnode is the deepest concatenation, and its parents are the
5197       --  concatenation nodes above, so now we process bottom up, doing the
5198       --  operations. We gather a string that is as long as possible up to five
5199       --  operands.
5200
5201       --  The outer loop runs more than once if more than one concatenation
5202       --  type is involved.
5203
5204       Outer : loop
5205          Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
5206          Set_Parent (Opnds, N);
5207
5208          --  The inner loop gathers concatenation operands
5209
5210          Inner : while Cnode /= N
5211                    and then Base_Type (Etype (Cnode)) =
5212                             Base_Type (Etype (Parent (Cnode)))
5213          loop
5214             Cnode := Parent (Cnode);
5215             Append (Right_Opnd (Cnode), Opnds);
5216          end loop Inner;
5217
5218          Expand_Concatenate (Cnode, Opnds);
5219
5220          exit Outer when Cnode = N;
5221          Cnode := Parent (Cnode);
5222       end loop Outer;
5223    end Expand_N_Op_Concat;
5224
5225    ------------------------
5226    -- Expand_N_Op_Divide --
5227    ------------------------
5228
5229    procedure Expand_N_Op_Divide (N : Node_Id) is
5230       Loc   : constant Source_Ptr := Sloc (N);
5231       Lopnd : constant Node_Id    := Left_Opnd (N);
5232       Ropnd : constant Node_Id    := Right_Opnd (N);
5233       Ltyp  : constant Entity_Id  := Etype (Lopnd);
5234       Rtyp  : constant Entity_Id  := Etype (Ropnd);
5235       Typ   : Entity_Id           := Etype (N);
5236       Rknow : constant Boolean    := Is_Integer_Type (Typ)
5237                                        and then
5238                                          Compile_Time_Known_Value (Ropnd);
5239       Rval  : Uint;
5240
5241    begin
5242       Binary_Op_Validity_Checks (N);
5243
5244       if Rknow then
5245          Rval := Expr_Value (Ropnd);
5246       end if;
5247
5248       --  N / 1 = N for integer types
5249
5250       if Rknow and then Rval = Uint_1 then
5251          Rewrite (N, Lopnd);
5252          return;
5253       end if;
5254
5255       --  Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
5256       --  Is_Power_Of_2_For_Shift is set means that we know that our left
5257       --  operand is an unsigned integer, as required for this to work.
5258
5259       if Nkind (Ropnd) = N_Op_Expon
5260         and then Is_Power_Of_2_For_Shift (Ropnd)
5261
5262       --  We cannot do this transformation in configurable run time mode if we
5263       --  have 64-bit integers and long shifts are not available.
5264
5265         and then
5266           (Esize (Ltyp) <= 32
5267              or else Support_Long_Shifts_On_Target)
5268       then
5269          Rewrite (N,
5270            Make_Op_Shift_Right (Loc,
5271              Left_Opnd  => Lopnd,
5272              Right_Opnd =>
5273                Convert_To (Standard_Natural, Right_Opnd (Ropnd))));
5274          Analyze_And_Resolve (N, Typ);
5275          return;
5276       end if;
5277
5278       --  Do required fixup of universal fixed operation
5279
5280       if Typ = Universal_Fixed then
5281          Fixup_Universal_Fixed_Operation (N);
5282          Typ := Etype (N);
5283       end if;
5284
5285       --  Divisions with fixed-point results
5286
5287       if Is_Fixed_Point_Type (Typ) then
5288
5289          --  No special processing if Treat_Fixed_As_Integer is set, since
5290          --  from a semantic point of view such operations are simply integer
5291          --  operations and will be treated that way.
5292
5293          if not Treat_Fixed_As_Integer (N) then
5294             if Is_Integer_Type (Rtyp) then
5295                Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
5296             else
5297                Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
5298             end if;
5299          end if;
5300
5301       --  Other cases of division of fixed-point operands. Again we exclude the
5302       --  case where Treat_Fixed_As_Integer is set.
5303
5304       elsif (Is_Fixed_Point_Type (Ltyp) or else
5305              Is_Fixed_Point_Type (Rtyp))
5306         and then not Treat_Fixed_As_Integer (N)
5307       then
5308          if Is_Integer_Type (Typ) then
5309             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
5310          else
5311             pragma Assert (Is_Floating_Point_Type (Typ));
5312             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
5313          end if;
5314
5315       --  Mixed-mode operations can appear in a non-static universal context,
5316       --  in which case the integer argument must be converted explicitly.
5317
5318       elsif Typ = Universal_Real
5319         and then Is_Integer_Type (Rtyp)
5320       then
5321          Rewrite (Ropnd,
5322            Convert_To (Universal_Real, Relocate_Node (Ropnd)));
5323
5324          Analyze_And_Resolve (Ropnd, Universal_Real);
5325
5326       elsif Typ = Universal_Real
5327         and then Is_Integer_Type (Ltyp)
5328       then
5329          Rewrite (Lopnd,
5330            Convert_To (Universal_Real, Relocate_Node (Lopnd)));
5331
5332          Analyze_And_Resolve (Lopnd, Universal_Real);
5333
5334       --  Non-fixed point cases, do integer zero divide and overflow checks
5335
5336       elsif Is_Integer_Type (Typ) then
5337          Apply_Divide_Check (N);
5338
5339          --  Check for 64-bit division available, or long shifts if the divisor
5340          --  is a small power of 2 (since such divides will be converted into
5341          --  long shifts).
5342
5343          if Esize (Ltyp) > 32
5344            and then not Support_64_Bit_Divides_On_Target
5345            and then
5346              (not Rknow
5347                 or else not Support_Long_Shifts_On_Target
5348                 or else (Rval /= Uint_2  and then
5349                          Rval /= Uint_4  and then
5350                          Rval /= Uint_8  and then
5351                          Rval /= Uint_16 and then
5352                          Rval /= Uint_32 and then
5353                          Rval /= Uint_64))
5354          then
5355             Error_Msg_CRT ("64-bit division", N);
5356          end if;
5357
5358       --  Deal with Vax_Float
5359
5360       elsif Vax_Float (Typ) then
5361          Expand_Vax_Arith (N);
5362          return;
5363       end if;
5364    end Expand_N_Op_Divide;
5365
5366    --------------------
5367    -- Expand_N_Op_Eq --
5368    --------------------
5369
5370    procedure Expand_N_Op_Eq (N : Node_Id) is
5371       Loc    : constant Source_Ptr := Sloc (N);
5372       Typ    : constant Entity_Id  := Etype (N);
5373       Lhs    : constant Node_Id    := Left_Opnd (N);
5374       Rhs    : constant Node_Id    := Right_Opnd (N);
5375       Bodies : constant List_Id    := New_List;
5376       A_Typ  : constant Entity_Id  := Etype (Lhs);
5377
5378       Typl    : Entity_Id := A_Typ;
5379       Op_Name : Entity_Id;
5380       Prim    : Elmt_Id;
5381
5382       procedure Build_Equality_Call (Eq : Entity_Id);
5383       --  If a constructed equality exists for the type or for its parent,
5384       --  build and analyze call, adding conversions if the operation is
5385       --  inherited.
5386
5387       function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
5388       --  Determines whether a type has a subcomponent of an unconstrained
5389       --  Unchecked_Union subtype. Typ is a record type.
5390
5391       -------------------------
5392       -- Build_Equality_Call --
5393       -------------------------
5394
5395       procedure Build_Equality_Call (Eq : Entity_Id) is
5396          Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
5397          L_Exp   : Node_Id := Relocate_Node (Lhs);
5398          R_Exp   : Node_Id := Relocate_Node (Rhs);
5399
5400       begin
5401          if Base_Type (Op_Type) /= Base_Type (A_Typ)
5402            and then not Is_Class_Wide_Type (A_Typ)
5403          then
5404             L_Exp := OK_Convert_To (Op_Type, L_Exp);
5405             R_Exp := OK_Convert_To (Op_Type, R_Exp);
5406          end if;
5407
5408          --  If we have an Unchecked_Union, we need to add the inferred
5409          --  discriminant values as actuals in the function call. At this
5410          --  point, the expansion has determined that both operands have
5411          --  inferable discriminants.
5412
5413          if Is_Unchecked_Union (Op_Type) then
5414             declare
5415                Lhs_Type      : constant Node_Id := Etype (L_Exp);
5416                Rhs_Type      : constant Node_Id := Etype (R_Exp);
5417                Lhs_Discr_Val : Node_Id;
5418                Rhs_Discr_Val : Node_Id;
5419
5420             begin
5421                --  Per-object constrained selected components require special
5422                --  attention. If the enclosing scope of the component is an
5423                --  Unchecked_Union, we cannot reference its discriminants
5424                --  directly. This is why we use the two extra parameters of
5425                --  the equality function of the enclosing Unchecked_Union.
5426
5427                --  type UU_Type (Discr : Integer := 0) is
5428                --     . . .
5429                --  end record;
5430                --  pragma Unchecked_Union (UU_Type);
5431
5432                --  1. Unchecked_Union enclosing record:
5433
5434                --     type Enclosing_UU_Type (Discr : Integer := 0) is record
5435                --        . . .
5436                --        Comp : UU_Type (Discr);
5437                --        . . .
5438                --     end Enclosing_UU_Type;
5439                --     pragma Unchecked_Union (Enclosing_UU_Type);
5440
5441                --     Obj1 : Enclosing_UU_Type;
5442                --     Obj2 : Enclosing_UU_Type (1);
5443
5444                --     [. . .] Obj1 = Obj2 [. . .]
5445
5446                --     Generated code:
5447
5448                --     if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then
5449
5450                --  A and B are the formal parameters of the equality function
5451                --  of Enclosing_UU_Type. The function always has two extra
5452                --  formals to capture the inferred discriminant values.
5453
5454                --  2. Non-Unchecked_Union enclosing record:
5455
5456                --     type
5457                --       Enclosing_Non_UU_Type (Discr : Integer := 0)
5458                --     is record
5459                --        . . .
5460                --        Comp : UU_Type (Discr);
5461                --        . . .
5462                --     end Enclosing_Non_UU_Type;
5463
5464                --     Obj1 : Enclosing_Non_UU_Type;
5465                --     Obj2 : Enclosing_Non_UU_Type (1);
5466
5467                --     ...  Obj1 = Obj2 ...
5468
5469                --     Generated code:
5470
5471                --     if not (uu_typeEQ (obj1.comp, obj2.comp,
5472                --                        obj1.discr, obj2.discr)) then
5473
5474                --  In this case we can directly reference the discriminants of
5475                --  the enclosing record.
5476
5477                --  Lhs of equality
5478
5479                if Nkind (Lhs) = N_Selected_Component
5480                  and then Has_Per_Object_Constraint
5481                             (Entity (Selector_Name (Lhs)))
5482                then
5483                   --  Enclosing record is an Unchecked_Union, use formal A
5484
5485                   if Is_Unchecked_Union (Scope
5486                        (Entity (Selector_Name (Lhs))))
5487                   then
5488                      Lhs_Discr_Val :=
5489                        Make_Identifier (Loc,
5490                          Chars => Name_A);
5491
5492                   --  Enclosing record is of a non-Unchecked_Union type, it is
5493                   --  possible to reference the discriminant.
5494
5495                   else
5496                      Lhs_Discr_Val :=
5497                        Make_Selected_Component (Loc,
5498                          Prefix => Prefix (Lhs),
5499                          Selector_Name =>
5500                            New_Copy
5501                              (Get_Discriminant_Value
5502                                 (First_Discriminant (Lhs_Type),
5503                                  Lhs_Type,
5504                                  Stored_Constraint (Lhs_Type))));
5505                   end if;
5506
5507                --  Comment needed here ???
5508
5509                else
5510                   --  Infer the discriminant value
5511
5512                   Lhs_Discr_Val :=
5513                     New_Copy
5514                       (Get_Discriminant_Value
5515                          (First_Discriminant (Lhs_Type),
5516                           Lhs_Type,
5517                           Stored_Constraint (Lhs_Type)));
5518                end if;
5519
5520                --  Rhs of equality
5521
5522                if Nkind (Rhs) = N_Selected_Component
5523                  and then Has_Per_Object_Constraint
5524                             (Entity (Selector_Name (Rhs)))
5525                then
5526                   if Is_Unchecked_Union
5527                        (Scope (Entity (Selector_Name (Rhs))))
5528                   then
5529                      Rhs_Discr_Val :=
5530                        Make_Identifier (Loc,
5531                          Chars => Name_B);
5532
5533                   else
5534                      Rhs_Discr_Val :=
5535                        Make_Selected_Component (Loc,
5536                          Prefix => Prefix (Rhs),
5537                          Selector_Name =>
5538                            New_Copy (Get_Discriminant_Value (
5539                              First_Discriminant (Rhs_Type),
5540                              Rhs_Type,
5541                              Stored_Constraint (Rhs_Type))));
5542
5543                   end if;
5544                else
5545                   Rhs_Discr_Val :=
5546                     New_Copy (Get_Discriminant_Value (
5547                       First_Discriminant (Rhs_Type),
5548                       Rhs_Type,
5549                       Stored_Constraint (Rhs_Type)));
5550
5551                end if;
5552
5553                Rewrite (N,
5554                  Make_Function_Call (Loc,
5555                    Name => New_Reference_To (Eq, Loc),
5556                    Parameter_Associations => New_List (
5557                      L_Exp,
5558                      R_Exp,
5559                      Lhs_Discr_Val,
5560                      Rhs_Discr_Val)));
5561             end;
5562
5563          --  Normal case, not an unchecked union
5564
5565          else
5566             Rewrite (N,
5567               Make_Function_Call (Loc,
5568                 Name => New_Reference_To (Eq, Loc),
5569                 Parameter_Associations => New_List (L_Exp, R_Exp)));
5570          end if;
5571
5572          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5573       end Build_Equality_Call;
5574
5575       ------------------------------------
5576       -- Has_Unconstrained_UU_Component --
5577       ------------------------------------
5578
5579       function Has_Unconstrained_UU_Component
5580         (Typ : Node_Id) return Boolean
5581       is
5582          Tdef  : constant Node_Id :=
5583                    Type_Definition (Declaration_Node (Base_Type (Typ)));
5584          Clist : Node_Id;
5585          Vpart : Node_Id;
5586
5587          function Component_Is_Unconstrained_UU
5588            (Comp : Node_Id) return Boolean;
5589          --  Determines whether the subtype of the component is an
5590          --  unconstrained Unchecked_Union.
5591
5592          function Variant_Is_Unconstrained_UU
5593            (Variant : Node_Id) return Boolean;
5594          --  Determines whether a component of the variant has an unconstrained
5595          --  Unchecked_Union subtype.
5596
5597          -----------------------------------
5598          -- Component_Is_Unconstrained_UU --
5599          -----------------------------------
5600
5601          function Component_Is_Unconstrained_UU
5602            (Comp : Node_Id) return Boolean
5603          is
5604          begin
5605             if Nkind (Comp) /= N_Component_Declaration then
5606                return False;
5607             end if;
5608
5609             declare
5610                Sindic : constant Node_Id :=
5611                           Subtype_Indication (Component_Definition (Comp));
5612
5613             begin
5614                --  Unconstrained nominal type. In the case of a constraint
5615                --  present, the node kind would have been N_Subtype_Indication.
5616
5617                if Nkind (Sindic) = N_Identifier then
5618                   return Is_Unchecked_Union (Base_Type (Etype (Sindic)));
5619                end if;
5620
5621                return False;
5622             end;
5623          end Component_Is_Unconstrained_UU;
5624
5625          ---------------------------------
5626          -- Variant_Is_Unconstrained_UU --
5627          ---------------------------------
5628
5629          function Variant_Is_Unconstrained_UU
5630            (Variant : Node_Id) return Boolean
5631          is
5632             Clist : constant Node_Id := Component_List (Variant);
5633
5634          begin
5635             if Is_Empty_List (Component_Items (Clist)) then
5636                return False;
5637             end if;
5638
5639             --  We only need to test one component
5640
5641             declare
5642                Comp : Node_Id := First (Component_Items (Clist));
5643
5644             begin
5645                while Present (Comp) loop
5646                   if Component_Is_Unconstrained_UU (Comp) then
5647                      return True;
5648                   end if;
5649
5650                   Next (Comp);
5651                end loop;
5652             end;
5653
5654             --  None of the components withing the variant were of
5655             --  unconstrained Unchecked_Union type.
5656
5657             return False;
5658          end Variant_Is_Unconstrained_UU;
5659
5660       --  Start of processing for Has_Unconstrained_UU_Component
5661
5662       begin
5663          if Null_Present (Tdef) then
5664             return False;
5665          end if;
5666
5667          Clist := Component_List (Tdef);
5668          Vpart := Variant_Part (Clist);
5669
5670          --  Inspect available components
5671
5672          if Present (Component_Items (Clist)) then
5673             declare
5674                Comp : Node_Id := First (Component_Items (Clist));
5675
5676             begin
5677                while Present (Comp) loop
5678
5679                   --  One component is sufficient
5680
5681                   if Component_Is_Unconstrained_UU (Comp) then
5682                      return True;
5683                   end if;
5684
5685                   Next (Comp);
5686                end loop;
5687             end;
5688          end if;
5689
5690          --  Inspect available components withing variants
5691
5692          if Present (Vpart) then
5693             declare
5694                Variant : Node_Id := First (Variants (Vpart));
5695
5696             begin
5697                while Present (Variant) loop
5698
5699                   --  One component within a variant is sufficient
5700
5701                   if Variant_Is_Unconstrained_UU (Variant) then
5702                      return True;
5703                   end if;
5704
5705                   Next (Variant);
5706                end loop;
5707             end;
5708          end if;
5709
5710          --  Neither the available components, nor the components inside the
5711          --  variant parts were of an unconstrained Unchecked_Union subtype.
5712
5713          return False;
5714       end Has_Unconstrained_UU_Component;
5715
5716    --  Start of processing for Expand_N_Op_Eq
5717
5718    begin
5719       Binary_Op_Validity_Checks (N);
5720
5721       if Ekind (Typl) = E_Private_Type then
5722          Typl := Underlying_Type (Typl);
5723       elsif Ekind (Typl) = E_Private_Subtype then
5724          Typl := Underlying_Type (Base_Type (Typl));
5725       else
5726          null;
5727       end if;
5728
5729       --  It may happen in error situations that the underlying type is not
5730       --  set. The error will be detected later, here we just defend the
5731       --  expander code.
5732
5733       if No (Typl) then
5734          return;
5735       end if;
5736
5737       Typl := Base_Type (Typl);
5738
5739       --  Boolean types (requiring handling of non-standard case)
5740
5741       if Is_Boolean_Type (Typl) then
5742          Adjust_Condition (Left_Opnd (N));
5743          Adjust_Condition (Right_Opnd (N));
5744          Set_Etype (N, Standard_Boolean);
5745          Adjust_Result_Type (N, Typ);
5746
5747       --  Array types
5748
5749       elsif Is_Array_Type (Typl) then
5750
5751          --  If we are doing full validity checking, and it is possible for the
5752          --  array elements to be invalid then expand out array comparisons to
5753          --  make sure that we check the array elements.
5754
5755          if Validity_Check_Operands
5756            and then not Is_Known_Valid (Component_Type (Typl))
5757          then
5758             declare
5759                Save_Force_Validity_Checks : constant Boolean :=
5760                                               Force_Validity_Checks;
5761             begin
5762                Force_Validity_Checks := True;
5763                Rewrite (N,
5764                  Expand_Array_Equality
5765                   (N,
5766                    Relocate_Node (Lhs),
5767                    Relocate_Node (Rhs),
5768                    Bodies,
5769                    Typl));
5770                Insert_Actions (N, Bodies);
5771                Analyze_And_Resolve (N, Standard_Boolean);
5772                Force_Validity_Checks := Save_Force_Validity_Checks;
5773             end;
5774
5775          --  Packed case where both operands are known aligned
5776
5777          elsif Is_Bit_Packed_Array (Typl)
5778            and then not Is_Possibly_Unaligned_Object (Lhs)
5779            and then not Is_Possibly_Unaligned_Object (Rhs)
5780          then
5781             Expand_Packed_Eq (N);
5782
5783          --  Where the component type is elementary we can use a block bit
5784          --  comparison (if supported on the target) exception in the case
5785          --  of floating-point (negative zero issues require element by
5786          --  element comparison), and atomic types (where we must be sure
5787          --  to load elements independently) and possibly unaligned arrays.
5788
5789          elsif Is_Elementary_Type (Component_Type (Typl))
5790            and then not Is_Floating_Point_Type (Component_Type (Typl))
5791            and then not Is_Atomic (Component_Type (Typl))
5792            and then not Is_Possibly_Unaligned_Object (Lhs)
5793            and then not Is_Possibly_Unaligned_Object (Rhs)
5794            and then Support_Composite_Compare_On_Target
5795          then
5796             null;
5797
5798          --  For composite and floating-point cases, expand equality loop to
5799          --  make sure of using proper comparisons for tagged types, and
5800          --  correctly handling the floating-point case.
5801
5802          else
5803             Rewrite (N,
5804               Expand_Array_Equality
5805                 (N,
5806                  Relocate_Node (Lhs),
5807                  Relocate_Node (Rhs),
5808                  Bodies,
5809                  Typl));
5810             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5811             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5812          end if;
5813
5814       --  Record Types
5815
5816       elsif Is_Record_Type (Typl) then
5817
5818          --  For tagged types, use the primitive "="
5819
5820          if Is_Tagged_Type (Typl) then
5821
5822             --  No need to do anything else compiling under restriction
5823             --  No_Dispatching_Calls. During the semantic analysis we
5824             --  already notified such violation.
5825
5826             if Restriction_Active (No_Dispatching_Calls) then
5827                return;
5828             end if;
5829
5830             --  If this is derived from an untagged private type completed with
5831             --  a tagged type, it does not have a full view, so we use the
5832             --  primitive operations of the private type. This check should no
5833             --  longer be necessary when these types get their full views???
5834
5835             if Is_Private_Type (A_Typ)
5836               and then not Is_Tagged_Type (A_Typ)
5837               and then Is_Derived_Type (A_Typ)
5838               and then No (Full_View (A_Typ))
5839             then
5840                --  Search for equality operation, checking that the operands
5841                --  have the same type. Note that we must find a matching entry,
5842                --  or something is very wrong!
5843
5844                Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
5845
5846                while Present (Prim) loop
5847                   exit when Chars (Node (Prim)) = Name_Op_Eq
5848                     and then Etype (First_Formal (Node (Prim))) =
5849                              Etype (Next_Formal (First_Formal (Node (Prim))))
5850                     and then
5851                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5852
5853                   Next_Elmt (Prim);
5854                end loop;
5855
5856                pragma Assert (Present (Prim));
5857                Op_Name := Node (Prim);
5858
5859             --  Find the type's predefined equality or an overriding
5860             --  user- defined equality. The reason for not simply calling
5861             --  Find_Prim_Op here is that there may be a user-defined
5862             --  overloaded equality op that precedes the equality that we want,
5863             --  so we have to explicitly search (e.g., there could be an
5864             --  equality with two different parameter types).
5865
5866             else
5867                if Is_Class_Wide_Type (Typl) then
5868                   Typl := Root_Type (Typl);
5869                end if;
5870
5871                Prim := First_Elmt (Primitive_Operations (Typl));
5872                while Present (Prim) loop
5873                   exit when Chars (Node (Prim)) = Name_Op_Eq
5874                     and then Etype (First_Formal (Node (Prim))) =
5875                              Etype (Next_Formal (First_Formal (Node (Prim))))
5876                     and then
5877                       Base_Type (Etype (Node (Prim))) = Standard_Boolean;
5878
5879                   Next_Elmt (Prim);
5880                end loop;
5881
5882                pragma Assert (Present (Prim));
5883                Op_Name := Node (Prim);
5884             end if;
5885
5886             Build_Equality_Call (Op_Name);
5887
5888          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
5889          --  predefined equality operator for a type which has a subcomponent
5890          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
5891
5892          elsif Has_Unconstrained_UU_Component (Typl) then
5893             Insert_Action (N,
5894               Make_Raise_Program_Error (Loc,
5895                 Reason => PE_Unchecked_Union_Restriction));
5896
5897             --  Prevent Gigi from generating incorrect code by rewriting the
5898             --  equality as a standard False.
5899
5900             Rewrite (N,
5901               New_Occurrence_Of (Standard_False, Loc));
5902
5903          elsif Is_Unchecked_Union (Typl) then
5904
5905             --  If we can infer the discriminants of the operands, we make a
5906             --  call to the TSS equality function.
5907
5908             if Has_Inferable_Discriminants (Lhs)
5909                  and then
5910                Has_Inferable_Discriminants (Rhs)
5911             then
5912                Build_Equality_Call
5913                  (TSS (Root_Type (Typl), TSS_Composite_Equality));
5914
5915             else
5916                --  Ada 2005 (AI-216): Program_Error is raised when evaluating
5917                --  the predefined equality operator for an Unchecked_Union type
5918                --  if either of the operands lack inferable discriminants.
5919
5920                Insert_Action (N,
5921                  Make_Raise_Program_Error (Loc,
5922                    Reason => PE_Unchecked_Union_Restriction));
5923
5924                --  Prevent Gigi from generating incorrect code by rewriting
5925                --  the equality as a standard False.
5926
5927                Rewrite (N,
5928                  New_Occurrence_Of (Standard_False, Loc));
5929
5930             end if;
5931
5932          --  If a type support function is present (for complex cases), use it
5933
5934          elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
5935             Build_Equality_Call
5936               (TSS (Root_Type (Typl), TSS_Composite_Equality));
5937
5938          --  Otherwise expand the component by component equality. Note that
5939          --  we never use block-bit comparisons for records, because of the
5940          --  problems with gaps. The backend will often be able to recombine
5941          --  the separate comparisons that we generate here.
5942
5943          else
5944             Remove_Side_Effects (Lhs);
5945             Remove_Side_Effects (Rhs);
5946             Rewrite (N,
5947               Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
5948
5949             Insert_Actions      (N, Bodies,           Suppress => All_Checks);
5950             Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
5951          end if;
5952       end if;
5953
5954       --  Test if result is known at compile time
5955
5956       Rewrite_Comparison (N);
5957
5958       --  If we still have comparison for Vax_Float, process it
5959
5960       if Vax_Float (Typl) and then Nkind (N) in N_Op_Compare  then
5961          Expand_Vax_Comparison (N);
5962          return;
5963       end if;
5964    end Expand_N_Op_Eq;
5965
5966    -----------------------
5967    -- Expand_N_Op_Expon --
5968    -----------------------
5969
5970    procedure Expand_N_Op_Expon (N : Node_Id) is
5971       Loc    : constant Source_Ptr := Sloc (N);
5972       Typ    : constant Entity_Id  := Etype (N);
5973       Rtyp   : constant Entity_Id  := Root_Type (Typ);
5974       Base   : constant Node_Id    := Relocate_Node (Left_Opnd (N));
5975       Bastyp : constant Node_Id    := Etype (Base);
5976       Exp    : constant Node_Id    := Relocate_Node (Right_Opnd (N));
5977       Exptyp : constant Entity_Id  := Etype (Exp);
5978       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
5979       Expv   : Uint;
5980       Xnode  : Node_Id;
5981       Temp   : Node_Id;
5982       Rent   : RE_Id;
5983       Ent    : Entity_Id;
5984       Etyp   : Entity_Id;
5985
5986    begin
5987       Binary_Op_Validity_Checks (N);
5988
5989       --  If either operand is of a private type, then we have the use of an
5990       --  intrinsic operator, and we get rid of the privateness, by using root
5991       --  types of underlying types for the actual operation. Otherwise the
5992       --  private types will cause trouble if we expand multiplications or
5993       --  shifts etc. We also do this transformation if the result type is
5994       --  different from the base type.
5995
5996       if Is_Private_Type (Etype (Base))
5997            or else
5998          Is_Private_Type (Typ)
5999            or else
6000          Is_Private_Type (Exptyp)
6001            or else
6002          Rtyp /= Root_Type (Bastyp)
6003       then
6004          declare
6005             Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
6006             Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
6007
6008          begin
6009             Rewrite (N,
6010               Unchecked_Convert_To (Typ,
6011                 Make_Op_Expon (Loc,
6012                   Left_Opnd  => Unchecked_Convert_To (Bt, Base),
6013                   Right_Opnd => Unchecked_Convert_To (Et, Exp))));
6014             Analyze_And_Resolve (N, Typ);
6015             return;
6016          end;
6017       end if;
6018
6019       --  Test for case of known right argument
6020
6021       if Compile_Time_Known_Value (Exp) then
6022          Expv := Expr_Value (Exp);
6023
6024          --  We only fold small non-negative exponents. You might think we
6025          --  could fold small negative exponents for the real case, but we
6026          --  can't because we are required to raise Constraint_Error for
6027          --  the case of 0.0 ** (negative) even if Machine_Overflows = False.
6028          --  See ACVC test C4A012B.
6029
6030          if Expv >= 0 and then Expv <= 4 then
6031
6032             --  X ** 0 = 1 (or 1.0)
6033
6034             if Expv = 0 then
6035
6036                --  Call Remove_Side_Effects to ensure that any side effects
6037                --  in the ignored left operand (in particular function calls
6038                --  to user defined functions) are properly executed.
6039
6040                Remove_Side_Effects (Base);
6041
6042                if Ekind (Typ) in Integer_Kind then
6043                   Xnode := Make_Integer_Literal (Loc, Intval => 1);
6044                else
6045                   Xnode := Make_Real_Literal (Loc, Ureal_1);
6046                end if;
6047
6048             --  X ** 1 = X
6049
6050             elsif Expv = 1 then
6051                Xnode := Base;
6052
6053             --  X ** 2 = X * X
6054
6055             elsif Expv = 2 then
6056                Xnode :=
6057                  Make_Op_Multiply (Loc,
6058                    Left_Opnd  => Duplicate_Subexpr (Base),
6059                    Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
6060
6061             --  X ** 3 = X * X * X
6062
6063             elsif Expv = 3 then
6064                Xnode :=
6065                  Make_Op_Multiply (Loc,
6066                    Left_Opnd =>
6067                      Make_Op_Multiply (Loc,
6068                        Left_Opnd  => Duplicate_Subexpr (Base),
6069                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
6070                    Right_Opnd  => Duplicate_Subexpr_No_Checks (Base));
6071
6072             --  X ** 4  ->
6073             --    En : constant base'type := base * base;
6074             --    ...
6075             --    En * En
6076
6077             else -- Expv = 4
6078                Temp := Make_Temporary (Loc, 'E', Base);
6079
6080                Insert_Actions (N, New_List (
6081                  Make_Object_Declaration (Loc,
6082                    Defining_Identifier => Temp,
6083                    Constant_Present    => True,
6084                    Object_Definition   => New_Reference_To (Typ, Loc),
6085                    Expression =>
6086                      Make_Op_Multiply (Loc,
6087                        Left_Opnd  => Duplicate_Subexpr (Base),
6088                        Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
6089
6090                Xnode :=
6091                  Make_Op_Multiply (Loc,
6092                    Left_Opnd  => New_Reference_To (Temp, Loc),
6093                    Right_Opnd => New_Reference_To (Temp, Loc));
6094             end if;
6095
6096             Rewrite (N, Xnode);
6097             Analyze_And_Resolve (N, Typ);
6098             return;
6099          end if;
6100       end if;
6101
6102       --  Case of (2 ** expression) appearing as an argument of an integer
6103       --  multiplication, or as the right argument of a division of a non-
6104       --  negative integer. In such cases we leave the node untouched, setting
6105       --  the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
6106       --  of the higher level node converts it into a shift.
6107
6108       --  Another case is 2 ** N in any other context. We simply convert
6109       --  this to 1 * 2 ** N, and then the above transformation applies.
6110
6111       --  Note: this transformation is not applicable for a modular type with
6112       --  a non-binary modulus in the multiplication case, since we get a wrong
6113       --  result if the shift causes an overflow before the modular reduction.
6114
6115       if Nkind (Base) = N_Integer_Literal
6116         and then Intval (Base) = 2
6117         and then Is_Integer_Type (Root_Type (Exptyp))
6118         and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
6119         and then Is_Unsigned_Type (Exptyp)
6120         and then not Ovflo
6121       then
6122          --  First the multiply and divide cases
6123
6124          if Nkind_In (Parent (N), N_Op_Divide, N_Op_Multiply) then
6125             declare
6126                P : constant Node_Id := Parent (N);
6127                L : constant Node_Id := Left_Opnd (P);
6128                R : constant Node_Id := Right_Opnd (P);
6129
6130             begin
6131                if (Nkind (P) = N_Op_Multiply
6132                    and then not Non_Binary_Modulus (Typ)
6133                    and then
6134                      ((Is_Integer_Type (Etype (L)) and then R = N)
6135                          or else
6136                       (Is_Integer_Type (Etype (R)) and then L = N))
6137                    and then not Do_Overflow_Check (P))
6138                  or else
6139                   (Nkind (P) = N_Op_Divide
6140                      and then Is_Integer_Type (Etype (L))
6141                      and then Is_Unsigned_Type (Etype (L))
6142                      and then R = N
6143                      and then not Do_Overflow_Check (P))
6144                then
6145                   Set_Is_Power_Of_2_For_Shift (N);
6146                   return;
6147                end if;
6148             end;
6149
6150          --  Now the other cases
6151
6152          elsif not Non_Binary_Modulus (Typ) then
6153             Rewrite (N,
6154               Make_Op_Multiply (Loc,
6155                 Left_Opnd  => Make_Integer_Literal (Loc, 1),
6156                 Right_Opnd => Relocate_Node (N)));
6157             Analyze_And_Resolve (N, Typ);
6158             return;
6159          end if;
6160       end if;
6161
6162       --  Fall through if exponentiation must be done using a runtime routine
6163
6164       --  First deal with modular case
6165
6166       if Is_Modular_Integer_Type (Rtyp) then
6167
6168          --  Non-binary case, we call the special exponentiation routine for
6169          --  the non-binary case, converting the argument to Long_Long_Integer
6170          --  and passing the modulus value. Then the result is converted back
6171          --  to the base type.
6172
6173          if Non_Binary_Modulus (Rtyp) then
6174             Rewrite (N,
6175               Convert_To (Typ,
6176                 Make_Function_Call (Loc,
6177                   Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
6178                   Parameter_Associations => New_List (
6179                     Convert_To (Standard_Integer, Base),
6180                     Make_Integer_Literal (Loc, Modulus (Rtyp)),
6181                     Exp))));
6182
6183          --  Binary case, in this case, we call one of two routines, either the
6184          --  unsigned integer case, or the unsigned long long integer case,
6185          --  with a final "and" operation to do the required mod.
6186
6187          else
6188             if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
6189                Ent := RTE (RE_Exp_Unsigned);
6190             else
6191                Ent := RTE (RE_Exp_Long_Long_Unsigned);
6192             end if;
6193
6194             Rewrite (N,
6195               Convert_To (Typ,
6196                 Make_Op_And (Loc,
6197                   Left_Opnd =>
6198                     Make_Function_Call (Loc,
6199                       Name => New_Reference_To (Ent, Loc),
6200                       Parameter_Associations => New_List (
6201                         Convert_To (Etype (First_Formal (Ent)), Base),
6202                         Exp)),
6203                    Right_Opnd =>
6204                      Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
6205
6206          end if;
6207
6208          --  Common exit point for modular type case
6209
6210          Analyze_And_Resolve (N, Typ);
6211          return;
6212
6213       --  Signed integer cases, done using either Integer or Long_Long_Integer.
6214       --  It is not worth having routines for Short_[Short_]Integer, since for
6215       --  most machines it would not help, and it would generate more code that
6216       --  might need certification when a certified run time is required.
6217
6218       --  In the integer cases, we have two routines, one for when overflow
6219       --  checks are required, and one when they are not required, since there
6220       --  is a real gain in omitting checks on many machines.
6221
6222       elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
6223         or else (Rtyp = Base_Type (Standard_Long_Integer)
6224                    and then
6225                      Esize (Standard_Long_Integer) > Esize (Standard_Integer))
6226         or else (Rtyp = Universal_Integer)
6227       then
6228          Etyp := Standard_Long_Long_Integer;
6229
6230          if Ovflo then
6231             Rent := RE_Exp_Long_Long_Integer;
6232          else
6233             Rent := RE_Exn_Long_Long_Integer;
6234          end if;
6235
6236       elsif Is_Signed_Integer_Type (Rtyp) then
6237          Etyp := Standard_Integer;
6238
6239          if Ovflo then
6240             Rent := RE_Exp_Integer;
6241          else
6242             Rent := RE_Exn_Integer;
6243          end if;
6244
6245       --  Floating-point cases, always done using Long_Long_Float. We do not
6246       --  need separate routines for the overflow case here, since in the case
6247       --  of floating-point, we generate infinities anyway as a rule (either
6248       --  that or we automatically trap overflow), and if there is an infinity
6249       --  generated and a range check is required, the check will fail anyway.
6250
6251       else
6252          pragma Assert (Is_Floating_Point_Type (Rtyp));
6253          Etyp := Standard_Long_Long_Float;
6254          Rent := RE_Exn_Long_Long_Float;
6255       end if;
6256
6257       --  Common processing for integer cases and floating-point cases.
6258       --  If we are in the right type, we can call runtime routine directly
6259
6260       if Typ = Etyp
6261         and then Rtyp /= Universal_Integer
6262         and then Rtyp /= Universal_Real
6263       then
6264          Rewrite (N,
6265            Make_Function_Call (Loc,
6266              Name => New_Reference_To (RTE (Rent), Loc),
6267              Parameter_Associations => New_List (Base, Exp)));
6268
6269       --  Otherwise we have to introduce conversions (conversions are also
6270       --  required in the universal cases, since the runtime routine is
6271       --  typed using one of the standard types).
6272
6273       else
6274          Rewrite (N,
6275            Convert_To (Typ,
6276              Make_Function_Call (Loc,
6277                Name => New_Reference_To (RTE (Rent), Loc),
6278                Parameter_Associations => New_List (
6279                  Convert_To (Etyp, Base),
6280                  Exp))));
6281       end if;
6282
6283       Analyze_And_Resolve (N, Typ);
6284       return;
6285
6286    exception
6287       when RE_Not_Available =>
6288          return;
6289    end Expand_N_Op_Expon;
6290
6291    --------------------
6292    -- Expand_N_Op_Ge --
6293    --------------------
6294
6295    procedure Expand_N_Op_Ge (N : Node_Id) is
6296       Typ  : constant Entity_Id := Etype (N);
6297       Op1  : constant Node_Id   := Left_Opnd (N);
6298       Op2  : constant Node_Id   := Right_Opnd (N);
6299       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6300
6301    begin
6302       Binary_Op_Validity_Checks (N);
6303
6304       if Is_Array_Type (Typ1) then
6305          Expand_Array_Comparison (N);
6306          return;
6307       end if;
6308
6309       if Is_Boolean_Type (Typ1) then
6310          Adjust_Condition (Op1);
6311          Adjust_Condition (Op2);
6312          Set_Etype (N, Standard_Boolean);
6313          Adjust_Result_Type (N, Typ);
6314       end if;
6315
6316       Rewrite_Comparison (N);
6317
6318       --  If we still have comparison, and Vax_Float type, process it
6319
6320       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6321          Expand_Vax_Comparison (N);
6322          return;
6323       end if;
6324    end Expand_N_Op_Ge;
6325
6326    --------------------
6327    -- Expand_N_Op_Gt --
6328    --------------------
6329
6330    procedure Expand_N_Op_Gt (N : Node_Id) is
6331       Typ  : constant Entity_Id := Etype (N);
6332       Op1  : constant Node_Id   := Left_Opnd (N);
6333       Op2  : constant Node_Id   := Right_Opnd (N);
6334       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6335
6336    begin
6337       Binary_Op_Validity_Checks (N);
6338
6339       if Is_Array_Type (Typ1) then
6340          Expand_Array_Comparison (N);
6341          return;
6342       end if;
6343
6344       if Is_Boolean_Type (Typ1) then
6345          Adjust_Condition (Op1);
6346          Adjust_Condition (Op2);
6347          Set_Etype (N, Standard_Boolean);
6348          Adjust_Result_Type (N, Typ);
6349       end if;
6350
6351       Rewrite_Comparison (N);
6352
6353       --  If we still have comparison, and Vax_Float type, process it
6354
6355       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6356          Expand_Vax_Comparison (N);
6357          return;
6358       end if;
6359    end Expand_N_Op_Gt;
6360
6361    --------------------
6362    -- Expand_N_Op_Le --
6363    --------------------
6364
6365    procedure Expand_N_Op_Le (N : Node_Id) is
6366       Typ  : constant Entity_Id := Etype (N);
6367       Op1  : constant Node_Id   := Left_Opnd (N);
6368       Op2  : constant Node_Id   := Right_Opnd (N);
6369       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6370
6371    begin
6372       Binary_Op_Validity_Checks (N);
6373
6374       if Is_Array_Type (Typ1) then
6375          Expand_Array_Comparison (N);
6376          return;
6377       end if;
6378
6379       if Is_Boolean_Type (Typ1) then
6380          Adjust_Condition (Op1);
6381          Adjust_Condition (Op2);
6382          Set_Etype (N, Standard_Boolean);
6383          Adjust_Result_Type (N, Typ);
6384       end if;
6385
6386       Rewrite_Comparison (N);
6387
6388       --  If we still have comparison, and Vax_Float type, process it
6389
6390       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6391          Expand_Vax_Comparison (N);
6392          return;
6393       end if;
6394    end Expand_N_Op_Le;
6395
6396    --------------------
6397    -- Expand_N_Op_Lt --
6398    --------------------
6399
6400    procedure Expand_N_Op_Lt (N : Node_Id) is
6401       Typ  : constant Entity_Id := Etype (N);
6402       Op1  : constant Node_Id   := Left_Opnd (N);
6403       Op2  : constant Node_Id   := Right_Opnd (N);
6404       Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
6405
6406    begin
6407       Binary_Op_Validity_Checks (N);
6408
6409       if Is_Array_Type (Typ1) then
6410          Expand_Array_Comparison (N);
6411          return;
6412       end if;
6413
6414       if Is_Boolean_Type (Typ1) then
6415          Adjust_Condition (Op1);
6416          Adjust_Condition (Op2);
6417          Set_Etype (N, Standard_Boolean);
6418          Adjust_Result_Type (N, Typ);
6419       end if;
6420
6421       Rewrite_Comparison (N);
6422
6423       --  If we still have comparison, and Vax_Float type, process it
6424
6425       if Vax_Float (Typ1) and then Nkind (N) in N_Op_Compare then
6426          Expand_Vax_Comparison (N);
6427          return;
6428       end if;
6429    end Expand_N_Op_Lt;
6430
6431    -----------------------
6432    -- Expand_N_Op_Minus --
6433    -----------------------
6434
6435    procedure Expand_N_Op_Minus (N : Node_Id) is
6436       Loc : constant Source_Ptr := Sloc (N);
6437       Typ : constant Entity_Id  := Etype (N);
6438
6439    begin
6440       Unary_Op_Validity_Checks (N);
6441
6442       if not Backend_Overflow_Checks_On_Target
6443          and then Is_Signed_Integer_Type (Etype (N))
6444          and then Do_Overflow_Check (N)
6445       then
6446          --  Software overflow checking expands -expr into (0 - expr)
6447
6448          Rewrite (N,
6449            Make_Op_Subtract (Loc,
6450              Left_Opnd  => Make_Integer_Literal (Loc, 0),
6451              Right_Opnd => Right_Opnd (N)));
6452
6453          Analyze_And_Resolve (N, Typ);
6454
6455       --  Vax floating-point types case
6456
6457       elsif Vax_Float (Etype (N)) then
6458          Expand_Vax_Arith (N);
6459       end if;
6460    end Expand_N_Op_Minus;
6461
6462    ---------------------
6463    -- Expand_N_Op_Mod --
6464    ---------------------
6465
6466    procedure Expand_N_Op_Mod (N : Node_Id) is
6467       Loc   : constant Source_Ptr := Sloc (N);
6468       Typ   : constant Entity_Id  := Etype (N);
6469       Left  : constant Node_Id    := Left_Opnd (N);
6470       Right : constant Node_Id    := Right_Opnd (N);
6471       DOC   : constant Boolean    := Do_Overflow_Check (N);
6472       DDC   : constant Boolean    := Do_Division_Check (N);
6473
6474       LLB : Uint;
6475       Llo : Uint;
6476       Lhi : Uint;
6477       LOK : Boolean;
6478       Rlo : Uint;
6479       Rhi : Uint;
6480       ROK : Boolean;
6481
6482       pragma Warnings (Off, Lhi);
6483
6484    begin
6485       Binary_Op_Validity_Checks (N);
6486
6487       Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
6488       Determine_Range (Left,  LOK, Llo, Lhi, Assume_Valid => True);
6489
6490       --  Convert mod to rem if operands are known non-negative. We do this
6491       --  since it is quite likely that this will improve the quality of code,
6492       --  (the operation now corresponds to the hardware remainder), and it
6493       --  does not seem likely that it could be harmful.
6494
6495       if LOK and then Llo >= 0
6496            and then
6497          ROK and then Rlo >= 0
6498       then
6499          Rewrite (N,
6500            Make_Op_Rem (Sloc (N),
6501              Left_Opnd  => Left_Opnd (N),
6502              Right_Opnd => Right_Opnd (N)));
6503
6504          --  Instead of reanalyzing the node we do the analysis manually. This
6505          --  avoids anomalies when the replacement is done in an instance and
6506          --  is epsilon more efficient.
6507
6508          Set_Entity            (N, Standard_Entity (S_Op_Rem));
6509          Set_Etype             (N, Typ);
6510          Set_Do_Overflow_Check (N, DOC);
6511          Set_Do_Division_Check (N, DDC);
6512          Expand_N_Op_Rem (N);
6513          Set_Analyzed (N);
6514
6515       --  Otherwise, normal mod processing
6516
6517       else
6518          if Is_Integer_Type (Etype (N)) then
6519             Apply_Divide_Check (N);
6520          end if;
6521
6522          --  Apply optimization x mod 1 = 0. We don't really need that with
6523          --  gcc, but it is useful with other back ends (e.g. AAMP), and is
6524          --  certainly harmless.
6525
6526          if Is_Integer_Type (Etype (N))
6527            and then Compile_Time_Known_Value (Right)
6528            and then Expr_Value (Right) = Uint_1
6529          then
6530             --  Call Remove_Side_Effects to ensure that any side effects in
6531             --  the ignored left operand (in particular function calls to
6532             --  user defined functions) are properly executed.
6533
6534             Remove_Side_Effects (Left);
6535
6536             Rewrite (N, Make_Integer_Literal (Loc, 0));
6537             Analyze_And_Resolve (N, Typ);
6538             return;
6539          end if;
6540
6541          --  Deal with annoying case of largest negative number remainder
6542          --  minus one. Gigi does not handle this case correctly, because
6543          --  it generates a divide instruction which may trap in this case.
6544
6545          --  In fact the check is quite easy, if the right operand is -1, then
6546          --  the mod value is always 0, and we can just ignore the left operand
6547          --  completely in this case.
6548
6549          --  The operand type may be private (e.g. in the expansion of an
6550          --  intrinsic operation) so we must use the underlying type to get the
6551          --  bounds, and convert the literals explicitly.
6552
6553          LLB :=
6554            Expr_Value
6555              (Type_Low_Bound (Base_Type (Underlying_Type (Etype (Left)))));
6556
6557          if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
6558            and then
6559             ((not LOK) or else (Llo = LLB))
6560          then
6561             Rewrite (N,
6562               Make_Conditional_Expression (Loc,
6563                 Expressions => New_List (
6564                   Make_Op_Eq (Loc,
6565                     Left_Opnd => Duplicate_Subexpr (Right),
6566                     Right_Opnd =>
6567                       Unchecked_Convert_To (Typ,
6568                         Make_Integer_Literal (Loc, -1))),
6569                   Unchecked_Convert_To (Typ,
6570                     Make_Integer_Literal (Loc, Uint_0)),
6571                   Relocate_Node (N))));
6572
6573             Set_Analyzed (Next (Next (First (Expressions (N)))));
6574             Analyze_And_Resolve (N, Typ);
6575          end if;
6576       end if;
6577    end Expand_N_Op_Mod;
6578
6579    --------------------------
6580    -- Expand_N_Op_Multiply --
6581    --------------------------
6582
6583    procedure Expand_N_Op_Multiply (N : Node_Id) is
6584       Loc : constant Source_Ptr := Sloc (N);
6585       Lop : constant Node_Id    := Left_Opnd (N);
6586       Rop : constant Node_Id    := Right_Opnd (N);
6587
6588       Lp2 : constant Boolean :=
6589               Nkind (Lop) = N_Op_Expon
6590                 and then Is_Power_Of_2_For_Shift (Lop);
6591
6592       Rp2 : constant Boolean :=
6593               Nkind (Rop) = N_Op_Expon
6594                 and then Is_Power_Of_2_For_Shift (Rop);
6595
6596       Ltyp : constant Entity_Id  := Etype (Lop);
6597       Rtyp : constant Entity_Id  := Etype (Rop);
6598       Typ  : Entity_Id           := Etype (N);
6599
6600    begin
6601       Binary_Op_Validity_Checks (N);
6602
6603       --  Special optimizations for integer types
6604
6605       if Is_Integer_Type (Typ) then
6606
6607          --  N * 0 = 0 for integer types
6608
6609          if Compile_Time_Known_Value (Rop)
6610            and then Expr_Value (Rop) = Uint_0
6611          then
6612             --  Call Remove_Side_Effects to ensure that any side effects in
6613             --  the ignored left operand (in particular function calls to
6614             --  user defined functions) are properly executed.
6615
6616             Remove_Side_Effects (Lop);
6617
6618             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
6619             Analyze_And_Resolve (N, Typ);
6620             return;
6621          end if;
6622
6623          --  Similar handling for 0 * N = 0
6624
6625          if Compile_Time_Known_Value (Lop)
6626            and then Expr_Value (Lop) = Uint_0
6627          then
6628             Remove_Side_Effects (Rop);
6629             Rewrite (N, Make_Integer_Literal (Loc, Uint_0));
6630             Analyze_And_Resolve (N, Typ);
6631             return;
6632          end if;
6633
6634          --  N * 1 = 1 * N = N for integer types
6635
6636          --  This optimisation is not done if we are going to
6637          --  rewrite the product 1 * 2 ** N to a shift.
6638
6639          if Compile_Time_Known_Value (Rop)
6640            and then Expr_Value (Rop) = Uint_1
6641            and then not Lp2
6642          then
6643             Rewrite (N, Lop);
6644             return;
6645
6646          elsif Compile_Time_Known_Value (Lop)
6647            and then Expr_Value (Lop) = Uint_1
6648            and then not Rp2
6649          then
6650             Rewrite (N, Rop);
6651             return;
6652          end if;
6653       end if;
6654
6655       --  Convert x * 2 ** y to Shift_Left (x, y). Note that the fact that
6656       --  Is_Power_Of_2_For_Shift is set means that we know that our left
6657       --  operand is an integer, as required for this to work.
6658
6659       if Rp2 then
6660          if Lp2 then
6661
6662             --  Convert 2 ** A * 2 ** B into  2 ** (A + B)
6663
6664             Rewrite (N,
6665               Make_Op_Expon (Loc,
6666                 Left_Opnd => Make_Integer_Literal (Loc, 2),
6667                 Right_Opnd =>
6668                   Make_Op_Add (Loc,
6669                     Left_Opnd  => Right_Opnd (Lop),
6670                     Right_Opnd => Right_Opnd (Rop))));
6671             Analyze_And_Resolve (N, Typ);
6672             return;
6673
6674          else
6675             Rewrite (N,
6676               Make_Op_Shift_Left (Loc,
6677                 Left_Opnd  => Lop,
6678                 Right_Opnd =>
6679                   Convert_To (Standard_Natural, Right_Opnd (Rop))));
6680             Analyze_And_Resolve (N, Typ);
6681             return;
6682          end if;
6683
6684       --  Same processing for the operands the other way round
6685
6686       elsif Lp2 then
6687          Rewrite (N,
6688            Make_Op_Shift_Left (Loc,
6689              Left_Opnd  => Rop,
6690              Right_Opnd =>
6691                Convert_To (Standard_Natural, Right_Opnd (Lop))));
6692          Analyze_And_Resolve (N, Typ);
6693          return;
6694       end if;
6695
6696       --  Do required fixup of universal fixed operation
6697
6698       if Typ = Universal_Fixed then
6699          Fixup_Universal_Fixed_Operation (N);
6700          Typ := Etype (N);
6701       end if;
6702
6703       --  Multiplications with fixed-point results
6704
6705       if Is_Fixed_Point_Type (Typ) then
6706
6707          --  No special processing if Treat_Fixed_As_Integer is set, since from
6708          --  a semantic point of view such operations are simply integer
6709          --  operations and will be treated that way.
6710
6711          if not Treat_Fixed_As_Integer (N) then
6712
6713             --  Case of fixed * integer => fixed
6714
6715             if Is_Integer_Type (Rtyp) then
6716                Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
6717
6718             --  Case of integer * fixed => fixed
6719
6720             elsif Is_Integer_Type (Ltyp) then
6721                Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
6722
6723             --  Case of fixed * fixed => fixed
6724
6725             else
6726                Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
6727             end if;
6728          end if;
6729
6730       --  Other cases of multiplication of fixed-point operands. Again we
6731       --  exclude the cases where Treat_Fixed_As_Integer flag is set.
6732
6733       elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
6734         and then not Treat_Fixed_As_Integer (N)
6735       then
6736          if Is_Integer_Type (Typ) then
6737             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
6738          else
6739             pragma Assert (Is_Floating_Point_Type (Typ));
6740             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
6741          end if;
6742
6743       --  Mixed-mode operations can appear in a non-static universal context,
6744       --  in which case the integer argument must be converted explicitly.
6745
6746       elsif Typ = Universal_Real
6747         and then Is_Integer_Type (Rtyp)
6748       then
6749          Rewrite (Rop, Convert_To (Universal_Real, Relocate_Node (Rop)));
6750
6751          Analyze_And_Resolve (Rop, Universal_Real);
6752
6753       elsif Typ = Universal_Real
6754         and then Is_Integer_Type (Ltyp)
6755       then
6756          Rewrite (Lop, Convert_To (Universal_Real, Relocate_Node (Lop)));
6757
6758          Analyze_And_Resolve (Lop, Universal_Real);
6759
6760       --  Non-fixed point cases, check software overflow checking required
6761
6762       elsif Is_Signed_Integer_Type (Etype (N)) then
6763          Apply_Arithmetic_Overflow_Check (N);
6764
6765       --  Deal with VAX float case
6766
6767       elsif Vax_Float (Typ) then
6768          Expand_Vax_Arith (N);
6769          return;
6770       end if;
6771    end Expand_N_Op_Multiply;
6772
6773    --------------------
6774    -- Expand_N_Op_Ne --
6775    --------------------
6776
6777    procedure Expand_N_Op_Ne (N : Node_Id) is
6778       Typ : constant Entity_Id := Etype (Left_Opnd (N));
6779
6780    begin
6781       --  Case of elementary type with standard operator
6782
6783       if Is_Elementary_Type (Typ)
6784         and then Sloc (Entity (N)) = Standard_Location
6785       then
6786          Binary_Op_Validity_Checks (N);
6787
6788          --  Boolean types (requiring handling of non-standard case)
6789
6790          if Is_Boolean_Type (Typ) then
6791             Adjust_Condition (Left_Opnd (N));
6792             Adjust_Condition (Right_Opnd (N));
6793             Set_Etype (N, Standard_Boolean);
6794             Adjust_Result_Type (N, Typ);
6795          end if;
6796
6797          Rewrite_Comparison (N);
6798
6799          --  If we still have comparison for Vax_Float, process it
6800
6801          if Vax_Float (Typ) and then Nkind (N) in N_Op_Compare  then
6802             Expand_Vax_Comparison (N);
6803             return;
6804          end if;
6805
6806       --  For all cases other than elementary types, we rewrite node as the
6807       --  negation of an equality operation, and reanalyze. The equality to be
6808       --  used is defined in the same scope and has the same signature. This
6809       --  signature must be set explicitly since in an instance it may not have
6810       --  the same visibility as in the generic unit. This avoids duplicating
6811       --  or factoring the complex code for record/array equality tests etc.
6812
6813       else
6814          declare
6815             Loc : constant Source_Ptr := Sloc (N);
6816             Neg : Node_Id;
6817             Ne  : constant Entity_Id := Entity (N);
6818
6819          begin
6820             Binary_Op_Validity_Checks (N);
6821
6822             Neg :=
6823               Make_Op_Not (Loc,
6824                 Right_Opnd =>
6825                   Make_Op_Eq (Loc,
6826                     Left_Opnd =>  Left_Opnd (N),
6827                     Right_Opnd => Right_Opnd (N)));
6828             Set_Paren_Count (Right_Opnd (Neg), 1);
6829
6830             if Scope (Ne) /= Standard_Standard then
6831                Set_Entity (Right_Opnd (Neg), Corresponding_Equality (Ne));
6832             end if;
6833
6834             --  For navigation purposes, the inequality is treated as an
6835             --  implicit reference to the corresponding equality. Preserve the
6836             --  Comes_From_ source flag so that the proper Xref entry is
6837             --  generated.
6838
6839             Preserve_Comes_From_Source (Neg, N);
6840             Preserve_Comes_From_Source (Right_Opnd (Neg), N);
6841             Rewrite (N, Neg);
6842             Analyze_And_Resolve (N, Standard_Boolean);
6843          end;
6844       end if;
6845    end Expand_N_Op_Ne;
6846
6847    ---------------------
6848    -- Expand_N_Op_Not --
6849    ---------------------
6850
6851    --  If the argument is other than a Boolean array type, there is no special
6852    --  expansion required, except for VMS operations on signed integers.
6853
6854    --  For the packed case, we call the special routine in Exp_Pakd, except
6855    --  that if the component size is greater than one, we use the standard
6856    --  routine generating a gruesome loop (it is so peculiar to have packed
6857    --  arrays with non-standard Boolean representations anyway, so it does not
6858    --  matter that we do not handle this case efficiently).
6859
6860    --  For the unpacked case (and for the special packed case where we have non
6861    --  standard Booleans, as discussed above), we generate and insert into the
6862    --  tree the following function definition:
6863
6864    --     function Nnnn (A : arr) is
6865    --       B : arr;
6866    --     begin
6867    --       for J in a'range loop
6868    --          B (J) := not A (J);
6869    --       end loop;
6870    --       return B;
6871    --     end Nnnn;
6872
6873    --  Here arr is the actual subtype of the parameter (and hence always
6874    --  constrained). Then we replace the not with a call to this function.
6875
6876    procedure Expand_N_Op_Not (N : Node_Id) is
6877       Loc  : constant Source_Ptr := Sloc (N);
6878       Typ  : constant Entity_Id  := Etype (N);
6879       Opnd : Node_Id;
6880       Arr  : Entity_Id;
6881       A    : Entity_Id;
6882       B    : Entity_Id;
6883       J    : Entity_Id;
6884       A_J  : Node_Id;
6885       B_J  : Node_Id;
6886
6887       Func_Name      : Entity_Id;
6888       Loop_Statement : Node_Id;
6889
6890    begin
6891       Unary_Op_Validity_Checks (N);
6892
6893       --  For boolean operand, deal with non-standard booleans
6894
6895       if Is_Boolean_Type (Typ) then
6896          Adjust_Condition (Right_Opnd (N));
6897          Set_Etype (N, Standard_Boolean);
6898          Adjust_Result_Type (N, Typ);
6899          return;
6900       end if;
6901
6902       --  For the VMS "not" on signed integer types, use conversion to and
6903       --  from a predefined modular type.
6904
6905       if Is_VMS_Operator (Entity (N)) then
6906          declare
6907             Rtyp : Entity_Id;
6908             Utyp : Entity_Id;
6909
6910          begin
6911             --  If this is a derived type, retrieve original VMS type so that
6912             --  the proper sized type is used for intermediate values.
6913
6914             if Is_Derived_Type (Typ) then
6915                Rtyp := First_Subtype (Etype (Typ));
6916             else
6917                Rtyp := Typ;
6918             end if;
6919
6920             --  The proper unsigned type must have a size compatible with the
6921             --  operand, to prevent misalignment.
6922
6923             if RM_Size (Rtyp) <= 8 then
6924                Utyp := RTE (RE_Unsigned_8);
6925
6926             elsif RM_Size (Rtyp) <= 16 then
6927                Utyp := RTE (RE_Unsigned_16);
6928
6929             elsif RM_Size (Rtyp) = RM_Size (Standard_Unsigned) then
6930                Utyp := RTE (RE_Unsigned_32);
6931
6932             else
6933                Utyp := RTE (RE_Long_Long_Unsigned);
6934             end if;
6935
6936             Rewrite (N,
6937               Unchecked_Convert_To (Typ,
6938                 Make_Op_Not (Loc,
6939                   Unchecked_Convert_To (Utyp, Right_Opnd (N)))));
6940             Analyze_And_Resolve (N, Typ);
6941             return;
6942          end;
6943       end if;
6944
6945       --  Only array types need any other processing
6946
6947       if not Is_Array_Type (Typ) then
6948          return;
6949       end if;
6950
6951       --  Case of array operand. If bit packed with a component size of 1,
6952       --  handle it in Exp_Pakd if the operand is known to be aligned.
6953
6954       if Is_Bit_Packed_Array (Typ)
6955         and then Component_Size (Typ) = 1
6956         and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
6957       then
6958          Expand_Packed_Not (N);
6959          return;
6960       end if;
6961
6962       --  Case of array operand which is not bit-packed. If the context is
6963       --  a safe assignment, call in-place operation, If context is a larger
6964       --  boolean expression in the context of a safe assignment, expansion is
6965       --  done by enclosing operation.
6966
6967       Opnd := Relocate_Node (Right_Opnd (N));
6968       Convert_To_Actual_Subtype (Opnd);
6969       Arr := Etype (Opnd);
6970       Ensure_Defined (Arr, N);
6971       Silly_Boolean_Array_Not_Test (N, Arr);
6972
6973       if Nkind (Parent (N)) = N_Assignment_Statement then
6974          if Safe_In_Place_Array_Op (Name (Parent (N)), N, Empty) then
6975             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6976             return;
6977
6978          --  Special case the negation of a binary operation
6979
6980          elsif Nkind_In (Opnd, N_Op_And, N_Op_Or, N_Op_Xor)
6981            and then Safe_In_Place_Array_Op
6982                       (Name (Parent (N)), Left_Opnd (Opnd), Right_Opnd (Opnd))
6983          then
6984             Build_Boolean_Array_Proc_Call (Parent (N), Opnd, Empty);
6985             return;
6986          end if;
6987
6988       elsif Nkind (Parent (N)) in N_Binary_Op
6989         and then Nkind (Parent (Parent (N))) = N_Assignment_Statement
6990       then
6991          declare
6992             Op1 : constant Node_Id := Left_Opnd  (Parent (N));
6993             Op2 : constant Node_Id := Right_Opnd (Parent (N));
6994             Lhs : constant Node_Id := Name (Parent (Parent (N)));
6995
6996          begin
6997             if Safe_In_Place_Array_Op (Lhs, Op1, Op2) then
6998
6999                --  (not A) op (not B) can be reduced to a single call
7000
7001                if N = Op1 and then Nkind (Op2) = N_Op_Not then
7002                   return;
7003
7004                --  A xor (not B) can also be special-cased
7005
7006                elsif N = Op2 and then Nkind (Parent (N)) = N_Op_Xor then
7007                   return;
7008                end if;
7009             end if;
7010          end;
7011       end if;
7012
7013       A := Make_Defining_Identifier (Loc, Name_uA);
7014       B := Make_Defining_Identifier (Loc, Name_uB);
7015       J := Make_Defining_Identifier (Loc, Name_uJ);
7016
7017       A_J :=
7018         Make_Indexed_Component (Loc,
7019           Prefix      => New_Reference_To (A, Loc),
7020           Expressions => New_List (New_Reference_To (J, Loc)));
7021
7022       B_J :=
7023         Make_Indexed_Component (Loc,
7024           Prefix      => New_Reference_To (B, Loc),
7025           Expressions => New_List (New_Reference_To (J, Loc)));
7026
7027       Loop_Statement :=
7028         Make_Implicit_Loop_Statement (N,
7029           Identifier => Empty,
7030
7031           Iteration_Scheme =>
7032             Make_Iteration_Scheme (Loc,
7033               Loop_Parameter_Specification =>
7034                 Make_Loop_Parameter_Specification (Loc,
7035                   Defining_Identifier         => J,
7036                   Discrete_Subtype_Definition =>
7037                     Make_Attribute_Reference (Loc,
7038                       Prefix         => Make_Identifier (Loc, Chars (A)),
7039                       Attribute_Name => Name_Range))),
7040
7041           Statements => New_List (
7042             Make_Assignment_Statement (Loc,
7043               Name       => B_J,
7044               Expression => Make_Op_Not (Loc, A_J))));
7045
7046       Func_Name := Make_Temporary (Loc, 'N');
7047       Set_Is_Inlined (Func_Name);
7048
7049       Insert_Action (N,
7050         Make_Subprogram_Body (Loc,
7051           Specification =>
7052             Make_Function_Specification (Loc,
7053               Defining_Unit_Name => Func_Name,
7054               Parameter_Specifications => New_List (
7055                 Make_Parameter_Specification (Loc,
7056                   Defining_Identifier => A,
7057                   Parameter_Type      => New_Reference_To (Typ, Loc))),
7058               Result_Definition => New_Reference_To (Typ, Loc)),
7059
7060           Declarations => New_List (
7061             Make_Object_Declaration (Loc,
7062               Defining_Identifier => B,
7063               Object_Definition   => New_Reference_To (Arr, Loc))),
7064
7065           Handled_Statement_Sequence =>
7066             Make_Handled_Sequence_Of_Statements (Loc,
7067               Statements => New_List (
7068                 Loop_Statement,
7069                 Make_Simple_Return_Statement (Loc,
7070                   Expression => Make_Identifier (Loc, Chars (B)))))));
7071
7072       Rewrite (N,
7073         Make_Function_Call (Loc,
7074           Name                   => New_Reference_To (Func_Name, Loc),
7075           Parameter_Associations => New_List (Opnd)));
7076
7077       Analyze_And_Resolve (N, Typ);
7078    end Expand_N_Op_Not;
7079
7080    --------------------
7081    -- Expand_N_Op_Or --
7082    --------------------
7083
7084    procedure Expand_N_Op_Or (N : Node_Id) is
7085       Typ : constant Entity_Id := Etype (N);
7086
7087    begin
7088       Binary_Op_Validity_Checks (N);
7089
7090       if Is_Array_Type (Etype (N)) then
7091          Expand_Boolean_Operator (N);
7092
7093       elsif Is_Boolean_Type (Etype (N)) then
7094
7095          --  Replace OR by OR ELSE if Short_Circuit_And_Or active and the type
7096          --  is standard Boolean (do not mess with AND that uses a non-standard
7097          --  Boolean type, because something strange is going on).
7098
7099          if Short_Circuit_And_Or and then Typ = Standard_Boolean then
7100             Rewrite (N,
7101               Make_Or_Else (Sloc (N),
7102                 Left_Opnd  => Relocate_Node (Left_Opnd (N)),
7103                 Right_Opnd => Relocate_Node (Right_Opnd (N))));
7104             Analyze_And_Resolve (N, Typ);
7105
7106          --  Otherwise, adjust conditions
7107
7108          else
7109             Adjust_Condition (Left_Opnd (N));
7110             Adjust_Condition (Right_Opnd (N));
7111             Set_Etype (N, Standard_Boolean);
7112             Adjust_Result_Type (N, Typ);
7113          end if;
7114       end if;
7115    end Expand_N_Op_Or;
7116
7117    ----------------------
7118    -- Expand_N_Op_Plus --
7119    ----------------------
7120
7121    procedure Expand_N_Op_Plus (N : Node_Id) is
7122    begin
7123       Unary_Op_Validity_Checks (N);
7124    end Expand_N_Op_Plus;
7125
7126    ---------------------
7127    -- Expand_N_Op_Rem --
7128    ---------------------
7129
7130    procedure Expand_N_Op_Rem (N : Node_Id) is
7131       Loc : constant Source_Ptr := Sloc (N);
7132       Typ : constant Entity_Id  := Etype (N);
7133
7134       Left  : constant Node_Id := Left_Opnd (N);
7135       Right : constant Node_Id := Right_Opnd (N);
7136
7137       Lo : Uint;
7138       Hi : Uint;
7139       OK : Boolean;
7140
7141       Lneg : Boolean;
7142       Rneg : Boolean;
7143       --  Set if corresponding operand can be negative
7144
7145       pragma Unreferenced (Hi);
7146
7147    begin
7148       Binary_Op_Validity_Checks (N);
7149
7150       if Is_Integer_Type (Etype (N)) then
7151          Apply_Divide_Check (N);
7152       end if;
7153
7154       --  Apply optimization x rem 1 = 0. We don't really need that with gcc,
7155       --  but it is useful with other back ends (e.g. AAMP), and is certainly
7156       --  harmless.
7157
7158       if Is_Integer_Type (Etype (N))
7159         and then Compile_Time_Known_Value (Right)
7160         and then Expr_Value (Right) = Uint_1
7161       then
7162          --  Call Remove_Side_Effects to ensure that any side effects in the
7163          --  ignored left operand (in particular function calls to user defined
7164          --  functions) are properly executed.
7165
7166          Remove_Side_Effects (Left);
7167
7168          Rewrite (N, Make_Integer_Literal (Loc, 0));
7169          Analyze_And_Resolve (N, Typ);
7170          return;
7171       end if;
7172
7173       --  Deal with annoying case of largest negative number remainder minus
7174       --  one. Gigi does not handle this case correctly, because it generates
7175       --  a divide instruction which may trap in this case.
7176
7177       --  In fact the check is quite easy, if the right operand is -1, then
7178       --  the remainder is always 0, and we can just ignore the left operand
7179       --  completely in this case.
7180
7181       Determine_Range (Right, OK, Lo, Hi, Assume_Valid => True);
7182       Lneg := (not OK) or else Lo < 0;
7183
7184       Determine_Range (Left,  OK, Lo, Hi, Assume_Valid => True);
7185       Rneg := (not OK) or else Lo < 0;
7186
7187       --  We won't mess with trying to find out if the left operand can really
7188       --  be the largest negative number (that's a pain in the case of private
7189       --  types and this is really marginal). We will just assume that we need
7190       --  the test if the left operand can be negative at all.
7191
7192       if Lneg and Rneg then
7193          Rewrite (N,
7194            Make_Conditional_Expression (Loc,
7195              Expressions => New_List (
7196                Make_Op_Eq (Loc,
7197                  Left_Opnd  => Duplicate_Subexpr (Right),
7198                  Right_Opnd =>
7199                    Unchecked_Convert_To (Typ, Make_Integer_Literal (Loc, -1))),
7200
7201                Unchecked_Convert_To (Typ,
7202                  Make_Integer_Literal (Loc, Uint_0)),
7203
7204                Relocate_Node (N))));
7205
7206          Set_Analyzed (Next (Next (First (Expressions (N)))));
7207          Analyze_And_Resolve (N, Typ);
7208       end if;
7209    end Expand_N_Op_Rem;
7210
7211    -----------------------------
7212    -- Expand_N_Op_Rotate_Left --
7213    -----------------------------
7214
7215    procedure Expand_N_Op_Rotate_Left (N : Node_Id) is
7216    begin
7217       Binary_Op_Validity_Checks (N);
7218    end Expand_N_Op_Rotate_Left;
7219
7220    ------------------------------
7221    -- Expand_N_Op_Rotate_Right --
7222    ------------------------------
7223
7224    procedure Expand_N_Op_Rotate_Right (N : Node_Id) is
7225    begin
7226       Binary_Op_Validity_Checks (N);
7227    end Expand_N_Op_Rotate_Right;
7228
7229    ----------------------------
7230    -- Expand_N_Op_Shift_Left --
7231    ----------------------------
7232
7233    procedure Expand_N_Op_Shift_Left (N : Node_Id) is
7234    begin
7235       Binary_Op_Validity_Checks (N);
7236    end Expand_N_Op_Shift_Left;
7237
7238    -----------------------------
7239    -- Expand_N_Op_Shift_Right --
7240    -----------------------------
7241
7242    procedure Expand_N_Op_Shift_Right (N : Node_Id) is
7243    begin
7244       Binary_Op_Validity_Checks (N);
7245    end Expand_N_Op_Shift_Right;
7246
7247    ----------------------------------------
7248    -- Expand_N_Op_Shift_Right_Arithmetic --
7249    ----------------------------------------
7250
7251    procedure Expand_N_Op_Shift_Right_Arithmetic (N : Node_Id) is
7252    begin
7253       Binary_Op_Validity_Checks (N);
7254    end Expand_N_Op_Shift_Right_Arithmetic;
7255
7256    --------------------------
7257    -- Expand_N_Op_Subtract --
7258    --------------------------
7259
7260    procedure Expand_N_Op_Subtract (N : Node_Id) is
7261       Typ : constant Entity_Id := Etype (N);
7262
7263    begin
7264       Binary_Op_Validity_Checks (N);
7265
7266       --  N - 0 = N for integer types
7267
7268       if Is_Integer_Type (Typ)
7269         and then Compile_Time_Known_Value (Right_Opnd (N))
7270         and then Expr_Value (Right_Opnd (N)) = 0
7271       then
7272          Rewrite (N, Left_Opnd (N));
7273          return;
7274       end if;
7275
7276       --  Arithmetic overflow checks for signed integer/fixed point types
7277
7278       if Is_Signed_Integer_Type (Typ)
7279            or else
7280          Is_Fixed_Point_Type (Typ)
7281       then
7282          Apply_Arithmetic_Overflow_Check (N);
7283
7284       --  VAX floating-point types case
7285
7286       elsif Vax_Float (Typ) then
7287          Expand_Vax_Arith (N);
7288       end if;
7289    end Expand_N_Op_Subtract;
7290
7291    ---------------------
7292    -- Expand_N_Op_Xor --
7293    ---------------------
7294
7295    procedure Expand_N_Op_Xor (N : Node_Id) is
7296       Typ : constant Entity_Id := Etype (N);
7297
7298    begin
7299       Binary_Op_Validity_Checks (N);
7300
7301       if Is_Array_Type (Etype (N)) then
7302          Expand_Boolean_Operator (N);
7303
7304       elsif Is_Boolean_Type (Etype (N)) then
7305          Adjust_Condition (Left_Opnd (N));
7306          Adjust_Condition (Right_Opnd (N));
7307          Set_Etype (N, Standard_Boolean);
7308          Adjust_Result_Type (N, Typ);
7309       end if;
7310    end Expand_N_Op_Xor;
7311
7312    ----------------------
7313    -- Expand_N_Or_Else --
7314    ----------------------
7315
7316    procedure Expand_N_Or_Else (N : Node_Id)
7317      renames Expand_Short_Circuit_Operator;
7318
7319    -----------------------------------
7320    -- Expand_N_Qualified_Expression --
7321    -----------------------------------
7322
7323    procedure Expand_N_Qualified_Expression (N : Node_Id) is
7324       Operand     : constant Node_Id   := Expression (N);
7325       Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
7326
7327    begin
7328       --  Do validity check if validity checking operands
7329
7330       if Validity_Checks_On
7331         and then Validity_Check_Operands
7332       then
7333          Ensure_Valid (Operand);
7334       end if;
7335
7336       --  Apply possible constraint check
7337
7338       Apply_Constraint_Check (Operand, Target_Type, No_Sliding => True);
7339
7340       if Do_Range_Check (Operand) then
7341          Set_Do_Range_Check (Operand, False);
7342          Generate_Range_Check (Operand, Target_Type, CE_Range_Check_Failed);
7343       end if;
7344    end Expand_N_Qualified_Expression;
7345
7346    ---------------------------------
7347    -- Expand_N_Selected_Component --
7348    ---------------------------------
7349
7350    --  If the selector is a discriminant of a concurrent object, rewrite the
7351    --  prefix to denote the corresponding record type.
7352
7353    procedure Expand_N_Selected_Component (N : Node_Id) is
7354       Loc   : constant Source_Ptr := Sloc (N);
7355       Par   : constant Node_Id    := Parent (N);
7356       P     : constant Node_Id    := Prefix (N);
7357       Ptyp  : Entity_Id           := Underlying_Type (Etype (P));
7358       Disc  : Entity_Id;
7359       New_N : Node_Id;
7360       Dcon  : Elmt_Id;
7361
7362       function In_Left_Hand_Side (Comp : Node_Id) return Boolean;
7363       --  Gigi needs a temporary for prefixes that depend on a discriminant,
7364       --  unless the context of an assignment can provide size information.
7365       --  Don't we have a general routine that does this???
7366
7367       -----------------------
7368       -- In_Left_Hand_Side --
7369       -----------------------
7370
7371       function In_Left_Hand_Side (Comp : Node_Id) return Boolean is
7372       begin
7373          return (Nkind (Parent (Comp)) = N_Assignment_Statement
7374                    and then Comp = Name (Parent (Comp)))
7375            or else (Present (Parent (Comp))
7376                       and then Nkind (Parent (Comp)) in N_Subexpr
7377                       and then In_Left_Hand_Side (Parent (Comp)));
7378       end In_Left_Hand_Side;
7379
7380    --  Start of processing for Expand_N_Selected_Component
7381
7382    begin
7383       --  Insert explicit dereference if required
7384
7385       if Is_Access_Type (Ptyp) then
7386          Insert_Explicit_Dereference (P);
7387          Analyze_And_Resolve (P, Designated_Type (Ptyp));
7388
7389          if Ekind (Etype (P)) = E_Private_Subtype
7390            and then Is_For_Access_Subtype (Etype (P))
7391          then
7392             Set_Etype (P, Base_Type (Etype (P)));
7393          end if;
7394
7395          Ptyp := Etype (P);
7396       end if;
7397
7398       --  Deal with discriminant check required
7399
7400       if Do_Discriminant_Check (N) then
7401
7402          --  Present the discriminant checking function to the backend, so that
7403          --  it can inline the call to the function.
7404
7405          Add_Inlined_Body
7406            (Discriminant_Checking_Func
7407              (Original_Record_Component (Entity (Selector_Name (N)))));
7408
7409          --  Now reset the flag and generate the call
7410
7411          Set_Do_Discriminant_Check (N, False);
7412          Generate_Discriminant_Check (N);
7413       end if;
7414
7415       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7416       --  function, then additional actuals must be passed.
7417
7418       if Ada_Version >= Ada_05
7419         and then Is_Build_In_Place_Function_Call (P)
7420       then
7421          Make_Build_In_Place_Call_In_Anonymous_Context (P);
7422       end if;
7423
7424       --  Gigi cannot handle unchecked conversions that are the prefix of a
7425       --  selected component with discriminants. This must be checked during
7426       --  expansion, because during analysis the type of the selector is not
7427       --  known at the point the prefix is analyzed. If the conversion is the
7428       --  target of an assignment, then we cannot force the evaluation.
7429
7430       if Nkind (Prefix (N)) = N_Unchecked_Type_Conversion
7431         and then Has_Discriminants (Etype (N))
7432         and then not In_Left_Hand_Side (N)
7433       then
7434          Force_Evaluation (Prefix (N));
7435       end if;
7436
7437       --  Remaining processing applies only if selector is a discriminant
7438
7439       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
7440
7441          --  If the selector is a discriminant of a constrained record type,
7442          --  we may be able to rewrite the expression with the actual value
7443          --  of the discriminant, a useful optimization in some cases.
7444
7445          if Is_Record_Type (Ptyp)
7446            and then Has_Discriminants (Ptyp)
7447            and then Is_Constrained (Ptyp)
7448          then
7449             --  Do this optimization for discrete types only, and not for
7450             --  access types (access discriminants get us into trouble!)
7451
7452             if not Is_Discrete_Type (Etype (N)) then
7453                null;
7454
7455             --  Don't do this on the left hand of an assignment statement.
7456             --  Normally one would think that references like this would not
7457             --  occur, but they do in generated code, and mean that we really
7458             --  do want to assign the discriminant!
7459
7460             elsif Nkind (Par) = N_Assignment_Statement
7461               and then Name (Par) = N
7462             then
7463                null;
7464
7465             --  Don't do this optimization for the prefix of an attribute or
7466             --  the name of an object renaming declaration since these are
7467             --  contexts where we do not want the value anyway.
7468
7469             elsif (Nkind (Par) = N_Attribute_Reference
7470                      and then Prefix (Par) = N)
7471               or else Is_Renamed_Object (N)
7472             then
7473                null;
7474
7475             --  If this is a discriminant of a component of a mutable record,
7476             --  or a renaming of such, no optimization is possible, and value
7477             --  must be retrieved anew. Note that in the previous case we may
7478             --  be dealing with a renaming declaration, while here we may have
7479             --  a use of a renaming.
7480
7481             elsif Nkind (P) = N_Selected_Component
7482               and then Is_Record_Type (Etype (Prefix (P)))
7483               and then not Is_Constrained (Etype (Prefix (P)))
7484             then
7485                null;
7486
7487             --  Don't do this optimization if we are within the code for a
7488             --  discriminant check, since the whole point of such a check may
7489             --  be to verify the condition on which the code below depends!
7490
7491             elsif Is_In_Discriminant_Check (N) then
7492                null;
7493
7494             --  Green light to see if we can do the optimization. There is
7495             --  still one condition that inhibits the optimization below but
7496             --  now is the time to check the particular discriminant.
7497
7498             else
7499                --  Loop through discriminants to find the matching discriminant
7500                --  constraint to see if we can copy it.
7501
7502                Disc := First_Discriminant (Ptyp);
7503                Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
7504                Discr_Loop : while Present (Dcon) loop
7505
7506                   --  Check if this is the matching discriminant
7507
7508                   if Disc = Entity (Selector_Name (N)) then
7509
7510                      --  Here we have the matching discriminant. Check for
7511                      --  the case of a discriminant of a component that is
7512                      --  constrained by an outer discriminant, which cannot
7513                      --  be optimized away.
7514
7515                      if
7516                        Denotes_Discriminant
7517                         (Node (Dcon), Check_Concurrent => True)
7518                      then
7519                         exit Discr_Loop;
7520
7521                      --  In the context of a case statement, the expression may
7522                      --  have the base type of the discriminant, and we need to
7523                      --  preserve the constraint to avoid spurious errors on
7524                      --  missing cases.
7525
7526                      elsif Nkind (Parent (N)) = N_Case_Statement
7527                        and then Etype (Node (Dcon)) /= Etype (Disc)
7528                      then
7529                         Rewrite (N,
7530                           Make_Qualified_Expression (Loc,
7531                             Subtype_Mark =>
7532                               New_Occurrence_Of (Etype (Disc), Loc),
7533                             Expression   =>
7534                               New_Copy_Tree (Node (Dcon))));
7535                         Analyze_And_Resolve (N, Etype (Disc));
7536
7537                         --  In case that comes out as a static expression,
7538                         --  reset it (a selected component is never static).
7539
7540                         Set_Is_Static_Expression (N, False);
7541                         return;
7542
7543                      --  Otherwise we can just copy the constraint, but the
7544                      --  result is certainly not static! In some cases the
7545                      --  discriminant constraint has been analyzed in the
7546                      --  context of the original subtype indication, but for
7547                      --  itypes the constraint might not have been analyzed
7548                      --  yet, and this must be done now.
7549
7550                      else
7551                         Rewrite (N, New_Copy_Tree (Node (Dcon)));
7552                         Analyze_And_Resolve (N);
7553                         Set_Is_Static_Expression (N, False);
7554                         return;
7555                      end if;
7556                   end if;
7557
7558                   Next_Elmt (Dcon);
7559                   Next_Discriminant (Disc);
7560                end loop Discr_Loop;
7561
7562                --  Note: the above loop should always find a matching
7563                --  discriminant, but if it does not, we just missed an
7564                --  optimization due to some glitch (perhaps a previous error),
7565                --  so ignore.
7566
7567             end if;
7568          end if;
7569
7570          --  The only remaining processing is in the case of a discriminant of
7571          --  a concurrent object, where we rewrite the prefix to denote the
7572          --  corresponding record type. If the type is derived and has renamed
7573          --  discriminants, use corresponding discriminant, which is the one
7574          --  that appears in the corresponding record.
7575
7576          if not Is_Concurrent_Type (Ptyp) then
7577             return;
7578          end if;
7579
7580          Disc := Entity (Selector_Name (N));
7581
7582          if Is_Derived_Type (Ptyp)
7583            and then Present (Corresponding_Discriminant (Disc))
7584          then
7585             Disc := Corresponding_Discriminant (Disc);
7586          end if;
7587
7588          New_N :=
7589            Make_Selected_Component (Loc,
7590              Prefix =>
7591                Unchecked_Convert_To (Corresponding_Record_Type (Ptyp),
7592                  New_Copy_Tree (P)),
7593              Selector_Name => Make_Identifier (Loc, Chars (Disc)));
7594
7595          Rewrite (N, New_N);
7596          Analyze (N);
7597       end if;
7598    end Expand_N_Selected_Component;
7599
7600    --------------------
7601    -- Expand_N_Slice --
7602    --------------------
7603
7604    procedure Expand_N_Slice (N : Node_Id) is
7605       Loc  : constant Source_Ptr := Sloc (N);
7606       Typ  : constant Entity_Id  := Etype (N);
7607       Pfx  : constant Node_Id    := Prefix (N);
7608       Ptp  : Entity_Id           := Etype (Pfx);
7609
7610       function Is_Procedure_Actual (N : Node_Id) return Boolean;
7611       --  Check whether the argument is an actual for a procedure call, in
7612       --  which case the expansion of a bit-packed slice is deferred until the
7613       --  call itself is expanded. The reason this is required is that we might
7614       --  have an IN OUT or OUT parameter, and the copy out is essential, and
7615       --  that copy out would be missed if we created a temporary here in
7616       --  Expand_N_Slice. Note that we don't bother to test specifically for an
7617       --  IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
7618       --  is harmless to defer expansion in the IN case, since the call
7619       --  processing will still generate the appropriate copy in operation,
7620       --  which will take care of the slice.
7621
7622       procedure Make_Temporary_For_Slice;
7623       --  Create a named variable for the value of the slice, in cases where
7624       --  the back-end cannot handle it properly, e.g. when packed types or
7625       --  unaligned slices are involved.
7626
7627       -------------------------
7628       -- Is_Procedure_Actual --
7629       -------------------------
7630
7631       function Is_Procedure_Actual (N : Node_Id) return Boolean is
7632          Par : Node_Id := Parent (N);
7633
7634       begin
7635          loop
7636             --  If our parent is a procedure call we can return
7637
7638             if Nkind (Par) = N_Procedure_Call_Statement then
7639                return True;
7640
7641             --  If our parent is a type conversion, keep climbing the tree,
7642             --  since a type conversion can be a procedure actual. Also keep
7643             --  climbing if parameter association or a qualified expression,
7644             --  since these are additional cases that do can appear on
7645             --  procedure actuals.
7646
7647             elsif Nkind_In (Par, N_Type_Conversion,
7648                                  N_Parameter_Association,
7649                                  N_Qualified_Expression)
7650             then
7651                Par := Parent (Par);
7652
7653                --  Any other case is not what we are looking for
7654
7655             else
7656                return False;
7657             end if;
7658          end loop;
7659       end Is_Procedure_Actual;
7660
7661       ------------------------------
7662       -- Make_Temporary_For_Slice --
7663       ------------------------------
7664
7665       procedure Make_Temporary_For_Slice is
7666          Decl : Node_Id;
7667          Ent  : constant Entity_Id := Make_Temporary (Loc, 'T', N);
7668
7669       begin
7670          Decl :=
7671            Make_Object_Declaration (Loc,
7672              Defining_Identifier => Ent,
7673              Object_Definition   => New_Occurrence_Of (Typ, Loc));
7674
7675          Set_No_Initialization (Decl);
7676
7677          Insert_Actions (N, New_List (
7678            Decl,
7679            Make_Assignment_Statement (Loc,
7680              Name => New_Occurrence_Of (Ent, Loc),
7681              Expression => Relocate_Node (N))));
7682
7683          Rewrite (N, New_Occurrence_Of (Ent, Loc));
7684          Analyze_And_Resolve (N, Typ);
7685       end Make_Temporary_For_Slice;
7686
7687    --  Start of processing for Expand_N_Slice
7688
7689    begin
7690       --  Special handling for access types
7691
7692       if Is_Access_Type (Ptp) then
7693
7694          Ptp := Designated_Type (Ptp);
7695
7696          Rewrite (Pfx,
7697            Make_Explicit_Dereference (Sloc (N),
7698             Prefix => Relocate_Node (Pfx)));
7699
7700          Analyze_And_Resolve (Pfx, Ptp);
7701       end if;
7702
7703       --  Ada 2005 (AI-318-02): If the prefix is a call to a build-in-place
7704       --  function, then additional actuals must be passed.
7705
7706       if Ada_Version >= Ada_05
7707         and then Is_Build_In_Place_Function_Call (Pfx)
7708       then
7709          Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
7710       end if;
7711
7712       --  The remaining case to be handled is packed slices. We can leave
7713       --  packed slices as they are in the following situations:
7714
7715       --    1. Right or left side of an assignment (we can handle this
7716       --       situation correctly in the assignment statement expansion).
7717
7718       --    2. Prefix of indexed component (the slide is optimized away in this
7719       --       case, see the start of Expand_N_Slice.)
7720
7721       --    3. Object renaming declaration, since we want the name of the
7722       --       slice, not the value.
7723
7724       --    4. Argument to procedure call, since copy-in/copy-out handling may
7725       --       be required, and this is handled in the expansion of call
7726       --       itself.
7727
7728       --    5. Prefix of an address attribute (this is an error which is caught
7729       --       elsewhere, and the expansion would interfere with generating the
7730       --       error message).
7731
7732       if not Is_Packed (Typ) then
7733
7734          --  Apply transformation for actuals of a function call, where
7735          --  Expand_Actuals is not used.
7736
7737          if Nkind (Parent (N)) = N_Function_Call
7738            and then Is_Possibly_Unaligned_Slice (N)
7739          then
7740             Make_Temporary_For_Slice;
7741          end if;
7742
7743       elsif Nkind (Parent (N)) = N_Assignment_Statement
7744         or else (Nkind (Parent (Parent (N))) = N_Assignment_Statement
7745                    and then Parent (N) = Name (Parent (Parent (N))))
7746       then
7747          return;
7748
7749       elsif Nkind (Parent (N)) = N_Indexed_Component
7750         or else Is_Renamed_Object (N)
7751         or else Is_Procedure_Actual (N)
7752       then
7753          return;
7754
7755       elsif Nkind (Parent (N)) = N_Attribute_Reference
7756         and then Attribute_Name (Parent (N)) = Name_Address
7757       then
7758          return;
7759
7760       else
7761          Make_Temporary_For_Slice;
7762       end if;
7763    end Expand_N_Slice;
7764
7765    ------------------------------
7766    -- Expand_N_Type_Conversion --
7767    ------------------------------
7768
7769    procedure Expand_N_Type_Conversion (N : Node_Id) is
7770       Loc          : constant Source_Ptr := Sloc (N);
7771       Operand      : constant Node_Id    := Expression (N);
7772       Target_Type  : constant Entity_Id  := Etype (N);
7773       Operand_Type : Entity_Id           := Etype (Operand);
7774
7775       procedure Handle_Changed_Representation;
7776       --  This is called in the case of record and array type conversions to
7777       --  see if there is a change of representation to be handled. Change of
7778       --  representation is actually handled at the assignment statement level,
7779       --  and what this procedure does is rewrite node N conversion as an
7780       --  assignment to temporary. If there is no change of representation,
7781       --  then the conversion node is unchanged.
7782
7783       procedure Raise_Accessibility_Error;
7784       --  Called when we know that an accessibility check will fail. Rewrites
7785       --  node N to an appropriate raise statement and outputs warning msgs.
7786       --  The Etype of the raise node is set to Target_Type.
7787
7788       procedure Real_Range_Check;
7789       --  Handles generation of range check for real target value
7790
7791       -----------------------------------
7792       -- Handle_Changed_Representation --
7793       -----------------------------------
7794
7795       procedure Handle_Changed_Representation is
7796          Temp : Entity_Id;
7797          Decl : Node_Id;
7798          Odef : Node_Id;
7799          Disc : Node_Id;
7800          N_Ix : Node_Id;
7801          Cons : List_Id;
7802
7803       begin
7804          --  Nothing else to do if no change of representation
7805
7806          if Same_Representation (Operand_Type, Target_Type) then
7807             return;
7808
7809          --  The real change of representation work is done by the assignment
7810          --  statement processing. So if this type conversion is appearing as
7811          --  the expression of an assignment statement, nothing needs to be
7812          --  done to the conversion.
7813
7814          elsif Nkind (Parent (N)) = N_Assignment_Statement then
7815             return;
7816
7817          --  Otherwise we need to generate a temporary variable, and do the
7818          --  change of representation assignment into that temporary variable.
7819          --  The conversion is then replaced by a reference to this variable.
7820
7821          else
7822             Cons := No_List;
7823
7824             --  If type is unconstrained we have to add a constraint, copied
7825             --  from the actual value of the left hand side.
7826
7827             if not Is_Constrained (Target_Type) then
7828                if Has_Discriminants (Operand_Type) then
7829                   Disc := First_Discriminant (Operand_Type);
7830
7831                   if Disc /= First_Stored_Discriminant (Operand_Type) then
7832                      Disc := First_Stored_Discriminant (Operand_Type);
7833                   end if;
7834
7835                   Cons := New_List;
7836                   while Present (Disc) loop
7837                      Append_To (Cons,
7838                        Make_Selected_Component (Loc,
7839                          Prefix => Duplicate_Subexpr_Move_Checks (Operand),
7840                          Selector_Name =>
7841                            Make_Identifier (Loc, Chars (Disc))));
7842                      Next_Discriminant (Disc);
7843                   end loop;
7844
7845                elsif Is_Array_Type (Operand_Type) then
7846                   N_Ix := First_Index (Target_Type);
7847                   Cons := New_List;
7848
7849                   for J in 1 .. Number_Dimensions (Operand_Type) loop
7850
7851                      --  We convert the bounds explicitly. We use an unchecked
7852                      --  conversion because bounds checks are done elsewhere.
7853
7854                      Append_To (Cons,
7855                        Make_Range (Loc,
7856                          Low_Bound =>
7857                            Unchecked_Convert_To (Etype (N_Ix),
7858                              Make_Attribute_Reference (Loc,
7859                                Prefix =>
7860                                  Duplicate_Subexpr_No_Checks
7861                                    (Operand, Name_Req => True),
7862                                Attribute_Name => Name_First,
7863                                Expressions    => New_List (
7864                                  Make_Integer_Literal (Loc, J)))),
7865
7866                          High_Bound =>
7867                            Unchecked_Convert_To (Etype (N_Ix),
7868                              Make_Attribute_Reference (Loc,
7869                                Prefix =>
7870                                  Duplicate_Subexpr_No_Checks
7871                                    (Operand, Name_Req => True),
7872                                Attribute_Name => Name_Last,
7873                                Expressions    => New_List (
7874                                  Make_Integer_Literal (Loc, J))))));
7875
7876                      Next_Index (N_Ix);
7877                   end loop;
7878                end if;
7879             end if;
7880
7881             Odef := New_Occurrence_Of (Target_Type, Loc);
7882
7883             if Present (Cons) then
7884                Odef :=
7885                  Make_Subtype_Indication (Loc,
7886                    Subtype_Mark => Odef,
7887                    Constraint =>
7888                      Make_Index_Or_Discriminant_Constraint (Loc,
7889                        Constraints => Cons));
7890             end if;
7891
7892             Temp := Make_Temporary (Loc, 'C');
7893             Decl :=
7894               Make_Object_Declaration (Loc,
7895                 Defining_Identifier => Temp,
7896                 Object_Definition   => Odef);
7897
7898             Set_No_Initialization (Decl, True);
7899
7900             --  Insert required actions. It is essential to suppress checks
7901             --  since we have suppressed default initialization, which means
7902             --  that the variable we create may have no discriminants.
7903
7904             Insert_Actions (N,
7905               New_List (
7906                 Decl,
7907                 Make_Assignment_Statement (Loc,
7908                   Name => New_Occurrence_Of (Temp, Loc),
7909                   Expression => Relocate_Node (N))),
7910                 Suppress => All_Checks);
7911
7912             Rewrite (N, New_Occurrence_Of (Temp, Loc));
7913             return;
7914          end if;
7915       end Handle_Changed_Representation;
7916
7917       -------------------------------
7918       -- Raise_Accessibility_Error --
7919       -------------------------------
7920
7921       procedure Raise_Accessibility_Error is
7922       begin
7923          Rewrite (N,
7924            Make_Raise_Program_Error (Sloc (N),
7925              Reason => PE_Accessibility_Check_Failed));
7926          Set_Etype (N, Target_Type);
7927
7928          Error_Msg_N ("?accessibility check failure", N);
7929          Error_Msg_NE
7930            ("\?& will be raised at run time", N, Standard_Program_Error);
7931       end Raise_Accessibility_Error;
7932
7933       ----------------------
7934       -- Real_Range_Check --
7935       ----------------------
7936
7937       --  Case of conversions to floating-point or fixed-point. If range checks
7938       --  are enabled and the target type has a range constraint, we convert:
7939
7940       --     typ (x)
7941
7942       --       to
7943
7944       --     Tnn : typ'Base := typ'Base (x);
7945       --     [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
7946       --     Tnn
7947
7948       --  This is necessary when there is a conversion of integer to float or
7949       --  to fixed-point to ensure that the correct checks are made. It is not
7950       --  necessary for float to float where it is enough to simply set the
7951       --  Do_Range_Check flag.
7952
7953       procedure Real_Range_Check is
7954          Btyp : constant Entity_Id := Base_Type (Target_Type);
7955          Lo   : constant Node_Id   := Type_Low_Bound  (Target_Type);
7956          Hi   : constant Node_Id   := Type_High_Bound (Target_Type);
7957          Xtyp : constant Entity_Id := Etype (Operand);
7958          Conv : Node_Id;
7959          Tnn  : Entity_Id;
7960
7961       begin
7962          --  Nothing to do if conversion was rewritten
7963
7964          if Nkind (N) /= N_Type_Conversion then
7965             return;
7966          end if;
7967
7968          --  Nothing to do if range checks suppressed, or target has the same
7969          --  range as the base type (or is the base type).
7970
7971          if Range_Checks_Suppressed (Target_Type)
7972            or else (Lo = Type_Low_Bound (Btyp)
7973                       and then
7974                     Hi = Type_High_Bound (Btyp))
7975          then
7976             return;
7977          end if;
7978
7979          --  Nothing to do if expression is an entity on which checks have been
7980          --  suppressed.
7981
7982          if Is_Entity_Name (Operand)
7983            and then Range_Checks_Suppressed (Entity (Operand))
7984          then
7985             return;
7986          end if;
7987
7988          --  Nothing to do if bounds are all static and we can tell that the
7989          --  expression is within the bounds of the target. Note that if the
7990          --  operand is of an unconstrained floating-point type, then we do
7991          --  not trust it to be in range (might be infinite)
7992
7993          declare
7994             S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
7995             S_Hi : constant Node_Id := Type_High_Bound (Xtyp);
7996
7997          begin
7998             if (not Is_Floating_Point_Type (Xtyp)
7999                  or else Is_Constrained (Xtyp))
8000               and then Compile_Time_Known_Value (S_Lo)
8001               and then Compile_Time_Known_Value (S_Hi)
8002               and then Compile_Time_Known_Value (Hi)
8003               and then Compile_Time_Known_Value (Lo)
8004             then
8005                declare
8006                   D_Lov : constant Ureal := Expr_Value_R (Lo);
8007                   D_Hiv : constant Ureal := Expr_Value_R (Hi);
8008                   S_Lov : Ureal;
8009                   S_Hiv : Ureal;
8010
8011                begin
8012                   if Is_Real_Type (Xtyp) then
8013                      S_Lov := Expr_Value_R (S_Lo);
8014                      S_Hiv := Expr_Value_R (S_Hi);
8015                   else
8016                      S_Lov := UR_From_Uint (Expr_Value (S_Lo));
8017                      S_Hiv := UR_From_Uint (Expr_Value (S_Hi));
8018                   end if;
8019
8020                   if D_Hiv > D_Lov
8021                     and then S_Lov >= D_Lov
8022                     and then S_Hiv <= D_Hiv
8023                   then
8024                      Set_Do_Range_Check (Operand, False);
8025                      return;
8026                   end if;
8027                end;
8028             end if;
8029          end;
8030
8031          --  For float to float conversions, we are done
8032
8033          if Is_Floating_Point_Type (Xtyp)
8034               and then
8035             Is_Floating_Point_Type (Btyp)
8036          then
8037             return;
8038          end if;
8039
8040          --  Otherwise rewrite the conversion as described above
8041
8042          Conv := Relocate_Node (N);
8043          Rewrite (Subtype_Mark (Conv), New_Occurrence_Of (Btyp, Loc));
8044          Set_Etype (Conv, Btyp);
8045
8046          --  Enable overflow except for case of integer to float conversions,
8047          --  where it is never required, since we can never have overflow in
8048          --  this case.
8049
8050          if not Is_Integer_Type (Etype (Operand)) then
8051             Enable_Overflow_Check (Conv);
8052          end if;
8053
8054          Tnn := Make_Temporary (Loc, 'T', Conv);
8055
8056          Insert_Actions (N, New_List (
8057            Make_Object_Declaration (Loc,
8058              Defining_Identifier => Tnn,
8059              Object_Definition   => New_Occurrence_Of (Btyp, Loc),
8060              Expression => Conv),
8061
8062            Make_Raise_Constraint_Error (Loc,
8063              Condition =>
8064               Make_Or_Else (Loc,
8065                 Left_Opnd =>
8066                   Make_Op_Lt (Loc,
8067                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
8068                     Right_Opnd =>
8069                       Make_Attribute_Reference (Loc,
8070                         Attribute_Name => Name_First,
8071                         Prefix =>
8072                           New_Occurrence_Of (Target_Type, Loc))),
8073
8074                 Right_Opnd =>
8075                   Make_Op_Gt (Loc,
8076                     Left_Opnd  => New_Occurrence_Of (Tnn, Loc),
8077                     Right_Opnd =>
8078                       Make_Attribute_Reference (Loc,
8079                         Attribute_Name => Name_Last,
8080                         Prefix =>
8081                           New_Occurrence_Of (Target_Type, Loc)))),
8082              Reason => CE_Range_Check_Failed)));
8083
8084          Rewrite (N, New_Occurrence_Of (Tnn, Loc));
8085          Analyze_And_Resolve (N, Btyp);
8086       end Real_Range_Check;
8087
8088    --  Start of processing for Expand_N_Type_Conversion
8089
8090    begin
8091       --  Nothing at all to do if conversion is to the identical type so remove
8092       --  the conversion completely, it is useless, except that it may carry
8093       --  an Assignment_OK attribute, which must be propagated to the operand.
8094
8095       if Operand_Type = Target_Type then
8096          if Assignment_OK (N) then
8097             Set_Assignment_OK (Operand);
8098          end if;
8099
8100          Rewrite (N, Relocate_Node (Operand));
8101          return;
8102       end if;
8103
8104       --  Nothing to do if this is the second argument of read. This is a
8105       --  "backwards" conversion that will be handled by the specialized code
8106       --  in attribute processing.
8107
8108       if Nkind (Parent (N)) = N_Attribute_Reference
8109         and then Attribute_Name (Parent (N)) = Name_Read
8110         and then Next (First (Expressions (Parent (N)))) = N
8111       then
8112          return;
8113       end if;
8114
8115       --  Here if we may need to expand conversion
8116
8117       --  If the operand of the type conversion is an arithmetic operation on
8118       --  signed integers, and the based type of the signed integer type in
8119       --  question is smaller than Standard.Integer, we promote both of the
8120       --  operands to type Integer.
8121
8122       --  For example, if we have
8123
8124       --     target-type (opnd1 + opnd2)
8125
8126       --  and opnd1 and opnd2 are of type short integer, then we rewrite
8127       --  this as:
8128
8129       --     target-type (integer(opnd1) + integer(opnd2))
8130
8131       --  We do this because we are always allowed to compute in a larger type
8132       --  if we do the right thing with the result, and in this case we are
8133       --  going to do a conversion which will do an appropriate check to make
8134       --  sure that things are in range of the target type in any case. This
8135       --  avoids some unnecessary intermediate overflows.
8136
8137       --  We might consider a similar transformation in the case where the
8138       --  target is a real type or a 64-bit integer type, and the operand
8139       --  is an arithmetic operation using a 32-bit integer type. However,
8140       --  we do not bother with this case, because it could cause significant
8141       --  ineffiencies on 32-bit machines. On a 64-bit machine it would be
8142       --  much cheaper, but we don't want different behavior on 32-bit and
8143       --  64-bit machines. Note that the exclusion of the 64-bit case also
8144       --  handles the configurable run-time cases where 64-bit arithmetic
8145       --  may simply be unavailable.
8146
8147       --  Note: this circuit is partially redundant with respect to the circuit
8148       --  in Checks.Apply_Arithmetic_Overflow_Check, but we catch more cases in
8149       --  the processing here. Also we still need the Checks circuit, since we
8150       --  have to be sure not to generate junk overflow checks in the first
8151       --  place, since it would be trick to remove them here!
8152
8153       if Integer_Promotion_Possible (N) then
8154
8155          --  All conditions met, go ahead with transformation
8156
8157          declare
8158             Opnd : Node_Id;
8159             L, R : Node_Id;
8160
8161          begin
8162             R :=
8163               Make_Type_Conversion (Loc,
8164                 Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
8165                 Expression   => Relocate_Node (Right_Opnd (Operand)));
8166
8167             Opnd := New_Op_Node (Nkind (Operand), Loc);
8168             Set_Right_Opnd (Opnd, R);
8169
8170             if Nkind (Operand) in N_Binary_Op then
8171                L :=
8172                  Make_Type_Conversion (Loc,
8173                    Subtype_Mark => New_Reference_To (Standard_Integer, Loc),
8174                    Expression   => Relocate_Node (Left_Opnd (Operand)));
8175
8176                Set_Left_Opnd  (Opnd, L);
8177             end if;
8178
8179             Rewrite (N,
8180               Make_Type_Conversion (Loc,
8181                 Subtype_Mark => Relocate_Node (Subtype_Mark (N)),
8182                 Expression   => Opnd));
8183
8184             Analyze_And_Resolve (N, Target_Type);
8185             return;
8186          end;
8187       end if;
8188
8189       --  Do validity check if validity checking operands
8190
8191       if Validity_Checks_On
8192         and then Validity_Check_Operands
8193       then
8194          Ensure_Valid (Operand);
8195       end if;
8196
8197       --  Special case of converting from non-standard boolean type
8198
8199       if Is_Boolean_Type (Operand_Type)
8200         and then (Nonzero_Is_True (Operand_Type))
8201       then
8202          Adjust_Condition (Operand);
8203          Set_Etype (Operand, Standard_Boolean);
8204          Operand_Type := Standard_Boolean;
8205       end if;
8206
8207       --  Case of converting to an access type
8208
8209       if Is_Access_Type (Target_Type) then
8210
8211          --  Apply an accessibility check when the conversion operand is an
8212          --  access parameter (or a renaming thereof), unless conversion was
8213          --  expanded from an Unchecked_ or Unrestricted_Access attribute.
8214          --  Note that other checks may still need to be applied below (such
8215          --  as tagged type checks).
8216
8217          if Is_Entity_Name (Operand)
8218            and then
8219              (Is_Formal (Entity (Operand))
8220                or else
8221                  (Present (Renamed_Object (Entity (Operand)))
8222                    and then Is_Entity_Name (Renamed_Object (Entity (Operand)))
8223                    and then Is_Formal
8224                               (Entity (Renamed_Object (Entity (Operand))))))
8225            and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type
8226            and then (Nkind (Original_Node (N)) /= N_Attribute_Reference
8227                       or else Attribute_Name (Original_Node (N)) = Name_Access)
8228          then
8229             Apply_Accessibility_Check
8230               (Operand, Target_Type, Insert_Node => Operand);
8231
8232          --  If the level of the operand type is statically deeper than the
8233          --  level of the target type, then force Program_Error. Note that this
8234          --  can only occur for cases where the attribute is within the body of
8235          --  an instantiation (otherwise the conversion will already have been
8236          --  rejected as illegal). Note: warnings are issued by the analyzer
8237          --  for the instance cases.
8238
8239          elsif In_Instance_Body
8240            and then Type_Access_Level (Operand_Type) >
8241                     Type_Access_Level (Target_Type)
8242          then
8243             Raise_Accessibility_Error;
8244
8245          --  When the operand is a selected access discriminant the check needs
8246          --  to be made against the level of the object denoted by the prefix
8247          --  of the selected name. Force Program_Error for this case as well
8248          --  (this accessibility violation can only happen if within the body
8249          --  of an instantiation).
8250
8251          elsif In_Instance_Body
8252            and then Ekind (Operand_Type) = E_Anonymous_Access_Type
8253            and then Nkind (Operand) = N_Selected_Component
8254            and then Object_Access_Level (Operand) >
8255                       Type_Access_Level (Target_Type)
8256          then
8257             Raise_Accessibility_Error;
8258             return;
8259          end if;
8260       end if;
8261
8262       --  Case of conversions of tagged types and access to tagged types
8263
8264       --  When needed, that is to say when the expression is class-wide, Add
8265       --  runtime a tag check for (strict) downward conversion by using the
8266       --  membership test, generating:
8267
8268       --      [constraint_error when Operand not in Target_Type'Class]
8269
8270       --  or in the access type case
8271
8272       --      [constraint_error
8273       --        when Operand /= null
8274       --          and then Operand.all not in
8275       --            Designated_Type (Target_Type)'Class]
8276
8277       if (Is_Access_Type (Target_Type)
8278            and then Is_Tagged_Type (Designated_Type (Target_Type)))
8279         or else Is_Tagged_Type (Target_Type)
8280       then
8281          --  Do not do any expansion in the access type case if the parent is a
8282          --  renaming, since this is an error situation which will be caught by
8283          --  Sem_Ch8, and the expansion can interfere with this error check.
8284
8285          if Is_Access_Type (Target_Type) and then Is_Renamed_Object (N) then
8286             return;
8287          end if;
8288
8289          --  Otherwise, proceed with processing tagged conversion
8290
8291          Tagged_Conversion : declare
8292             Actual_Op_Typ   : Entity_Id;
8293             Actual_Targ_Typ : Entity_Id;
8294             Make_Conversion : Boolean := False;
8295             Root_Op_Typ     : Entity_Id;
8296
8297             procedure Make_Tag_Check (Targ_Typ : Entity_Id);
8298             --  Create a membership check to test whether Operand is a member
8299             --  of Targ_Typ. If the original Target_Type is an access, include
8300             --  a test for null value. The check is inserted at N.
8301
8302             --------------------
8303             -- Make_Tag_Check --
8304             --------------------
8305
8306             procedure Make_Tag_Check (Targ_Typ : Entity_Id) is
8307                Cond : Node_Id;
8308
8309             begin
8310                --  Generate:
8311                --    [Constraint_Error
8312                --       when Operand /= null
8313                --         and then Operand.all not in Targ_Typ]
8314
8315                if Is_Access_Type (Target_Type) then
8316                   Cond :=
8317                     Make_And_Then (Loc,
8318                       Left_Opnd =>
8319                         Make_Op_Ne (Loc,
8320                           Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
8321                           Right_Opnd => Make_Null (Loc)),
8322
8323                       Right_Opnd =>
8324                         Make_Not_In (Loc,
8325                           Left_Opnd  =>
8326                             Make_Explicit_Dereference (Loc,
8327                               Prefix => Duplicate_Subexpr_No_Checks (Operand)),
8328                           Right_Opnd => New_Reference_To (Targ_Typ, Loc)));
8329
8330                --  Generate:
8331                --    [Constraint_Error when Operand not in Targ_Typ]
8332
8333                else
8334                   Cond :=
8335                     Make_Not_In (Loc,
8336                       Left_Opnd  => Duplicate_Subexpr_No_Checks (Operand),
8337                       Right_Opnd => New_Reference_To (Targ_Typ, Loc));
8338                end if;
8339
8340                Insert_Action (N,
8341                  Make_Raise_Constraint_Error (Loc,
8342                    Condition => Cond,
8343                    Reason    => CE_Tag_Check_Failed));
8344             end Make_Tag_Check;
8345
8346          --  Start of processing for Tagged_Conversion
8347
8348          begin
8349             if Is_Access_Type (Target_Type) then
8350
8351                --  Handle entities from the limited view
8352
8353                Actual_Op_Typ :=
8354                  Available_View (Designated_Type (Operand_Type));
8355                Actual_Targ_Typ :=
8356                  Available_View (Designated_Type (Target_Type));
8357             else
8358                Actual_Op_Typ   := Operand_Type;
8359                Actual_Targ_Typ := Target_Type;
8360             end if;
8361
8362             Root_Op_Typ := Root_Type (Actual_Op_Typ);
8363
8364             --  Ada 2005 (AI-251): Handle interface type conversion
8365
8366             if Is_Interface (Actual_Op_Typ) then
8367                Expand_Interface_Conversion (N, Is_Static => False);
8368                return;
8369             end if;
8370
8371             if not Tag_Checks_Suppressed (Actual_Targ_Typ) then
8372
8373                --  Create a runtime tag check for a downward class-wide type
8374                --  conversion.
8375
8376                if Is_Class_Wide_Type (Actual_Op_Typ)
8377                  and then Actual_Op_Typ /= Actual_Targ_Typ
8378                  and then Root_Op_Typ /= Actual_Targ_Typ
8379                  and then Is_Ancestor (Root_Op_Typ, Actual_Targ_Typ)
8380                then
8381                   Make_Tag_Check (Class_Wide_Type (Actual_Targ_Typ));
8382                   Make_Conversion := True;
8383                end if;
8384
8385                --  AI05-0073: If the result subtype of the function is defined
8386                --  by an access_definition designating a specific tagged type
8387                --  T, a check is made that the result value is null or the tag
8388                --  of the object designated by the result value identifies T.
8389                --  Constraint_Error is raised if this check fails.
8390
8391                if Nkind (Parent (N)) = Sinfo.N_Return_Statement then
8392                   declare
8393                      Func     : Entity_Id;
8394                      Func_Typ : Entity_Id;
8395
8396                   begin
8397                      --  Climb scope stack looking for the enclosing function
8398
8399                      Func := Current_Scope;
8400                      while Present (Func)
8401                        and then Ekind (Func) /= E_Function
8402                      loop
8403                         Func := Scope (Func);
8404                      end loop;
8405
8406                      --  The function's return subtype must be defined using
8407                      --  an access definition.
8408
8409                      if Nkind (Result_Definition (Parent (Func))) =
8410                           N_Access_Definition
8411                      then
8412                         Func_Typ := Directly_Designated_Type (Etype (Func));
8413
8414                         --  The return subtype denotes a specific tagged type,
8415                         --  in other words, a non class-wide type.
8416
8417                         if Is_Tagged_Type (Func_Typ)
8418                           and then not Is_Class_Wide_Type (Func_Typ)
8419                         then
8420                            Make_Tag_Check (Actual_Targ_Typ);
8421                            Make_Conversion := True;
8422                         end if;
8423                      end if;
8424                   end;
8425                end if;
8426
8427                --  We have generated a tag check for either a class-wide type
8428                --  conversion or for AI05-0073.
8429
8430                if Make_Conversion then
8431                   declare
8432                      Conv : Node_Id;
8433                   begin
8434                      Conv :=
8435                        Make_Unchecked_Type_Conversion (Loc,
8436                          Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
8437                          Expression   => Relocate_Node (Expression (N)));
8438                      Rewrite (N, Conv);
8439                      Analyze_And_Resolve (N, Target_Type);
8440                   end;
8441                end if;
8442             end if;
8443          end Tagged_Conversion;
8444
8445       --  Case of other access type conversions
8446
8447       elsif Is_Access_Type (Target_Type) then
8448          Apply_Constraint_Check (Operand, Target_Type);
8449
8450       --  Case of conversions from a fixed-point type
8451
8452       --  These conversions require special expansion and processing, found in
8453       --  the Exp_Fixd package. We ignore cases where Conversion_OK is set,
8454       --  since from a semantic point of view, these are simple integer
8455       --  conversions, which do not need further processing.
8456
8457       elsif Is_Fixed_Point_Type (Operand_Type)
8458         and then not Conversion_OK (N)
8459       then
8460          --  We should never see universal fixed at this case, since the
8461          --  expansion of the constituent divide or multiply should have
8462          --  eliminated the explicit mention of universal fixed.
8463
8464          pragma Assert (Operand_Type /= Universal_Fixed);
8465
8466          --  Check for special case of the conversion to universal real that
8467          --  occurs as a result of the use of a round attribute. In this case,
8468          --  the real type for the conversion is taken from the target type of
8469          --  the Round attribute and the result must be marked as rounded.
8470
8471          if Target_Type = Universal_Real
8472            and then Nkind (Parent (N)) = N_Attribute_Reference
8473            and then Attribute_Name (Parent (N)) = Name_Round
8474          then
8475             Set_Rounded_Result (N);
8476             Set_Etype (N, Etype (Parent (N)));
8477          end if;
8478
8479          --  Otherwise do correct fixed-conversion, but skip these if the
8480          --  Conversion_OK flag is set, because from a semantic point of view
8481          --  these are simple integer conversions needing no further processing
8482          --  (the backend will simply treat them as integers).
8483
8484          if not Conversion_OK (N) then
8485             if Is_Fixed_Point_Type (Etype (N)) then
8486                Expand_Convert_Fixed_To_Fixed (N);
8487                Real_Range_Check;
8488
8489             elsif Is_Integer_Type (Etype (N)) then
8490                Expand_Convert_Fixed_To_Integer (N);
8491
8492             else
8493                pragma Assert (Is_Floating_Point_Type (Etype (N)));
8494                Expand_Convert_Fixed_To_Float (N);
8495                Real_Range_Check;
8496             end if;
8497          end if;
8498
8499       --  Case of conversions to a fixed-point type
8500
8501       --  These conversions require special expansion and processing, found in
8502       --  the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
8503       --  since from a semantic point of view, these are simple integer
8504       --  conversions, which do not need further processing.
8505
8506       elsif Is_Fixed_Point_Type (Target_Type)
8507         and then not Conversion_OK (N)
8508       then
8509          if Is_Integer_Type (Operand_Type) then
8510             Expand_Convert_Integer_To_Fixed (N);
8511             Real_Range_Check;
8512          else
8513             pragma Assert (Is_Floating_Point_Type (Operand_Type));
8514             Expand_Convert_Float_To_Fixed (N);
8515             Real_Range_Check;
8516          end if;
8517
8518       --  Case of float-to-integer conversions
8519
8520       --  We also handle float-to-fixed conversions with Conversion_OK set
8521       --  since semantically the fixed-point target is treated as though it
8522       --  were an integer in such cases.
8523
8524       elsif Is_Floating_Point_Type (Operand_Type)
8525         and then
8526           (Is_Integer_Type (Target_Type)
8527             or else
8528           (Is_Fixed_Point_Type (Target_Type) and then Conversion_OK (N)))
8529       then
8530          --  One more check here, gcc is still not able to do conversions of
8531          --  this type with proper overflow checking, and so gigi is doing an
8532          --  approximation of what is required by doing floating-point compares
8533          --  with the end-point. But that can lose precision in some cases, and
8534          --  give a wrong result. Converting the operand to Universal_Real is
8535          --  helpful, but still does not catch all cases with 64-bit integers
8536          --  on targets with only 64-bit floats.
8537
8538          --  The above comment seems obsoleted by Apply_Float_Conversion_Check
8539          --  Can this code be removed ???
8540
8541          if Do_Range_Check (Operand) then
8542             Rewrite (Operand,
8543               Make_Type_Conversion (Loc,
8544                 Subtype_Mark =>
8545                   New_Occurrence_Of (Universal_Real, Loc),
8546                 Expression =>
8547                   Relocate_Node (Operand)));
8548
8549             Set_Etype (Operand, Universal_Real);
8550             Enable_Range_Check (Operand);
8551             Set_Do_Range_Check (Expression (Operand), False);
8552          end if;
8553
8554       --  Case of array conversions
8555
8556       --  Expansion of array conversions, add required length/range checks but
8557       --  only do this if there is no change of representation. For handling of
8558       --  this case, see Handle_Changed_Representation.
8559
8560       elsif Is_Array_Type (Target_Type) then
8561
8562          if Is_Constrained (Target_Type) then
8563             Apply_Length_Check (Operand, Target_Type);
8564          else
8565             Apply_Range_Check (Operand, Target_Type);
8566          end if;
8567
8568          Handle_Changed_Representation;
8569
8570       --  Case of conversions of discriminated types
8571
8572       --  Add required discriminant checks if target is constrained. Again this
8573       --  change is skipped if we have a change of representation.
8574
8575       elsif Has_Discriminants (Target_Type)
8576         and then Is_Constrained (Target_Type)
8577       then
8578          Apply_Discriminant_Check (Operand, Target_Type);
8579          Handle_Changed_Representation;
8580
8581       --  Case of all other record conversions. The only processing required
8582       --  is to check for a change of representation requiring the special
8583       --  assignment processing.
8584
8585       elsif Is_Record_Type (Target_Type) then
8586
8587          --  Ada 2005 (AI-216): Program_Error is raised when converting from
8588          --  a derived Unchecked_Union type to an unconstrained type that is
8589          --  not Unchecked_Union if the operand lacks inferable discriminants.
8590
8591          if Is_Derived_Type (Operand_Type)
8592            and then Is_Unchecked_Union (Base_Type (Operand_Type))
8593            and then not Is_Constrained (Target_Type)
8594            and then not Is_Unchecked_Union (Base_Type (Target_Type))
8595            and then not Has_Inferable_Discriminants (Operand)
8596          then
8597             --  To prevent Gigi from generating illegal code, we generate a
8598             --  Program_Error node, but we give it the target type of the
8599             --  conversion.
8600
8601             declare
8602                PE : constant Node_Id := Make_Raise_Program_Error (Loc,
8603                       Reason => PE_Unchecked_Union_Restriction);
8604
8605             begin
8606                Set_Etype (PE, Target_Type);
8607                Rewrite (N, PE);
8608
8609             end;
8610          else
8611             Handle_Changed_Representation;
8612          end if;
8613
8614       --  Case of conversions of enumeration types
8615
8616       elsif Is_Enumeration_Type (Target_Type) then
8617
8618          --  Special processing is required if there is a change of
8619          --  representation (from enumeration representation clauses).
8620
8621          if not Same_Representation (Target_Type, Operand_Type) then
8622
8623             --  Convert: x(y) to x'val (ytyp'val (y))
8624
8625             Rewrite (N,
8626                Make_Attribute_Reference (Loc,
8627                  Prefix => New_Occurrence_Of (Target_Type, Loc),
8628                  Attribute_Name => Name_Val,
8629                  Expressions => New_List (
8630                    Make_Attribute_Reference (Loc,
8631                      Prefix => New_Occurrence_Of (Operand_Type, Loc),
8632                      Attribute_Name => Name_Pos,
8633                      Expressions => New_List (Operand)))));
8634
8635             Analyze_And_Resolve (N, Target_Type);
8636          end if;
8637
8638       --  Case of conversions to floating-point
8639
8640       elsif Is_Floating_Point_Type (Target_Type) then
8641          Real_Range_Check;
8642       end if;
8643
8644       --  At this stage, either the conversion node has been transformed into
8645       --  some other equivalent expression, or left as a conversion that can be
8646       --  handled by Gigi, in the following cases:
8647
8648       --    Conversions with no change of representation or type
8649
8650       --    Numeric conversions involving integer, floating- and fixed-point
8651       --    values. Fixed-point values are allowed only if Conversion_OK is
8652       --    set, i.e. if the fixed-point values are to be treated as integers.
8653
8654       --  No other conversions should be passed to Gigi
8655
8656       --  Check: are these rules stated in sinfo??? if so, why restate here???
8657
8658       --  The only remaining step is to generate a range check if we still have
8659       --  a type conversion at this stage and Do_Range_Check is set. For now we
8660       --  do this only for conversions of discrete types.
8661
8662       if Nkind (N) = N_Type_Conversion
8663         and then Is_Discrete_Type (Etype (N))
8664       then
8665          declare
8666             Expr : constant Node_Id := Expression (N);
8667             Ftyp : Entity_Id;
8668             Ityp : Entity_Id;
8669
8670          begin
8671             if Do_Range_Check (Expr)
8672               and then Is_Discrete_Type (Etype (Expr))
8673             then
8674                Set_Do_Range_Check (Expr, False);
8675
8676                --  Before we do a range check, we have to deal with treating a
8677                --  fixed-point operand as an integer. The way we do this is
8678                --  simply to do an unchecked conversion to an appropriate
8679                --  integer type large enough to hold the result.
8680
8681                --  This code is not active yet, because we are only dealing
8682                --  with discrete types so far ???
8683
8684                if Nkind (Expr) in N_Has_Treat_Fixed_As_Integer
8685                  and then Treat_Fixed_As_Integer (Expr)
8686                then
8687                   Ftyp := Base_Type (Etype (Expr));
8688
8689                   if Esize (Ftyp) >= Esize (Standard_Integer) then
8690                      Ityp := Standard_Long_Long_Integer;
8691                   else
8692                      Ityp := Standard_Integer;
8693                   end if;
8694
8695                   Rewrite (Expr, Unchecked_Convert_To (Ityp, Expr));
8696                end if;
8697
8698                --  Reset overflow flag, since the range check will include
8699                --  dealing with possible overflow, and generate the check. If
8700                --  Address is either a source type or target type, suppress
8701                --  range check to avoid typing anomalies when it is a visible
8702                --  integer type.
8703
8704                Set_Do_Overflow_Check (N, False);
8705                if not Is_Descendent_Of_Address (Etype (Expr))
8706                  and then not Is_Descendent_Of_Address (Target_Type)
8707                then
8708                   Generate_Range_Check
8709                     (Expr, Target_Type, CE_Range_Check_Failed);
8710                end if;
8711             end if;
8712          end;
8713       end if;
8714
8715       --  Final step, if the result is a type conversion involving Vax_Float
8716       --  types, then it is subject for further special processing.
8717
8718       if Nkind (N) = N_Type_Conversion
8719         and then (Vax_Float (Operand_Type) or else Vax_Float (Target_Type))
8720       then
8721          Expand_Vax_Conversion (N);
8722          return;
8723       end if;
8724    end Expand_N_Type_Conversion;
8725
8726    -----------------------------------
8727    -- Expand_N_Unchecked_Expression --
8728    -----------------------------------
8729
8730    --  Remove the unchecked expression node from the tree. Its job was simply
8731    --  to make sure that its constituent expression was handled with checks
8732    --  off, and now that that is done, we can remove it from the tree, and
8733    --  indeed must, since Gigi does not expect to see these nodes.
8734
8735    procedure Expand_N_Unchecked_Expression (N : Node_Id) is
8736       Exp : constant Node_Id := Expression (N);
8737    begin
8738       Set_Assignment_OK (Exp, Assignment_OK (N) or else Assignment_OK (Exp));
8739       Rewrite (N, Exp);
8740    end Expand_N_Unchecked_Expression;
8741
8742    ----------------------------------------
8743    -- Expand_N_Unchecked_Type_Conversion --
8744    ----------------------------------------
8745
8746    --  If this cannot be handled by Gigi and we haven't already made a
8747    --  temporary for it, do it now.
8748
8749    procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
8750       Target_Type  : constant Entity_Id := Etype (N);
8751       Operand      : constant Node_Id   := Expression (N);
8752       Operand_Type : constant Entity_Id := Etype (Operand);
8753
8754    begin
8755       --  Nothing at all to do if conversion is to the identical type so remove
8756       --  the conversion completely, it is useless, except that it may carry
8757       --  an Assignment_OK indication which must be propagated to the operand.
8758
8759       if Operand_Type = Target_Type then
8760
8761          --  Code duplicates Expand_N_Unchecked_Expression above, factor???
8762
8763          if Assignment_OK (N) then
8764             Set_Assignment_OK (Operand);
8765          end if;
8766
8767          Rewrite (N, Relocate_Node (Operand));
8768          return;
8769       end if;
8770
8771       --  If we have a conversion of a compile time known value to a target
8772       --  type and the value is in range of the target type, then we can simply
8773       --  replace the construct by an integer literal of the correct type. We
8774       --  only apply this to integer types being converted. Possibly it may
8775       --  apply in other cases, but it is too much trouble to worry about.
8776
8777       --  Note that we do not do this transformation if the Kill_Range_Check
8778       --  flag is set, since then the value may be outside the expected range.
8779       --  This happens in the Normalize_Scalars case.
8780
8781       --  We also skip this if either the target or operand type is biased
8782       --  because in this case, the unchecked conversion is supposed to
8783       --  preserve the bit pattern, not the integer value.
8784
8785       if Is_Integer_Type (Target_Type)
8786         and then not Has_Biased_Representation (Target_Type)
8787         and then Is_Integer_Type (Operand_Type)
8788         and then not Has_Biased_Representation (Operand_Type)
8789         and then Compile_Time_Known_Value (Operand)
8790         and then not Kill_Range_Check (N)
8791       then
8792          declare
8793             Val : constant Uint := Expr_Value (Operand);
8794
8795          begin
8796             if Compile_Time_Known_Value (Type_Low_Bound (Target_Type))
8797                  and then
8798                Compile_Time_Known_Value (Type_High_Bound (Target_Type))
8799                  and then
8800                Val >= Expr_Value (Type_Low_Bound (Target_Type))
8801                  and then
8802                Val <= Expr_Value (Type_High_Bound (Target_Type))
8803             then
8804                Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
8805
8806                --  If Address is the target type, just set the type to avoid a
8807                --  spurious type error on the literal when Address is a visible
8808                --  integer type.
8809
8810                if Is_Descendent_Of_Address (Target_Type) then
8811                   Set_Etype (N, Target_Type);
8812                else
8813                   Analyze_And_Resolve (N, Target_Type);
8814                end if;
8815
8816                return;
8817             end if;
8818          end;
8819       end if;
8820
8821       --  Nothing to do if conversion is safe
8822
8823       if Safe_Unchecked_Type_Conversion (N) then
8824          return;
8825       end if;
8826
8827       --  Otherwise force evaluation unless Assignment_OK flag is set (this
8828       --  flag indicates ??? -- more comments needed here)
8829
8830       if Assignment_OK (N) then
8831          null;
8832       else
8833          Force_Evaluation (N);
8834       end if;
8835    end Expand_N_Unchecked_Type_Conversion;
8836
8837    ----------------------------
8838    -- Expand_Record_Equality --
8839    ----------------------------
8840
8841    --  For non-variant records, Equality is expanded when needed into:
8842
8843    --      and then Lhs.Discr1 = Rhs.Discr1
8844    --      and then ...
8845    --      and then Lhs.Discrn = Rhs.Discrn
8846    --      and then Lhs.Cmp1 = Rhs.Cmp1
8847    --      and then ...
8848    --      and then Lhs.Cmpn = Rhs.Cmpn
8849
8850    --  The expression is folded by the back-end for adjacent fields. This
8851    --  function is called for tagged record in only one occasion: for imple-
8852    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
8853    --  otherwise the primitive "=" is used directly.
8854
8855    function Expand_Record_Equality
8856      (Nod    : Node_Id;
8857       Typ    : Entity_Id;
8858       Lhs    : Node_Id;
8859       Rhs    : Node_Id;
8860       Bodies : List_Id) return Node_Id
8861    is
8862       Loc : constant Source_Ptr := Sloc (Nod);
8863
8864       Result : Node_Id;
8865       C      : Entity_Id;
8866
8867       First_Time : Boolean := True;
8868
8869       function Suitable_Element (C : Entity_Id) return Entity_Id;
8870       --  Return the first field to compare beginning with C, skipping the
8871       --  inherited components.
8872
8873       ----------------------
8874       -- Suitable_Element --
8875       ----------------------
8876
8877       function Suitable_Element (C : Entity_Id) return Entity_Id is
8878       begin
8879          if No (C) then
8880             return Empty;
8881
8882          elsif Ekind (C) /= E_Discriminant
8883            and then Ekind (C) /= E_Component
8884          then
8885             return Suitable_Element (Next_Entity (C));
8886
8887          elsif Is_Tagged_Type (Typ)
8888            and then C /= Original_Record_Component (C)
8889          then
8890             return Suitable_Element (Next_Entity (C));
8891
8892          elsif Chars (C) = Name_uController
8893            or else Chars (C) = Name_uTag
8894          then
8895             return Suitable_Element (Next_Entity (C));
8896
8897          elsif Is_Interface (Etype (C)) then
8898             return Suitable_Element (Next_Entity (C));
8899
8900          else
8901             return C;
8902          end if;
8903       end Suitable_Element;
8904
8905    --  Start of processing for Expand_Record_Equality
8906
8907    begin
8908       --  Generates the following code: (assuming that Typ has one Discr and
8909       --  component C2 is also a record)
8910
8911       --   True
8912       --     and then Lhs.Discr1 = Rhs.Discr1
8913       --     and then Lhs.C1 = Rhs.C1
8914       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
8915       --     and then ...
8916       --     and then Lhs.Cmpn = Rhs.Cmpn
8917
8918       Result := New_Reference_To (Standard_True, Loc);
8919       C := Suitable_Element (First_Entity (Typ));
8920       while Present (C) loop
8921          declare
8922             New_Lhs : Node_Id;
8923             New_Rhs : Node_Id;
8924             Check   : Node_Id;
8925
8926          begin
8927             if First_Time then
8928                First_Time := False;
8929                New_Lhs := Lhs;
8930                New_Rhs := Rhs;
8931             else
8932                New_Lhs := New_Copy_Tree (Lhs);
8933                New_Rhs := New_Copy_Tree (Rhs);
8934             end if;
8935
8936             Check :=
8937               Expand_Composite_Equality (Nod, Etype (C),
8938                Lhs =>
8939                  Make_Selected_Component (Loc,
8940                    Prefix => New_Lhs,
8941                    Selector_Name => New_Reference_To (C, Loc)),
8942                Rhs =>
8943                  Make_Selected_Component (Loc,
8944                    Prefix => New_Rhs,
8945                    Selector_Name => New_Reference_To (C, Loc)),
8946                Bodies => Bodies);
8947
8948             --  If some (sub)component is an unchecked_union, the whole
8949             --  operation will raise program error.
8950
8951             if Nkind (Check) = N_Raise_Program_Error then
8952                Result := Check;
8953                Set_Etype (Result, Standard_Boolean);
8954                exit;
8955             else
8956                Result :=
8957                  Make_And_Then (Loc,
8958                    Left_Opnd  => Result,
8959                    Right_Opnd => Check);
8960             end if;
8961          end;
8962
8963          C := Suitable_Element (Next_Entity (C));
8964       end loop;
8965
8966       return Result;
8967    end Expand_Record_Equality;
8968
8969    -----------------------------------
8970    -- Expand_Short_Circuit_Operator --
8971    -----------------------------------
8972
8973    --  Deal with special expansion if actions are present for the right operand
8974    --  and deal with optimizing case of arguments being True or False. We also
8975    --  deal with the special case of non-standard boolean values.
8976
8977    procedure Expand_Short_Circuit_Operator (N : Node_Id) is
8978       Loc     : constant Source_Ptr := Sloc (N);
8979       Typ     : constant Entity_Id  := Etype (N);
8980       Left    : constant Node_Id    := Left_Opnd (N);
8981       Right   : constant Node_Id    := Right_Opnd (N);
8982       LocR    : constant Source_Ptr := Sloc (Right);
8983       Actlist : List_Id;
8984
8985       Shortcut_Value : constant Boolean := Nkind (N) = N_Or_Else;
8986       Shortcut_Ent   : constant Entity_Id := Boolean_Literals (Shortcut_Value);
8987       --  If Left = Shortcut_Value then Right need not be evaluated
8988
8989       function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
8990       --  For Opnd a boolean expression, return a Boolean expression equivalent
8991       --  to Opnd /= Shortcut_Value.
8992
8993       --------------------
8994       -- Make_Test_Expr --
8995       --------------------
8996
8997       function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
8998       begin
8999          if Shortcut_Value then
9000             return Make_Op_Not (Sloc (Opnd), Opnd);
9001          else
9002             return Opnd;
9003          end if;
9004       end Make_Test_Expr;
9005
9006       Op_Var : Entity_Id;
9007       --  Entity for a temporary variable holding the value of the operator,
9008       --  used for expansion in the case where actions are present.
9009
9010    --  Start of processing for Expand_Short_Circuit_Operator
9011
9012    begin
9013       --  Deal with non-standard booleans
9014
9015       if Is_Boolean_Type (Typ) then
9016          Adjust_Condition (Left);
9017          Adjust_Condition (Right);
9018          Set_Etype (N, Standard_Boolean);
9019       end if;
9020
9021       --  Check for cases where left argument is known to be True or False
9022
9023       if Compile_Time_Known_Value (Left) then
9024
9025          --  Mark SCO for left condition as compile time known
9026
9027          if Generate_SCO and then Comes_From_Source (Left) then
9028             Set_SCO_Condition (Left, Expr_Value_E (Left) = Standard_True);
9029          end if;
9030
9031          --  Rewrite True AND THEN Right / False OR ELSE Right to Right.
9032          --  Any actions associated with Right will be executed unconditionally
9033          --  and can thus be inserted into the tree unconditionally.
9034
9035          if Expr_Value_E (Left) /= Shortcut_Ent then
9036             if Present (Actions (N)) then
9037                Insert_Actions (N, Actions (N));
9038             end if;
9039
9040             Rewrite (N, Right);
9041
9042          --  Rewrite False AND THEN Right / True OR ELSE Right to Left.
9043          --  In this case we can forget the actions associated with Right,
9044          --  since they will never be executed.
9045
9046          else
9047             Kill_Dead_Code (Right);
9048             Kill_Dead_Code (Actions (N));
9049             Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
9050          end if;
9051
9052          Adjust_Result_Type (N, Typ);
9053          return;
9054       end if;
9055
9056       --  If Actions are present for the right operand, we have to do some
9057       --  special processing. We can't just let these actions filter back into
9058       --  code preceding the short circuit (which is what would have happened
9059       --  if we had not trapped them in the short-circuit form), since they
9060       --  must only be executed if the right operand of the short circuit is
9061       --  executed and not otherwise.
9062
9063       --  the temporary variable C.
9064
9065       if Present (Actions (N)) then
9066          Actlist := Actions (N);
9067
9068          --  The old approach is to expand:
9069
9070          --     left AND THEN right
9071
9072          --  into
9073
9074          --     C : Boolean := False;
9075          --     IF left THEN
9076          --        Actions;
9077          --        IF right THEN
9078          --           C := True;
9079          --        END IF;
9080          --     END IF;
9081
9082          --  and finally rewrite the operator into a reference to C. Similarly
9083          --  for left OR ELSE right, with negated values. Note that this
9084          --  rewrite causes some difficulties for coverage analysis because
9085          --  of the introduction of the new variable C, which obscures the
9086          --  structure of the test.
9087
9088          --  We use this "old approach" if use of N_Expression_With_Actions
9089          --  is False (see description in Opt of when this is or is not set).
9090
9091          if not Use_Expression_With_Actions then
9092             Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
9093
9094             Insert_Action (N,
9095               Make_Object_Declaration (Loc,
9096                 Defining_Identifier =>
9097                   Op_Var,
9098                 Object_Definition   =>
9099                   New_Occurrence_Of (Standard_Boolean, Loc),
9100                 Expression          =>
9101                   New_Occurrence_Of (Shortcut_Ent, Loc)));
9102
9103             Append_To (Actlist,
9104               Make_Implicit_If_Statement (Right,
9105                 Condition       => Make_Test_Expr (Right),
9106                 Then_Statements => New_List (
9107                   Make_Assignment_Statement (LocR,
9108                     Name       => New_Occurrence_Of (Op_Var, LocR),
9109                     Expression =>
9110                       New_Occurrence_Of
9111                         (Boolean_Literals (not Shortcut_Value), LocR)))));
9112
9113             Insert_Action (N,
9114               Make_Implicit_If_Statement (Left,
9115                 Condition       => Make_Test_Expr (Left),
9116                 Then_Statements => Actlist));
9117
9118             Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
9119             Analyze_And_Resolve (N, Standard_Boolean);
9120
9121          --  The new approach, activated for now by the use of debug flag
9122          --  -gnatd.X is to use the new Expression_With_Actions node for the
9123          --  right operand of the short-circuit form. This should solve the
9124          --  traceability problems for coverage analysis.
9125
9126          else
9127             Rewrite (Right,
9128               Make_Expression_With_Actions (LocR,
9129                 Expression => Relocate_Node (Right),
9130                 Actions    => Actlist));
9131             Set_Actions (N, No_List);
9132             Analyze_And_Resolve (Right, Standard_Boolean);
9133          end if;
9134
9135          Adjust_Result_Type (N, Typ);
9136          return;
9137       end if;
9138
9139       --  No actions present, check for cases of right argument True/False
9140
9141       if Compile_Time_Known_Value (Right) then
9142
9143          --  Mark SCO for left condition as compile time known
9144
9145          if Generate_SCO and then Comes_From_Source (Right) then
9146             Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
9147          end if;
9148
9149          --  Change (Left and then True), (Left or else False) to Left.
9150          --  Note that we know there are no actions associated with the right
9151          --  operand, since we just checked for this case above.
9152
9153          if Expr_Value_E (Right) /= Shortcut_Ent then
9154             Rewrite (N, Left);
9155
9156          --  Change (Left and then False), (Left or else True) to Right,
9157          --  making sure to preserve any side effects associated with the Left
9158          --  operand.
9159
9160          else
9161             Remove_Side_Effects (Left);
9162             Rewrite (N, New_Occurrence_Of (Shortcut_Ent, Loc));
9163          end if;
9164       end if;
9165
9166       Adjust_Result_Type (N, Typ);
9167    end Expand_Short_Circuit_Operator;
9168
9169    -------------------------------------
9170    -- Fixup_Universal_Fixed_Operation --
9171    -------------------------------------
9172
9173    procedure Fixup_Universal_Fixed_Operation (N : Node_Id) is
9174       Conv : constant Node_Id := Parent (N);
9175
9176    begin
9177       --  We must have a type conversion immediately above us
9178
9179       pragma Assert (Nkind (Conv) = N_Type_Conversion);
9180
9181       --  Normally the type conversion gives our target type. The exception
9182       --  occurs in the case of the Round attribute, where the conversion
9183       --  will be to universal real, and our real type comes from the Round
9184       --  attribute (as well as an indication that we must round the result)
9185
9186       if Nkind (Parent (Conv)) = N_Attribute_Reference
9187         and then Attribute_Name (Parent (Conv)) = Name_Round
9188       then
9189          Set_Etype (N, Etype (Parent (Conv)));
9190          Set_Rounded_Result (N);
9191
9192       --  Normal case where type comes from conversion above us
9193
9194       else
9195          Set_Etype (N, Etype (Conv));
9196       end if;
9197    end Fixup_Universal_Fixed_Operation;
9198
9199    ------------------------------
9200    -- Get_Allocator_Final_List --
9201    ------------------------------
9202
9203    function Get_Allocator_Final_List
9204      (N    : Node_Id;
9205       T    : Entity_Id;
9206       PtrT : Entity_Id) return Entity_Id
9207    is
9208       Loc : constant Source_Ptr := Sloc (N);
9209
9210       Owner : Entity_Id := PtrT;
9211       --  The entity whose finalization list must be used to attach the
9212       --  allocated object.
9213
9214    begin
9215       if Ekind (PtrT) = E_Anonymous_Access_Type then
9216
9217          --  If the context is an access parameter, we need to create a
9218          --  non-anonymous access type in order to have a usable final list,
9219          --  because there is otherwise no pool to which the allocated object
9220          --  can belong. We create both the type and the finalization chain
9221          --  here, because freezing an internal type does not create such a
9222          --  chain. The Final_Chain that is thus created is shared by the
9223          --  access parameter. The access type is tested against the result
9224          --  type of the function to exclude allocators whose type is an
9225          --  anonymous access result type. We freeze the type at once to
9226          --  ensure that it is properly decorated for the back-end, even
9227          --  if the context and current scope is a loop.
9228
9229          if Nkind (Associated_Node_For_Itype (PtrT))
9230               in N_Subprogram_Specification
9231            and then
9232              PtrT /=
9233                Etype (Defining_Unit_Name (Associated_Node_For_Itype (PtrT)))
9234          then
9235             Owner := Make_Temporary (Loc, 'J');
9236             Insert_Action (N,
9237               Make_Full_Type_Declaration (Loc,
9238                 Defining_Identifier => Owner,
9239                 Type_Definition =>
9240                    Make_Access_To_Object_Definition (Loc,
9241                      Subtype_Indication =>
9242                        New_Occurrence_Of (T, Loc))));
9243
9244             Freeze_Before (N, Owner);
9245             Build_Final_List (N, Owner);
9246             Set_Associated_Final_Chain (PtrT, Associated_Final_Chain (Owner));
9247
9248          --  Ada 2005 (AI-318-02): If the context is a return object
9249          --  declaration, then the anonymous return subtype is defined to have
9250          --  the same accessibility level as that of the function's result
9251          --  subtype, which means that we want the scope where the function is
9252          --  declared.
9253
9254          elsif Nkind (Associated_Node_For_Itype (PtrT)) = N_Object_Declaration
9255            and then Ekind (Scope (PtrT)) = E_Return_Statement
9256          then
9257             Owner := Scope (Return_Applies_To (Scope (PtrT)));
9258
9259          --  Case of an access discriminant, or (Ada 2005) of an anonymous
9260          --  access component or anonymous access function result: find the
9261          --  final list associated with the scope of the type. (In the
9262          --  anonymous access component kind, a list controller will have
9263          --  been allocated when freezing the record type, and PtrT has an
9264          --  Associated_Final_Chain attribute designating it.)
9265
9266          elsif No (Associated_Final_Chain (PtrT)) then
9267             Owner := Scope (PtrT);
9268          end if;
9269       end if;
9270
9271       return Find_Final_List (Owner);
9272    end Get_Allocator_Final_List;
9273
9274    ---------------------------------
9275    -- Has_Inferable_Discriminants --
9276    ---------------------------------
9277
9278    function Has_Inferable_Discriminants (N : Node_Id) return Boolean is
9279
9280       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean;
9281       --  Determines whether the left-most prefix of a selected component is a
9282       --  formal parameter in a subprogram. Assumes N is a selected component.
9283
9284       --------------------------------
9285       -- Prefix_Is_Formal_Parameter --
9286       --------------------------------
9287
9288       function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is
9289          Sel_Comp : Node_Id := N;
9290
9291       begin
9292          --  Move to the left-most prefix by climbing up the tree
9293
9294          while Present (Parent (Sel_Comp))
9295            and then Nkind (Parent (Sel_Comp)) = N_Selected_Component
9296          loop
9297             Sel_Comp := Parent (Sel_Comp);
9298          end loop;
9299
9300          return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind;
9301       end Prefix_Is_Formal_Parameter;
9302
9303    --  Start of processing for Has_Inferable_Discriminants
9304
9305    begin
9306       --  For identifiers and indexed components, it is sufficient to have a
9307       --  constrained Unchecked_Union nominal subtype.
9308
9309       if Nkind_In (N, N_Identifier, N_Indexed_Component) then
9310          return Is_Unchecked_Union (Base_Type (Etype (N)))
9311                   and then
9312                 Is_Constrained (Etype (N));
9313
9314       --  For selected components, the subtype of the selector must be a
9315       --  constrained Unchecked_Union. If the component is subject to a
9316       --  per-object constraint, then the enclosing object must have inferable
9317       --  discriminants.
9318
9319       elsif Nkind (N) = N_Selected_Component then
9320          if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then
9321
9322             --  A small hack. If we have a per-object constrained selected
9323             --  component of a formal parameter, return True since we do not
9324             --  know the actual parameter association yet.
9325
9326             if Prefix_Is_Formal_Parameter (N) then
9327                return True;
9328             end if;
9329
9330             --  Otherwise, check the enclosing object and the selector
9331
9332             return Has_Inferable_Discriminants (Prefix (N))
9333                      and then
9334                    Has_Inferable_Discriminants (Selector_Name (N));
9335          end if;
9336
9337          --  The call to Has_Inferable_Discriminants will determine whether
9338          --  the selector has a constrained Unchecked_Union nominal type.
9339
9340          return Has_Inferable_Discriminants (Selector_Name (N));
9341
9342       --  A qualified expression has inferable discriminants if its subtype
9343       --  mark is a constrained Unchecked_Union subtype.
9344
9345       elsif Nkind (N) = N_Qualified_Expression then
9346          return Is_Unchecked_Union (Subtype_Mark (N))
9347                   and then
9348                 Is_Constrained (Subtype_Mark (N));
9349
9350       end if;
9351
9352       return False;
9353    end Has_Inferable_Discriminants;
9354
9355    -------------------------------
9356    -- Insert_Dereference_Action --
9357    -------------------------------
9358
9359    procedure Insert_Dereference_Action (N : Node_Id) is
9360       Loc  : constant Source_Ptr := Sloc (N);
9361       Typ  : constant Entity_Id  := Etype (N);
9362       Pool : constant Entity_Id  := Associated_Storage_Pool (Typ);
9363       Pnod : constant Node_Id    := Parent (N);
9364
9365       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean;
9366       --  Return true if type of P is derived from Checked_Pool;
9367
9368       -----------------------------
9369       -- Is_Checked_Storage_Pool --
9370       -----------------------------
9371
9372       function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean is
9373          T : Entity_Id;
9374
9375       begin
9376          if No (P) then
9377             return False;
9378          end if;
9379
9380          T := Etype (P);
9381          while T /= Etype (T) loop
9382             if Is_RTE (T, RE_Checked_Pool) then
9383                return True;
9384             else
9385                T := Etype (T);
9386             end if;
9387          end loop;
9388
9389          return False;
9390       end Is_Checked_Storage_Pool;
9391
9392    --  Start of processing for Insert_Dereference_Action
9393
9394    begin
9395       pragma Assert (Nkind (Pnod) = N_Explicit_Dereference);
9396
9397       if not (Is_Checked_Storage_Pool (Pool)
9398               and then Comes_From_Source (Original_Node (Pnod)))
9399       then
9400          return;
9401       end if;
9402
9403       Insert_Action (N,
9404         Make_Procedure_Call_Statement (Loc,
9405           Name => New_Reference_To (
9406             Find_Prim_Op (Etype (Pool), Name_Dereference), Loc),
9407
9408           Parameter_Associations => New_List (
9409
9410             --  Pool
9411
9412              New_Reference_To (Pool, Loc),
9413
9414             --  Storage_Address. We use the attribute Pool_Address, which uses
9415             --  the pointer itself to find the address of the object, and which
9416             --  handles unconstrained arrays properly by computing the address
9417             --  of the template. i.e. the correct address of the corresponding
9418             --  allocation.
9419
9420              Make_Attribute_Reference (Loc,
9421                Prefix         => Duplicate_Subexpr_Move_Checks (N),
9422                Attribute_Name => Name_Pool_Address),
9423
9424             --  Size_In_Storage_Elements
9425
9426              Make_Op_Divide (Loc,
9427                Left_Opnd  =>
9428                 Make_Attribute_Reference (Loc,
9429                   Prefix         =>
9430                     Make_Explicit_Dereference (Loc,
9431                       Duplicate_Subexpr_Move_Checks (N)),
9432                   Attribute_Name => Name_Size),
9433                Right_Opnd =>
9434                  Make_Integer_Literal (Loc, System_Storage_Unit)),
9435
9436             --  Alignment
9437
9438              Make_Attribute_Reference (Loc,
9439                Prefix         =>
9440                  Make_Explicit_Dereference (Loc,
9441                    Duplicate_Subexpr_Move_Checks (N)),
9442                Attribute_Name => Name_Alignment))));
9443
9444    exception
9445       when RE_Not_Available =>
9446          return;
9447    end Insert_Dereference_Action;
9448
9449    --------------------------------
9450    -- Integer_Promotion_Possible --
9451    --------------------------------
9452
9453    function Integer_Promotion_Possible (N : Node_Id) return Boolean is
9454       Operand           : constant Node_Id   := Expression (N);
9455       Operand_Type      : constant Entity_Id := Etype (Operand);
9456       Root_Operand_Type : constant Entity_Id := Root_Type (Operand_Type);
9457
9458    begin
9459       pragma Assert (Nkind (N) = N_Type_Conversion);
9460
9461       return
9462
9463            --  We only do the transformation for source constructs. We assume
9464            --  that the expander knows what it is doing when it generates code.
9465
9466            Comes_From_Source (N)
9467
9468            --  If the operand type is Short_Integer or Short_Short_Integer,
9469            --  then we will promote to Integer, which is available on all
9470            --  targets, and is sufficient to ensure no intermediate overflow.
9471            --  Furthermore it is likely to be as efficient or more efficient
9472            --  than using the smaller type for the computation so we do this
9473            --  unconditionally.
9474
9475            and then
9476              (Root_Operand_Type = Base_Type (Standard_Short_Integer)
9477                or else
9478               Root_Operand_Type = Base_Type (Standard_Short_Short_Integer))
9479
9480            --  Test for interesting operation, which includes addition,
9481            --  division, exponentiation, multiplication, subtraction, absolute
9482            --  value and unary negation. Unary "+" is omitted since it is a
9483            --  no-op and thus can't overflow.
9484
9485            and then Nkind_In (Operand, N_Op_Abs,
9486                                        N_Op_Add,
9487                                        N_Op_Divide,
9488                                        N_Op_Expon,
9489                                        N_Op_Minus,
9490                                        N_Op_Multiply,
9491                                        N_Op_Subtract);
9492    end Integer_Promotion_Possible;
9493
9494    ------------------------------
9495    -- Make_Array_Comparison_Op --
9496    ------------------------------
9497
9498    --  This is a hand-coded expansion of the following generic function:
9499
9500    --  generic
9501    --    type elem is  (<>);
9502    --    type index is (<>);
9503    --    type a is array (index range <>) of elem;
9504
9505    --  function Gnnn (X : a; Y: a) return boolean is
9506    --    J : index := Y'first;
9507
9508    --  begin
9509    --    if X'length = 0 then
9510    --       return false;
9511
9512    --    elsif Y'length = 0 then
9513    --       return true;
9514
9515    --    else
9516    --      for I in X'range loop
9517    --        if X (I) = Y (J) then
9518    --          if J = Y'last then
9519    --            exit;
9520    --          else
9521    --            J := index'succ (J);
9522    --          end if;
9523
9524    --        else
9525    --           return X (I) > Y (J);
9526    --        end if;
9527    --      end loop;
9528
9529    --      return X'length > Y'length;
9530    --    end if;
9531    --  end Gnnn;
9532
9533    --  Note that since we are essentially doing this expansion by hand, we
9534    --  do not need to generate an actual or formal generic part, just the
9535    --  instantiated function itself.
9536
9537    function Make_Array_Comparison_Op
9538      (Typ : Entity_Id;
9539       Nod : Node_Id) return Node_Id
9540    is
9541       Loc : constant Source_Ptr := Sloc (Nod);
9542
9543       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
9544       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
9545       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
9546       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
9547
9548       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
9549
9550       Loop_Statement : Node_Id;
9551       Loop_Body      : Node_Id;
9552       If_Stat        : Node_Id;
9553       Inner_If       : Node_Id;
9554       Final_Expr     : Node_Id;
9555       Func_Body      : Node_Id;
9556       Func_Name      : Entity_Id;
9557       Formals        : List_Id;
9558       Length1        : Node_Id;
9559       Length2        : Node_Id;
9560
9561    begin
9562       --  if J = Y'last then
9563       --     exit;
9564       --  else
9565       --     J := index'succ (J);
9566       --  end if;
9567
9568       Inner_If :=
9569         Make_Implicit_If_Statement (Nod,
9570           Condition =>
9571             Make_Op_Eq (Loc,
9572               Left_Opnd => New_Reference_To (J, Loc),
9573               Right_Opnd =>
9574                 Make_Attribute_Reference (Loc,
9575                   Prefix => New_Reference_To (Y, Loc),
9576                   Attribute_Name => Name_Last)),
9577
9578           Then_Statements => New_List (
9579                 Make_Exit_Statement (Loc)),
9580
9581           Else_Statements =>
9582             New_List (
9583               Make_Assignment_Statement (Loc,
9584                 Name => New_Reference_To (J, Loc),
9585                 Expression =>
9586                   Make_Attribute_Reference (Loc,
9587                     Prefix => New_Reference_To (Index, Loc),
9588                     Attribute_Name => Name_Succ,
9589                     Expressions => New_List (New_Reference_To (J, Loc))))));
9590
9591       --  if X (I) = Y (J) then
9592       --     if ... end if;
9593       --  else
9594       --     return X (I) > Y (J);
9595       --  end if;
9596
9597       Loop_Body :=
9598         Make_Implicit_If_Statement (Nod,
9599           Condition =>
9600             Make_Op_Eq (Loc,
9601               Left_Opnd =>
9602                 Make_Indexed_Component (Loc,
9603                   Prefix      => New_Reference_To (X, Loc),
9604                   Expressions => New_List (New_Reference_To (I, Loc))),
9605
9606               Right_Opnd =>
9607                 Make_Indexed_Component (Loc,
9608                   Prefix      => New_Reference_To (Y, Loc),
9609                   Expressions => New_List (New_Reference_To (J, Loc)))),
9610
9611           Then_Statements => New_List (Inner_If),
9612
9613           Else_Statements => New_List (
9614             Make_Simple_Return_Statement (Loc,
9615               Expression =>
9616                 Make_Op_Gt (Loc,
9617                   Left_Opnd =>
9618                     Make_Indexed_Component (Loc,
9619                       Prefix      => New_Reference_To (X, Loc),
9620                       Expressions => New_List (New_Reference_To (I, Loc))),
9621
9622                   Right_Opnd =>
9623                     Make_Indexed_Component (Loc,
9624                       Prefix      => New_Reference_To (Y, Loc),
9625                       Expressions => New_List (
9626                         New_Reference_To (J, Loc)))))));
9627
9628       --  for I in X'range loop
9629       --     if ... end if;
9630       --  end loop;
9631
9632       Loop_Statement :=
9633         Make_Implicit_Loop_Statement (Nod,
9634           Identifier => Empty,
9635
9636           Iteration_Scheme =>
9637             Make_Iteration_Scheme (Loc,
9638               Loop_Parameter_Specification =>
9639                 Make_Loop_Parameter_Specification (Loc,
9640                   Defining_Identifier => I,
9641                   Discrete_Subtype_Definition =>
9642                     Make_Attribute_Reference (Loc,
9643                       Prefix => New_Reference_To (X, Loc),
9644                       Attribute_Name => Name_Range))),
9645
9646           Statements => New_List (Loop_Body));
9647
9648       --    if X'length = 0 then
9649       --       return false;
9650       --    elsif Y'length = 0 then
9651       --       return true;
9652       --    else
9653       --      for ... loop ... end loop;
9654       --      return X'length > Y'length;
9655       --    end if;
9656
9657       Length1 :=
9658         Make_Attribute_Reference (Loc,
9659           Prefix => New_Reference_To (X, Loc),
9660           Attribute_Name => Name_Length);
9661
9662       Length2 :=
9663         Make_Attribute_Reference (Loc,
9664           Prefix => New_Reference_To (Y, Loc),
9665           Attribute_Name => Name_Length);
9666
9667       Final_Expr :=
9668         Make_Op_Gt (Loc,
9669           Left_Opnd  => Length1,
9670           Right_Opnd => Length2);
9671
9672       If_Stat :=
9673         Make_Implicit_If_Statement (Nod,
9674           Condition =>
9675             Make_Op_Eq (Loc,
9676               Left_Opnd =>
9677                 Make_Attribute_Reference (Loc,
9678                   Prefix => New_Reference_To (X, Loc),
9679                   Attribute_Name => Name_Length),
9680               Right_Opnd =>
9681                 Make_Integer_Literal (Loc, 0)),
9682
9683           Then_Statements =>
9684             New_List (
9685               Make_Simple_Return_Statement (Loc,
9686                 Expression => New_Reference_To (Standard_False, Loc))),
9687
9688           Elsif_Parts => New_List (
9689             Make_Elsif_Part (Loc,
9690               Condition =>
9691                 Make_Op_Eq (Loc,
9692                   Left_Opnd =>
9693                     Make_Attribute_Reference (Loc,
9694                       Prefix => New_Reference_To (Y, Loc),
9695                       Attribute_Name => Name_Length),
9696                   Right_Opnd =>
9697                     Make_Integer_Literal (Loc, 0)),
9698
9699               Then_Statements =>
9700                 New_List (
9701                   Make_Simple_Return_Statement (Loc,
9702                      Expression => New_Reference_To (Standard_True, Loc))))),
9703
9704           Else_Statements => New_List (
9705             Loop_Statement,
9706             Make_Simple_Return_Statement (Loc,
9707               Expression => Final_Expr)));
9708
9709       --  (X : a; Y: a)
9710
9711       Formals := New_List (
9712         Make_Parameter_Specification (Loc,
9713           Defining_Identifier => X,
9714           Parameter_Type      => New_Reference_To (Typ, Loc)),
9715
9716         Make_Parameter_Specification (Loc,
9717           Defining_Identifier => Y,
9718           Parameter_Type      => New_Reference_To (Typ, Loc)));
9719
9720       --  function Gnnn (...) return boolean is
9721       --    J : index := Y'first;
9722       --  begin
9723       --    if ... end if;
9724       --  end Gnnn;
9725
9726       Func_Name := Make_Temporary (Loc, 'G');
9727
9728       Func_Body :=
9729         Make_Subprogram_Body (Loc,
9730           Specification =>
9731             Make_Function_Specification (Loc,
9732               Defining_Unit_Name       => Func_Name,
9733               Parameter_Specifications => Formals,
9734               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
9735
9736           Declarations => New_List (
9737             Make_Object_Declaration (Loc,
9738               Defining_Identifier => J,
9739               Object_Definition   => New_Reference_To (Index, Loc),
9740               Expression =>
9741                 Make_Attribute_Reference (Loc,
9742                   Prefix => New_Reference_To (Y, Loc),
9743                   Attribute_Name => Name_First))),
9744
9745           Handled_Statement_Sequence =>
9746             Make_Handled_Sequence_Of_Statements (Loc,
9747               Statements => New_List (If_Stat)));
9748
9749       return Func_Body;
9750    end Make_Array_Comparison_Op;
9751
9752    ---------------------------
9753    -- Make_Boolean_Array_Op --
9754    ---------------------------
9755
9756    --  For logical operations on boolean arrays, expand in line the following,
9757    --  replacing 'and' with 'or' or 'xor' where needed:
9758
9759    --    function Annn (A : typ; B: typ) return typ is
9760    --       C : typ;
9761    --    begin
9762    --       for J in A'range loop
9763    --          C (J) := A (J) op B (J);
9764    --       end loop;
9765    --       return C;
9766    --    end Annn;
9767
9768    --  Here typ is the boolean array type
9769
9770    function Make_Boolean_Array_Op
9771      (Typ : Entity_Id;
9772       N   : Node_Id) return Node_Id
9773    is
9774       Loc : constant Source_Ptr := Sloc (N);
9775
9776       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
9777       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
9778       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
9779       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
9780
9781       A_J : Node_Id;
9782       B_J : Node_Id;
9783       C_J : Node_Id;
9784       Op  : Node_Id;
9785
9786       Formals        : List_Id;
9787       Func_Name      : Entity_Id;
9788       Func_Body      : Node_Id;
9789       Loop_Statement : Node_Id;
9790
9791    begin
9792       A_J :=
9793         Make_Indexed_Component (Loc,
9794           Prefix      => New_Reference_To (A, Loc),
9795           Expressions => New_List (New_Reference_To (J, Loc)));
9796
9797       B_J :=
9798         Make_Indexed_Component (Loc,
9799           Prefix      => New_Reference_To (B, Loc),
9800           Expressions => New_List (New_Reference_To (J, Loc)));
9801
9802       C_J :=
9803         Make_Indexed_Component (Loc,
9804           Prefix      => New_Reference_To (C, Loc),
9805           Expressions => New_List (New_Reference_To (J, Loc)));
9806
9807       if Nkind (N) = N_Op_And then
9808          Op :=
9809            Make_Op_And (Loc,
9810              Left_Opnd  => A_J,
9811              Right_Opnd => B_J);
9812
9813       elsif Nkind (N) = N_Op_Or then
9814          Op :=
9815            Make_Op_Or (Loc,
9816              Left_Opnd  => A_J,
9817              Right_Opnd => B_J);
9818
9819       else
9820          Op :=
9821            Make_Op_Xor (Loc,
9822              Left_Opnd  => A_J,
9823              Right_Opnd => B_J);
9824       end if;
9825
9826       Loop_Statement :=
9827         Make_Implicit_Loop_Statement (N,
9828           Identifier => Empty,
9829
9830           Iteration_Scheme =>
9831             Make_Iteration_Scheme (Loc,
9832               Loop_Parameter_Specification =>
9833                 Make_Loop_Parameter_Specification (Loc,
9834                   Defining_Identifier => J,
9835                   Discrete_Subtype_Definition =>
9836                     Make_Attribute_Reference (Loc,
9837                       Prefix => New_Reference_To (A, Loc),
9838                       Attribute_Name => Name_Range))),
9839
9840           Statements => New_List (
9841             Make_Assignment_Statement (Loc,
9842               Name       => C_J,
9843               Expression => Op)));
9844
9845       Formals := New_List (
9846         Make_Parameter_Specification (Loc,
9847           Defining_Identifier => A,
9848           Parameter_Type      => New_Reference_To (Typ, Loc)),
9849
9850         Make_Parameter_Specification (Loc,
9851           Defining_Identifier => B,
9852           Parameter_Type      => New_Reference_To (Typ, Loc)));
9853
9854       Func_Name := Make_Temporary (Loc, 'A');
9855       Set_Is_Inlined (Func_Name);
9856
9857       Func_Body :=
9858         Make_Subprogram_Body (Loc,
9859           Specification =>
9860             Make_Function_Specification (Loc,
9861               Defining_Unit_Name       => Func_Name,
9862               Parameter_Specifications => Formals,
9863               Result_Definition        => New_Reference_To (Typ, Loc)),
9864
9865           Declarations => New_List (
9866             Make_Object_Declaration (Loc,
9867               Defining_Identifier => C,
9868               Object_Definition   => New_Reference_To (Typ, Loc))),
9869
9870           Handled_Statement_Sequence =>
9871             Make_Handled_Sequence_Of_Statements (Loc,
9872               Statements => New_List (
9873                 Loop_Statement,
9874                 Make_Simple_Return_Statement (Loc,
9875                   Expression => New_Reference_To (C, Loc)))));
9876
9877       return Func_Body;
9878    end Make_Boolean_Array_Op;
9879
9880    ------------------------
9881    -- Rewrite_Comparison --
9882    ------------------------
9883
9884    procedure Rewrite_Comparison (N : Node_Id) is
9885       Warning_Generated : Boolean := False;
9886       --  Set to True if first pass with Assume_Valid generates a warning in
9887       --  which case we skip the second pass to avoid warning overloaded.
9888
9889       Result : Node_Id;
9890       --  Set to Standard_True or Standard_False
9891
9892    begin
9893       if Nkind (N) = N_Type_Conversion then
9894          Rewrite_Comparison (Expression (N));
9895          return;
9896
9897       elsif Nkind (N) not in N_Op_Compare then
9898          return;
9899       end if;
9900
9901       --  Now start looking at the comparison in detail. We potentially go
9902       --  through this loop twice. The first time, Assume_Valid is set False
9903       --  in the call to Compile_Time_Compare. If this call results in a
9904       --  clear result of always True or Always False, that's decisive and
9905       --  we are done. Otherwise we repeat the processing with Assume_Valid
9906       --  set to True to generate additional warnings. We can skip that step
9907       --  if Constant_Condition_Warnings is False.
9908
9909       for AV in False .. True loop
9910          declare
9911             Typ : constant Entity_Id := Etype (N);
9912             Op1 : constant Node_Id   := Left_Opnd (N);
9913             Op2 : constant Node_Id   := Right_Opnd (N);
9914
9915             Res : constant Compare_Result :=
9916                     Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
9917             --  Res indicates if compare outcome can be compile time determined
9918
9919             True_Result  : Boolean;
9920             False_Result : Boolean;
9921
9922          begin
9923             case N_Op_Compare (Nkind (N)) is
9924             when N_Op_Eq =>
9925                True_Result  := Res = EQ;
9926                False_Result := Res = LT or else Res = GT or else Res = NE;
9927
9928             when N_Op_Ge =>
9929                True_Result  := Res in Compare_GE;
9930                False_Result := Res = LT;
9931
9932                if Res = LE
9933                  and then Constant_Condition_Warnings
9934                  and then Comes_From_Source (Original_Node (N))
9935                  and then Nkind (Original_Node (N)) = N_Op_Ge
9936                  and then not In_Instance
9937                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
9938                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
9939                then
9940                   Error_Msg_N
9941                     ("can never be greater than, could replace by ""'=""?", N);
9942                   Warning_Generated := True;
9943                end if;
9944
9945             when N_Op_Gt =>
9946                True_Result  := Res = GT;
9947                False_Result := Res in Compare_LE;
9948
9949             when N_Op_Lt =>
9950                True_Result  := Res = LT;
9951                False_Result := Res in Compare_GE;
9952
9953             when N_Op_Le =>
9954                True_Result  := Res in Compare_LE;
9955                False_Result := Res = GT;
9956
9957                if Res = GE
9958                  and then Constant_Condition_Warnings
9959                  and then Comes_From_Source (Original_Node (N))
9960                  and then Nkind (Original_Node (N)) = N_Op_Le
9961                  and then not In_Instance
9962                  and then Is_Integer_Type (Etype (Left_Opnd (N)))
9963                  and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
9964                then
9965                   Error_Msg_N
9966                     ("can never be less than, could replace by ""'=""?", N);
9967                   Warning_Generated := True;
9968                end if;
9969
9970             when N_Op_Ne =>
9971                True_Result  := Res = NE or else Res = GT or else Res = LT;
9972                False_Result := Res = EQ;
9973             end case;
9974
9975             --  If this is the first iteration, then we actually convert the
9976             --  comparison into True or False, if the result is certain.
9977
9978             if AV = False then
9979                if True_Result or False_Result then
9980                   if True_Result then
9981                      Result := Standard_True;
9982                   else
9983                      Result := Standard_False;
9984                   end if;
9985
9986                   Rewrite (N,
9987                     Convert_To (Typ,
9988                       New_Occurrence_Of (Result, Sloc (N))));
9989                   Analyze_And_Resolve (N, Typ);
9990                   Warn_On_Known_Condition (N);
9991                   return;
9992                end if;
9993
9994             --  If this is the second iteration (AV = True), and the original
9995             --  node comes from source and we are not in an instance, then give
9996             --  a warning if we know result would be True or False. Note: we
9997             --  know Constant_Condition_Warnings is set if we get here.
9998
9999             elsif Comes_From_Source (Original_Node (N))
10000               and then not In_Instance
10001             then
10002                if True_Result then
10003                   Error_Msg_N
10004                     ("condition can only be False if invalid values present?",
10005                      N);
10006                elsif False_Result then
10007                   Error_Msg_N
10008                     ("condition can only be True if invalid values present?",
10009                      N);
10010                end if;
10011             end if;
10012          end;
10013
10014          --  Skip second iteration if not warning on constant conditions or
10015          --  if the first iteration already generated a warning of some kind or
10016          --  if we are in any case assuming all values are valid (so that the
10017          --  first iteration took care of the valid case).
10018
10019          exit when not Constant_Condition_Warnings;
10020          exit when Warning_Generated;
10021          exit when Assume_No_Invalid_Values;
10022       end loop;
10023    end Rewrite_Comparison;
10024
10025    ----------------------------
10026    -- Safe_In_Place_Array_Op --
10027    ----------------------------
10028
10029    function Safe_In_Place_Array_Op
10030      (Lhs : Node_Id;
10031       Op1 : Node_Id;
10032       Op2 : Node_Id) return Boolean
10033    is
10034       Target : Entity_Id;
10035
10036       function Is_Safe_Operand (Op : Node_Id) return Boolean;
10037       --  Operand is safe if it cannot overlap part of the target of the
10038       --  operation. If the operand and the target are identical, the operand
10039       --  is safe. The operand can be empty in the case of negation.
10040
10041       function Is_Unaliased (N : Node_Id) return Boolean;
10042       --  Check that N is a stand-alone entity
10043
10044       ------------------
10045       -- Is_Unaliased --
10046       ------------------
10047
10048       function Is_Unaliased (N : Node_Id) return Boolean is
10049       begin
10050          return
10051            Is_Entity_Name (N)
10052              and then No (Address_Clause (Entity (N)))
10053              and then No (Renamed_Object (Entity (N)));
10054       end Is_Unaliased;
10055
10056       ---------------------
10057       -- Is_Safe_Operand --
10058       ---------------------
10059
10060       function Is_Safe_Operand (Op : Node_Id) return Boolean is
10061       begin
10062          if No (Op) then
10063             return True;
10064
10065          elsif Is_Entity_Name (Op) then
10066             return Is_Unaliased (Op);
10067
10068          elsif Nkind_In (Op, N_Indexed_Component, N_Selected_Component) then
10069             return Is_Unaliased (Prefix (Op));
10070
10071          elsif Nkind (Op) = N_Slice then
10072             return
10073               Is_Unaliased (Prefix (Op))
10074                 and then Entity (Prefix (Op)) /= Target;
10075
10076          elsif Nkind (Op) = N_Op_Not then
10077             return Is_Safe_Operand (Right_Opnd (Op));
10078
10079          else
10080             return False;
10081          end if;
10082       end Is_Safe_Operand;
10083
10084    --  Start of processing for Is_Safe_In_Place_Array_Op
10085
10086    begin
10087       --  Skip this processing if the component size is different from system
10088       --  storage unit (since at least for NOT this would cause problems).
10089
10090       if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
10091          return False;
10092
10093       --  Cannot do in place stuff on VM_Target since cannot pass addresses
10094
10095       elsif VM_Target /= No_VM then
10096          return False;
10097
10098       --  Cannot do in place stuff if non-standard Boolean representation
10099
10100       elsif Has_Non_Standard_Rep (Component_Type (Etype (Lhs))) then
10101          return False;
10102
10103       elsif not Is_Unaliased (Lhs) then
10104          return False;
10105
10106       else
10107          Target := Entity (Lhs);
10108          return Is_Safe_Operand (Op1) and then Is_Safe_Operand (Op2);
10109       end if;
10110    end Safe_In_Place_Array_Op;
10111
10112    -----------------------
10113    -- Tagged_Membership --
10114    -----------------------
10115
10116    --  There are two different cases to consider depending on whether the right
10117    --  operand is a class-wide type or not. If not we just compare the actual
10118    --  tag of the left expr to the target type tag:
10119    --
10120    --     Left_Expr.Tag = Right_Type'Tag;
10121    --
10122    --  If it is a class-wide type we use the RT function CW_Membership which is
10123    --  usually implemented by looking in the ancestor tables contained in the
10124    --  dispatch table pointed by Left_Expr.Tag for Typ'Tag
10125
10126    --  Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
10127    --  function IW_Membership which is usually implemented by looking in the
10128    --  table of abstract interface types plus the ancestor table contained in
10129    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
10130
10131    procedure Tagged_Membership
10132      (N         : Node_Id;
10133       SCIL_Node : out Node_Id;
10134       Result    : out Node_Id)
10135    is
10136       Left  : constant Node_Id    := Left_Opnd  (N);
10137       Right : constant Node_Id    := Right_Opnd (N);
10138       Loc   : constant Source_Ptr := Sloc (N);
10139
10140       Left_Type  : Entity_Id;
10141       New_Node   : Node_Id;
10142       Right_Type : Entity_Id;
10143       Obj_Tag    : Node_Id;
10144
10145    begin
10146       SCIL_Node := Empty;
10147
10148       --  Handle entities from the limited view
10149
10150       Left_Type  := Available_View (Etype (Left));
10151       Right_Type := Available_View (Etype (Right));
10152
10153       if Is_Class_Wide_Type (Left_Type) then
10154          Left_Type := Root_Type (Left_Type);
10155       end if;
10156
10157       Obj_Tag :=
10158         Make_Selected_Component (Loc,
10159           Prefix        => Relocate_Node (Left),
10160           Selector_Name =>
10161             New_Reference_To (First_Tag_Component (Left_Type), Loc));
10162
10163       if Is_Class_Wide_Type (Right_Type) then
10164
10165          --  No need to issue a run-time check if we statically know that the
10166          --  result of this membership test is always true. For example,
10167          --  considering the following declarations:
10168
10169          --    type Iface is interface;
10170          --    type T     is tagged null record;
10171          --    type DT    is new T and Iface with null record;
10172
10173          --    Obj1 : T;
10174          --    Obj2 : DT;
10175
10176          --  These membership tests are always true:
10177
10178          --    Obj1 in T'Class
10179          --    Obj2 in T'Class;
10180          --    Obj2 in Iface'Class;
10181
10182          --  We do not need to handle cases where the membership is illegal.
10183          --  For example:
10184
10185          --    Obj1 in DT'Class;     --  Compile time error
10186          --    Obj1 in Iface'Class;  --  Compile time error
10187
10188          if not Is_Class_Wide_Type (Left_Type)
10189            and then (Is_Ancestor (Etype (Right_Type), Left_Type)
10190                        or else (Is_Interface (Etype (Right_Type))
10191                                  and then Interface_Present_In_Ancestor
10192                                            (Typ   => Left_Type,
10193                                             Iface => Etype (Right_Type))))
10194          then
10195             Result := New_Reference_To (Standard_True, Loc);
10196             return;
10197          end if;
10198
10199          --  Ada 2005 (AI-251): Class-wide applied to interfaces
10200
10201          if Is_Interface (Etype (Class_Wide_Type (Right_Type)))
10202
10203             --   Support to: "Iface_CW_Typ in Typ'Class"
10204
10205            or else Is_Interface (Left_Type)
10206          then
10207             --  Issue error if IW_Membership operation not available in a
10208             --  configurable run time setting.
10209
10210             if not RTE_Available (RE_IW_Membership) then
10211                Error_Msg_CRT
10212                  ("dynamic membership test on interface types", N);
10213                Result := Empty;
10214                return;
10215             end if;
10216
10217             Result :=
10218               Make_Function_Call (Loc,
10219                  Name => New_Occurrence_Of (RTE (RE_IW_Membership), Loc),
10220                  Parameter_Associations => New_List (
10221                    Make_Attribute_Reference (Loc,
10222                      Prefix => Obj_Tag,
10223                      Attribute_Name => Name_Address),
10224                    New_Reference_To (
10225                      Node (First_Elmt
10226                             (Access_Disp_Table (Root_Type (Right_Type)))),
10227                      Loc)));
10228
10229          --  Ada 95: Normal case
10230
10231          else
10232             Build_CW_Membership (Loc,
10233               Obj_Tag_Node => Obj_Tag,
10234               Typ_Tag_Node =>
10235                  New_Reference_To (
10236                    Node (First_Elmt
10237                           (Access_Disp_Table (Root_Type (Right_Type)))),
10238                    Loc),
10239               Related_Nod => N,
10240               New_Node    => New_Node);
10241
10242             --  Generate the SCIL node for this class-wide membership test.
10243             --  Done here because the previous call to Build_CW_Membership
10244             --  relocates Obj_Tag.
10245
10246             if Generate_SCIL then
10247                SCIL_Node := Make_SCIL_Membership_Test (Sloc (N));
10248                Set_SCIL_Entity (SCIL_Node, Etype (Right_Type));
10249                Set_SCIL_Tag_Value (SCIL_Node, Obj_Tag);
10250             end if;
10251
10252             Result := New_Node;
10253          end if;
10254
10255       --  Right_Type is not a class-wide type
10256
10257       else
10258          --  No need to check the tag of the object if Right_Typ is abstract
10259
10260          if Is_Abstract_Type (Right_Type) then
10261             Result := New_Reference_To (Standard_False, Loc);
10262
10263          else
10264             Result :=
10265               Make_Op_Eq (Loc,
10266                 Left_Opnd  => Obj_Tag,
10267                 Right_Opnd =>
10268                   New_Reference_To
10269                     (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
10270          end if;
10271       end if;
10272    end Tagged_Membership;
10273
10274    ------------------------------
10275    -- Unary_Op_Validity_Checks --
10276    ------------------------------
10277
10278    procedure Unary_Op_Validity_Checks (N : Node_Id) is
10279    begin
10280       if Validity_Checks_On and Validity_Check_Operands then
10281          Ensure_Valid (Right_Opnd (N));
10282       end if;
10283    end Unary_Op_Validity_Checks;
10284
10285 end Exp_Ch4;