home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / exp_ch4.adb < prev    next >
Text File  |  1996-09-28  |  116KB  |  3,371 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              E X P _ C H 4                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.203 $                            --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Atree;    use Atree;
  26. with Checks;   use Checks;
  27. with Einfo;    use Einfo;
  28. with Elists;   use Elists;
  29. with Exp_Ch3;  use Exp_Ch3;
  30. with Exp_Ch7;  use Exp_Ch7;
  31. with Exp_Ch9;  use Exp_Ch9;
  32. with Exp_Disp; use Exp_Disp;
  33. with Exp_Fixd; use Exp_Fixd;
  34. with Exp_Pakd; use Exp_Pakd;
  35. with Exp_TSS;  use Exp_TSS;
  36. with Exp_Util; use Exp_Util;
  37. with Freeze;   use Freeze;
  38. with Itypes;   use Itypes;
  39. with Nlists;   use Nlists;
  40. with Nmake;    use Nmake;
  41. with Opt;      use Opt;
  42. with Rtsfind;  use Rtsfind;
  43. with Sem;      use Sem;
  44. with Sem_Dist; use Sem_Dist;
  45. with Sem_Eval; use Sem_Eval;
  46. with Sem_Res;  use Sem_Res;
  47. with Sem_Type; use Sem_Type;
  48. with Sem_Util; use Sem_Util;
  49. with Sinfo;    use Sinfo;
  50. with Sinfo.CN; use Sinfo.CN;
  51. with Snames;   use Snames;
  52. with Stand;    use Stand;
  53. with Tbuild;   use Tbuild;
  54. with Ttypes;   use Ttypes;
  55. with Uintp;    use Uintp;
  56. with Urealp;   use Urealp;
  57.  
  58. package body Exp_Ch4 is
  59.  
  60.    ------------------------
  61.    --  Local Subprograms --
  62.    ------------------------
  63.  
  64.    function Expand_Array_Equality
  65.      (Loc : Source_Ptr; Typ : Entity_Id; Lhs, Rhs : Node_Id) return Node_Id;
  66.    --  Expand an array equality into an expression-action containing a local
  67.    --  function implementing this equality, and a call to it. Loc is the
  68.    --  location for the generated nodes. Typ is the type of the array, and
  69.    --  Lhs, Rhs are the array expressions to be compared.
  70.  
  71.    procedure Expand_Boolean_Operator (N : Node_Id);
  72.    --  Common expansion processing for Boolean operators (And, Or, Xor)
  73.    --  for the case of array type arguments.
  74.  
  75.    procedure Expand_Comparison_Operator (N : Node_Id);
  76.    --  This routine handles expansion of the comparison operators (N_Op_Lt,
  77.    --  N_Op_Le, N_Op_Gt, N_Op_Ge). The basic code for these operators is
  78.    --  similar, differing only in the details of the actual comparison
  79.    --  call that is made.
  80.  
  81.    function Expand_Composite_Equality
  82.      (Loc  : Source_Ptr;
  83.       Typ  : Entity_Id;
  84.       Lhs  : Node_Id;
  85.       Rhs  : Node_Id)
  86.       return Node_Id;
  87.    --  Local recursive function used to expand equality for nested
  88.    --  composite types. Used by Expand_Record_Equality, Expand_Array_Equality.
  89.  
  90.    procedure Expand_Concatenation (Node : Node_Id; Ops : List_Id);
  91.    --  This routine handles expansion of concatenation operations, where
  92.    --  N is the N_Op_Concat or N_Concat_Multiple node being expanded, and
  93.    --  Ops is the list of operands (at least two are present).
  94.  
  95.    procedure Expand_Zero_Divide_Check (N : Node_Id);
  96.    --  The node kind is N_Op_Divide, N_Op_Mod, or N_Op_Rem. The right operand
  97.    --  is replaced by an expression actions node that checks that the divisor
  98.    --  (right operand) is non-zero. Note that in the divide case, but not in
  99.    --  the other two cases, overflow can still occur with a non-zero divisor
  100.    --  as a result of dividing the largest negative number by minus one.
  101.  
  102.    function Make_Array_Comparison_Op
  103.      (Typ   : Entity_Id;
  104.       Loc   : Source_Ptr;
  105.       Equal : Boolean)
  106.       return  Node_Id;
  107.    --  Comparisons between arrays are expanded in line. This function
  108.    --  produces the body of the implementation of (a > b), or (a >= b), when
  109.    --  a and b are one-dimensional arrays of some discrete type. The original
  110.    --  node is then expanded into the appropriate call to this function.
  111.  
  112.    function Tagged_Membership (N : Node_Id) return Node_Id;
  113.    --  Construct the expression corresponding to the tagged membership test.
  114.    --  Deals with a second operand being (or not) a class-wide type.
  115.  
  116.    ---------------------------
  117.    -- Expand_Array_Equality --
  118.    ---------------------------
  119.  
  120.    --  Expand an equality function for multi-dimentionnal arrays. Here is
  121.    --  an example of such a function for Nb_Dimension = 2
  122.  
  123.    --  function Enn (A : arr; B : arr) return boolean is
  124.    --     J1 : integer := B'first (1);
  125.    --     J2 : integer := B'first (2);
  126.  
  127.    --  begin
  128.    --     if A'length (1) /= B'length (1) then
  129.    --        return false;
  130.    --     else
  131.    --        for I1 in A'first (1) .. A'last (1) loop
  132.    --           if A'length (2) /= B'length (2) then
  133.    --              return false;
  134.    --           else
  135.    --              for I2 in A'first (2) .. A'last (2) loop
  136.    --                 if A (I1, I2) /=  B (J1, J2) then
  137.    --                    return false;
  138.    --                 end if;
  139.    --                 J2 := Integer'succ (J2);
  140.    --              end loop;
  141.    --           end if;
  142.    --           J1 := Integer'succ (J1);
  143.    --        end loop;
  144.    --     end if;
  145.    --     return true;
  146.    --  end Enn;
  147.  
  148.    function Expand_Array_Equality
  149.      (Loc      : Source_Ptr;
  150.       Typ      : Entity_Id;
  151.       Lhs, Rhs : Node_Id)
  152.       return     Node_Id
  153.    is
  154.       Decls       : List_Id := New_List;
  155.       Index_List1 : List_Id := New_List;
  156.       Index_List2 : List_Id := New_List;
  157.       Index       : Entity_Id := First_Index (Typ);
  158.       Index_Type  : Entity_Id;
  159.       Formals     : List_Id;
  160.       Result      : Node_Id;
  161.       Stats       : Node_Id;
  162.       Func_Name   : Entity_Id;
  163.       Func_Body   : Node_Id;
  164.  
  165.       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
  166.       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
  167.  
  168.       function Component_Equality (Typ : Entity_Id) return Node_Id;
  169.       --  Create one statement to compare corresponding components, designated
  170.       --  by a full set of indices.
  171.  
  172.       function Loop_One_Dimension (N : Int) return Node_Id;
  173.       --  Loop over the n'th dimension of the arrays. The single statement
  174.       --  in the body of the loop is a loop over the next dimension, or
  175.       --  the comparison of corresponding components.
  176.  
  177.       ------------------------
  178.       -- Component_Equality --
  179.       ------------------------
  180.  
  181.       function Component_Equality (Typ : Entity_Id) return Node_Id is
  182.          Test : Node_Id;
  183.          L, R : Node_Id;
  184.  
  185.       begin
  186.          --  if a(i1...) /= b(j1...) then return false; end if;
  187.  
  188.          L :=
  189.            Make_Indexed_Component (Loc,
  190.              Prefix => Make_Identifier (Loc, Chars (A)),
  191.              Expressions => Index_List1);
  192.  
  193.          R :=
  194.            Make_Indexed_Component (Loc,
  195.              Prefix => Make_Identifier (Loc, Chars (B)),
  196.              Expressions => Index_List2);
  197.  
  198.          Test := Expand_Composite_Equality (Loc, Component_Type (Typ), L, R);
  199.  
  200.          return
  201.            Make_If_Statement (Loc,
  202.              Condition => Make_Op_Not (Loc, Right_Opnd => Test),
  203.              Then_Statements => New_List (
  204.                Make_Return_Statement (Loc,
  205.                  Expression => New_Occurrence_Of (Standard_False, Loc))));
  206.  
  207.       end Component_Equality;
  208.  
  209.       ------------------------
  210.       -- Loop_One_Dimension --
  211.       ------------------------
  212.  
  213.       function Loop_One_Dimension (N : Int) return Node_Id is
  214.          I : constant Entity_Id := Make_Defining_Identifier (Loc,
  215.                                                   New_Internal_Name ('I'));
  216.          J : constant Entity_Id := Make_Defining_Identifier (Loc,
  217.                                                   New_Internal_Name ('J'));
  218.          Stats : Node_Id;
  219.  
  220.       begin
  221.          if N > Number_Dimensions (Typ) then
  222.             return Component_Equality (Typ);
  223.  
  224.          else
  225.             --  Generate the following:
  226.  
  227.             --  j: index_type := b'first (n);
  228.             --  ...
  229.             --  if a'length (n) /= b'length (n) then
  230.             --    return false;
  231.             --  else
  232.             --     for i in a'range (n) loop
  233.             --        --  loop over remaining dimensions.
  234.             --        j := index_type'succ (j);
  235.             --     end loop;
  236.             --  end if;
  237.  
  238.             --  retrieve index type for current dimension.
  239.  
  240.             Index_Type := Base_Type (Etype (Index));
  241.             Append (New_Reference_To (I, Loc), Index_List1);
  242.             Append (New_Reference_To (J, Loc), Index_List2);
  243.  
  244.             --  Declare index for j as a local variable to the function.
  245.             --  Index i is a loop variable.
  246.  
  247.             Append_To (Decls,
  248.               Make_Object_Declaration (Loc,
  249.                 Defining_Identifier => J,
  250.                 Object_Definition   => New_Reference_To (Index_Type, Loc),
  251.                 Expression =>
  252.                   Make_Attribute_Reference (Loc,
  253.                     Prefix => New_Reference_To (B, Loc),
  254.                     Attribute_Name => Name_First,
  255.                     Expressions => New_List (
  256.                         Make_Integer_Literal (Loc, UI_From_Int (N))))));
  257.  
  258.             Stats :=
  259.               Make_If_Statement (Loc,
  260.                 Condition =>
  261.                   Make_Op_Ne (Loc,
  262.                     Left_Opnd =>
  263.                       Make_Attribute_Reference (Loc,
  264.                         Prefix => New_Reference_To (A, Loc),
  265.                         Attribute_Name => Name_Length,
  266.                         Expressions => New_List (
  267.                           Make_Integer_Literal (Loc, UI_From_Int (N)))),
  268.                     Right_Opnd =>
  269.                       Make_Attribute_Reference (Loc,
  270.                         Prefix => New_Reference_To (B, Loc),
  271.                         Attribute_Name => Name_Length,
  272.                         Expressions => New_List (
  273.                           Make_Integer_Literal (Loc, UI_From_Int (N))))),
  274.  
  275.                 Then_Statements => New_List (
  276.                   Make_Return_Statement (Loc,
  277.                     Expression => New_Occurrence_Of (Standard_False, Loc))),
  278.  
  279.                 Else_Statements => New_List (
  280.                   Make_Loop_Statement (Loc,
  281.                     Identifier => Empty,
  282.                     Iteration_Scheme =>
  283.                       Make_Iteration_Scheme (Loc,
  284.                         Loop_Parameter_Specification =>
  285.                           Make_Loop_Parameter_Specification (Loc,
  286.                             Defining_Identifier => I,
  287.                             Discrete_Subtype_Definition =>
  288.                               Make_Attribute_Reference (Loc,
  289.                                 Prefix => New_Reference_To (A, Loc),
  290.                                 Attribute_Name => Name_Range,
  291.                                 Expressions => New_List (
  292.                                   Make_Integer_Literal (Loc,
  293.                                     Intval => UI_From_Int (N)))))),
  294.  
  295.                     Statements => New_List (
  296.                       Loop_One_Dimension (N + 1),
  297.                       Make_Assignment_Statement (Loc,
  298.                         Name => New_Reference_To (J, Loc),
  299.                         Expression =>
  300.                           Make_Attribute_Reference (Loc,
  301.                             Prefix => New_Reference_To (Index_Type, Loc),
  302.                             Attribute_Name => Name_Succ,
  303.                             Expressions => New_List (
  304.                               New_Reference_To (J, Loc))))))));
  305.  
  306.             Index := Next_Index (Index);
  307.             return Stats;
  308.          end if;
  309.       end Loop_One_Dimension;
  310.  
  311.    ------------------------------------------
  312.    -- Processing for Expand_Array_Equality --
  313.    ------------------------------------------
  314.  
  315.    begin
  316.       Formals := New_List (
  317.         Make_Parameter_Specification (Loc,
  318.           Defining_Identifier => A,
  319.           Parameter_Type      => New_Reference_To (Typ, Loc)),
  320.  
  321.         Make_Parameter_Specification (Loc,
  322.           Defining_Identifier => B,
  323.           Parameter_Type      => New_Reference_To (Typ, Loc)));
  324.  
  325.       Func_Name := Make_Defining_Identifier (Loc,  New_Internal_Name ('E'));
  326.  
  327.       Stats := Loop_One_Dimension (1);
  328.  
  329.       Func_Body :=
  330.         Make_Subprogram_Body (Loc,
  331.           Specification =>
  332.             Make_Function_Specification (Loc,
  333.               Defining_Unit_Name       => Func_Name,
  334.               Parameter_Specifications => Formals,
  335.               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
  336.           Declarations               =>  Decls,
  337.           Handled_Statement_Sequence =>
  338.             Make_Handled_Sequence_Of_Statements (Loc,
  339.               Statements => New_List (
  340.                 Stats,
  341.                 Make_Return_Statement (Loc,
  342.                   Expression => New_Occurrence_Of (Standard_True, Loc)))));
  343.  
  344.          Set_Has_Completion (Func_Name, True);
  345.  
  346.          Result :=
  347.            Make_Expression_Actions (Loc,
  348.              Actions    => New_List (Func_Body),
  349.              Expression => Make_Function_Call (Loc,
  350.                Name => New_Reference_To (Func_Name, Loc),
  351.                Parameter_Associations => New_List (Lhs, Rhs)));
  352.  
  353.          return Result;
  354.    end Expand_Array_Equality;
  355.  
  356.    -----------------------------
  357.    -- Expand_Boolean_Operator --
  358.    -----------------------------
  359.  
  360.    --  Note that we first get the actual subtypes of the operands, since
  361.    --  we always want to deal with types that have bounds.
  362.  
  363.    procedure Expand_Boolean_Operator (N : Node_Id) is
  364.       Loc       : constant Source_Ptr := Sloc (N);
  365.       Typ       : constant Entity_Id  := Etype (N);
  366.       L         : constant Node_Id    := Convert_To_Actual_Subtype
  367.                                            (Left_Opnd (N));
  368.       R         : constant Node_Id    := Convert_To_Actual_Subtype
  369.                                            (Right_Opnd (N));
  370.       Func_Body : Node_Id;
  371.       Func_Name : Entity_Id;
  372.  
  373.    begin
  374.       Apply_Length_Check (R, Etype (L));
  375.  
  376.       if Is_Packed (Typ) then
  377.          Expand_Packed_Boolean_Operator (N);
  378.  
  379.       --  For the normal non-packed case, the expansion is to build a function
  380.       --  for carrying out the comparison (using Make_Boolean_Array_Op) and
  381.       --  then inserting it into the tree. The original operator node is then
  382.       --  rewritten as a call to this function.
  383.  
  384.       else
  385.          Func_Body := Make_Boolean_Array_Op (Etype (L), N);
  386.          Func_Name := Defining_Unit_Name (Specification (Func_Body));
  387.          Insert_Action (N, Func_Body);
  388.  
  389.          --  Now rewrite the expression with a call
  390.  
  391.          Rewrite_Substitute_Tree (N,
  392.            Make_Function_Call (Loc,
  393.              Name => New_Reference_To (Func_Name, Loc),
  394.              Parameter_Associations => New_List (L, R)));
  395.  
  396.          Analyze (N);
  397.          Resolve (N, Typ);
  398.       end if;
  399.    end Expand_Boolean_Operator;
  400.  
  401.    --------------------------------
  402.    -- Expand_Comparison_Operator --
  403.    --------------------------------
  404.  
  405.    --  Expansion is only required in the case of array types. The form of
  406.    --  the expansion is:
  407.  
  408.    --     [body for greater_nn; boolean_expression]
  409.  
  410.    --  The body is built by Make_Array_Comparison_Op, and the form of the
  411.    --  Boolean expression depends on the operator involved.
  412.  
  413.    procedure Expand_Comparison_Operator (N : Node_Id) is
  414.       Loc  : constant Source_Ptr := Sloc (N);
  415.       Op1  : Node_Id             := Left_Opnd (N);
  416.       Op2  : Node_Id             := Right_Opnd (N);
  417.       Typ1 : constant Node_Id    := Base_Type (Etype (Op1));
  418.  
  419.       Result    : Node_Id;
  420.       Expr      : Node_Id;
  421.       Func_Body : Node_Id;
  422.       Func_Name : Entity_Id;
  423.  
  424.    --   ??? can't Op1, Op2 be constants, aren't assignments to Op1, Op2
  425.    --   below redundant, if not why not? RBKD
  426.  
  427.    begin
  428.       if Is_Array_Type (Typ1) then
  429.  
  430.          --  For (a <= b) we convert to not (a > b)
  431.  
  432.          if Chars (N) = Name_Op_Le then
  433.             Rewrite_Substitute_Tree (N,
  434.               Make_Op_Not (Loc,
  435.                 Right_Opnd =>
  436.                    Make_Op_Gt (Loc,
  437.                     Left_Opnd  => Op1,
  438.                     Right_Opnd => Op2)));
  439.             Analyze (N);
  440.             Resolve (N, Standard_Boolean);
  441.             return;
  442.  
  443.          --  For < the Boolean expression is
  444.          --    greater__nn (op2, op1)
  445.  
  446.          elsif Chars (N) = Name_Op_Lt then
  447.             Func_Body := Make_Array_Comparison_Op (Typ1, Loc, False);
  448.             Op1  := Right_Opnd (N);
  449.             Op2  := Left_Opnd  (N);
  450.  
  451.          --  For (a >= b) we convert to not (a < b)
  452.          --    op1 = op2 or else greater__nn (op1, op2)
  453.  
  454.          elsif Chars (N) = Name_Op_Ge then
  455.             Rewrite_Substitute_Tree (N,
  456.               Make_Op_Not (Loc,
  457.                 Right_Opnd =>
  458.                   Make_Op_Lt (Loc,
  459.                     Left_Opnd => Op1,
  460.                     Right_Opnd => Op2)));
  461.             Analyze (N);
  462.             Resolve (N, Standard_Boolean);
  463.             return;
  464.  
  465.          --  For > the Boolean expression is
  466.          --    greater__nn (op1, op2)
  467.  
  468.          elsif Chars (N) = Name_Op_Gt then
  469.             Func_Body := Make_Array_Comparison_Op (Typ1, Loc, False);
  470.  
  471.          else
  472.             pragma Assert (False); null;
  473.          end if;
  474.  
  475.          Func_Name := Defining_Unit_Name (Specification (Func_Body));
  476.          Expr :=
  477.            Make_Function_Call (Loc,
  478.              Name => New_Reference_To (Func_Name, Loc),
  479.              Parameter_Associations => New_List (Op1, Op2));
  480.  
  481.          Result :=
  482.            Make_Expression_Actions (Loc,
  483.              Actions => New_List (Func_Body),
  484.              Expression => Expr);
  485.  
  486.          Rewrite_Substitute_Tree (N, Result);
  487.          Analyze (N);
  488.          Resolve (N, Standard_Boolean);
  489.       end if;
  490.  
  491.    end Expand_Comparison_Operator;
  492.  
  493.    -------------------------------
  494.    -- Expand_Composite_Equality --
  495.    -------------------------------
  496.  
  497.    --  This function is only called for comparing internal fields of composite
  498.    --  types when these fields are themselves composites. This is a special
  499.    --  case because it is not possible to respect normal Ada visibility rules.
  500.  
  501.    function Expand_Composite_Equality
  502.      (Loc  : Source_Ptr;
  503.       Typ  : Entity_Id;
  504.       Lhs  : Node_Id;
  505.       Rhs  : Node_Id)
  506.       return Node_Id
  507.    is
  508.       Full_Type : Entity_Id;
  509.       Prim      : Elmt_Id;
  510.    begin
  511.       if Is_Private_Type (Typ) then
  512.          Full_Type := Underlying_Type (Typ);
  513.       else
  514.          Full_Type := Typ;
  515.       end if;
  516.  
  517.       Full_Type := Base_Type (Full_Type);
  518.  
  519.       if Is_Array_Type (Full_Type) then
  520.  
  521.          if Is_Scalar_Type (Component_Type (Full_Type)) then
  522.             return Make_Op_Eq (Loc, Left_Opnd  => Lhs, Right_Opnd => Rhs);
  523.          else
  524.             return Expand_Array_Equality (Loc, Full_Type, Lhs, Rhs);
  525.          end if;
  526.  
  527.       elsif Is_Tagged_Type (Full_Type) then
  528.  
  529.          --  Call the primitive operation "=" of this type
  530.  
  531.          if Is_Class_Wide_Type (Full_Type) then
  532.             Full_Type := Root_Type (Full_Type);
  533.          end if;
  534.  
  535.          Prim := First_Elmt (Primitive_Operations (Full_Type));
  536.  
  537.          while Chars (Node (Prim)) /= Name_Op_Eq loop
  538.             Prim := Next_Elmt (Prim);
  539.             pragma Assert (Present (Prim));
  540.          end loop;
  541.  
  542.          return
  543.            Make_Function_Call (Loc,
  544.              Name => New_Reference_To (Node (Prim), Loc),
  545.              Parameter_Associations => New_List (Lhs, Rhs));
  546.  
  547.       elsif Is_Record_Type (Full_Type) then
  548.          return Expand_Record_Equality (Loc, Full_Type, Lhs, Rhs);
  549.       else
  550.          --  It can be a simple record or the full view of a scalar private
  551.  
  552.          return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
  553.       end if;
  554.    end Expand_Composite_Equality;
  555.  
  556.    --------------------------
  557.    -- Expand_Concatenation --
  558.    --------------------------
  559.  
  560.    --  We construct the following expression actions node, where Atyp is
  561.    --  the base type of the array involved and Ityp is the index type
  562.    --  of this array:
  563.  
  564.    --    [function Cnn (S1 : Atyp; S2 : Atyp; .. Sn : Atyp) return Atyp is
  565.    --        L : constant Ityp := S1'Length + S2'Length + ... Sn'Length;
  566.    --        R : Atyp (S1'First .. S1'First + L - 1)
  567.    --        P : Ityp := S1'First;
  568.    --
  569.    --     begin
  570.    --        R (P .. P + S1'Length - 1) := S1;
  571.    --        P := P + S1'Length;
  572.    --        R (P .. P + S2'Length - 1) := S2;
  573.    --        P := P + S2'Length;
  574.    --        ...
  575.    --        R (P .. P + Sn'Length - 1) := Sn;
  576.    --        P := P + Sn'Length;
  577.    --        return R;
  578.    --     end Cnn;
  579.    --
  580.    --     Cnn (operand1, operand2, ... operandn)]
  581.  
  582.    --  Note: the low bound is not quite right, to be fixed later ???
  583.  
  584.    procedure Expand_Concatenation (Node : Node_Id; Ops : List_Id) is
  585.       Loc   : constant Source_Ptr := Sloc (Node);
  586.       Atyp  : constant Entity_Id  := Base_Type (Etype (Node));
  587.       Ityp  : constant Entity_Id  := Etype (First_Index (Atyp));
  588.       N     : constant Nat        := List_Length (Ops);
  589.  
  590.       Op    : Node_Id;
  591.       Pspec : List_Id;
  592.       Lexpr : Node_Id;
  593.       Slist : List_Id;
  594.       Alist : List_Id;
  595.       Decls : List_Id;
  596.       Func  : Node_Id;
  597.  
  598.       function L return Node_Id;
  599.       --  Build reference to identifier l
  600.  
  601.       function Nam (J : Nat) return Name_Id;
  602.       --  Build reference to identifier Sn, where n is the value given
  603.  
  604.       function One return Node_Id;
  605.       --  Build integer literal one
  606.  
  607.       function P return Node_Id;
  608.       --  Build reference to identifier p
  609.  
  610.       function R return Node_Id;
  611.       --  Build referrnce to identifier r
  612.  
  613.       function S1first return Node_Id;
  614.       --  Build expression  S1'First
  615.  
  616.       function Slength (J : Nat) return Node_Id;
  617.       --  Build expression S1'Length
  618.  
  619.       function L return Node_Id is
  620.       begin
  621.          return Make_Identifier (Loc, Name_uL);
  622.       end L;
  623.  
  624.       function Nam (J : Nat) return Name_Id is
  625.       begin
  626.          return New_External_Name ('S', J);
  627.       end Nam;
  628.  
  629.       function One return Node_Id is
  630.       begin
  631.          return Make_Integer_Literal (Loc, Uint_1);
  632.       end One;
  633.  
  634.       function P return Node_Id is
  635.       begin
  636.          return Make_Identifier (Loc, Name_uP);
  637.       end P;
  638.  
  639.       function R return Node_Id is
  640.       begin
  641.          return Make_Identifier (Loc, Name_uR);
  642.       end R;
  643.  
  644.       function S1first return Node_Id is
  645.       begin
  646.          return
  647.            Make_Attribute_Reference (Loc,
  648.              Prefix => Make_Identifier (Loc, Nam (1)),
  649.              Attribute_Name => Name_First);
  650.       end S1first;
  651.  
  652.       function Slength (J : Nat) return Node_Id is
  653.       begin
  654.          return
  655.            Make_Attribute_Reference (Loc,
  656.              Prefix => Make_Identifier (Loc, Nam (J)),
  657.              Attribute_Name => Name_Length);
  658.       end Slength;
  659.  
  660.    --  Start of processing for Expand_Concatenation
  661.  
  662.    begin
  663.       --  Construct parameter specification list
  664.  
  665.       Pspec := New_List;
  666.  
  667.       for J in 1 .. N loop
  668.          Append_To (Pspec,
  669.            Make_Parameter_Specification (Loc,
  670.              Defining_Identifier => Make_Defining_Identifier (Loc, Nam (J)),
  671.              Parameter_Type => New_Reference_To (Atyp, Loc)));
  672.       end loop;
  673.  
  674.       --  Construct expression for total length of result
  675.  
  676.       Lexpr := Slength (1);
  677.  
  678.       for J in 2 .. N loop
  679.          Lexpr := Make_Op_Add (Loc, Lexpr, Slength (J));
  680.       end loop;
  681.  
  682.       --  Construct list of statements
  683.  
  684.       Slist := New_List;
  685.  
  686.       for J in 1 .. N loop
  687.          Append_To (Slist,
  688.            Make_Assignment_Statement (Loc,
  689.              Name =>
  690.                Make_Slice (Loc,
  691.                  Prefix => R,
  692.                  Discrete_Range =>
  693.                    Make_Range (Loc,
  694.                      Low_Bound => P,
  695.                      High_Bound =>
  696.                        Make_Op_Subtract (Loc,
  697.                          Left_Opnd  => Make_Op_Add (Loc, P, Slength (J)),
  698.                          Right_Opnd => One))),
  699.              Expression => Make_Identifier (Loc, Nam (J))));
  700.  
  701.          Append_To (Slist,
  702.            Make_Assignment_Statement (Loc,
  703.              Name       => P,
  704.              Expression => Make_Op_Add (Loc, P, Slength (J))));
  705.       end loop;
  706.  
  707.       Append_To (Slist, Make_Return_Statement (Loc, Expression => R));
  708.  
  709.       --  Construct list of arguments for the call
  710.  
  711.       Alist := New_List;
  712.       Op := First (Ops);
  713.  
  714.       for J in 1 .. N loop
  715.          Append_To (Alist, New_Copy (Op));
  716.          Op := Next (Op);
  717.       end loop;
  718.  
  719.       --  Construct the declarations for the function
  720.  
  721.       Decls := New_List (
  722.         Make_Object_Declaration (Loc,
  723.           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
  724.           Object_Definition   => New_Reference_To (Ityp, Loc),
  725.           Constant_Present    => True,
  726.           Expression          => Lexpr),
  727.  
  728.         Make_Object_Declaration (Loc,
  729.           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
  730.  
  731.           Object_Definition =>
  732.             Make_Subtype_Indication (Loc,
  733.               Subtype_Mark => New_Reference_To (Atyp, Loc),
  734.               Constraint =>
  735.                 Make_Index_Or_Discriminant_Constraint (Loc,
  736.                   Constraints => New_List (
  737.                     Make_Range (Loc,
  738.                       Low_Bound  => S1first,
  739.                       High_Bound =>
  740.                         Make_Op_Subtract (Loc,
  741.                           Left_Opnd => Make_Op_Add (Loc, S1first, L),
  742.                           Right_Opnd => One)))))),
  743.  
  744.         Make_Object_Declaration (Loc,
  745.           Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
  746.           Object_Definition   => New_Reference_To (Ityp, Loc),
  747.           Expression          => S1first));
  748.  
  749.       --  Now construct the expression actions node and do the replace
  750.  
  751.       Func := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
  752.  
  753.       Rewrite_Substitute_Tree (Node,
  754.         Make_Expression_Actions (Loc,
  755.           Actions => New_List (
  756.             Make_Subprogram_Body (Loc,
  757.               Specification =>
  758.                 Make_Function_Specification (Loc,
  759.                   Defining_Unit_Name       => Func,
  760.                   Parameter_Specifications => Pspec,
  761.                   Subtype_Mark => New_Reference_To (Atyp, Loc)),
  762.               Declarations => Decls,
  763.               Handled_Statement_Sequence =>
  764.                 Make_Handled_Sequence_Of_Statements (Loc, Slist))),
  765.           Expression =>
  766.             Make_Function_Call (Loc, New_Reference_To (Func, Loc), Alist)));
  767.  
  768.       Analyze (Node);
  769.       Resolve (Node, Atyp);
  770.       Set_Is_Inlined (Func);
  771.    end Expand_Concatenation;
  772.  
  773.    ------------------------
  774.    -- Expand_N_Allocator --
  775.    ------------------------
  776.  
  777.    --  If the allocator is for a type which requires initialization, and
  778.    --  there is no initial value (i.e. the operand is a subtype indication
  779.    --  rather than a qualifed expression), then we must generate a call to
  780.    --  the initialization routine. This is done using an expression actions
  781.    --  node:
  782.    --
  783.    --     [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
  784.    --
  785.    --  Here ptr_T is the pointer type for the allocator, and T is the
  786.    --  subtype of the allocator. A special case arises if the designated
  787.    --  type of the access type is a task or contains tasks. In this case
  788.    --  the call to Init (Temp.all ...) is replaced by code that ensures
  789.    --  that the tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
  790.    --  for details). In addition, if the type T is a task T, then the first
  791.    --  argument to Init must be converted to the task record type.
  792.  
  793.    procedure Expand_N_Allocator (N : Node_Id) is
  794.       PtrT  : constant Entity_Id  := Etype (N);
  795.       Loc   : constant Source_Ptr := Sloc (N);
  796.       Temp  : Entity_Id;
  797.       Node  : Node_Id;
  798.  
  799.    begin
  800.       --  RM E.2.3(22). We enforce that the expected type of an allocator
  801.       --  shall not be a remote access-to-class-wide-limited-private type
  802.  
  803.       Validate_Remote_Access_To_Class_Wide_Type (N);
  804.  
  805.       --  Set the Storage Pool
  806.  
  807.       Set_Storage_Pool (N, Associated_Storage_Pool (PtrT));
  808.  
  809.       if Present (Storage_Pool (N)) then
  810.          Set_Procedure_To_Call
  811.            (N, Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
  812.       end if;
  813.  
  814.       if Nkind (Expression (N)) = N_Qualified_Expression then
  815.          declare
  816.             Indic : constant Node_Id   := Subtype_Mark (Expression (N));
  817.             T     : constant Entity_Id := Entity (Indic);
  818.             Exp   : constant Node_Id   := Expression (Expression (N));
  819.  
  820.             Tag_Assign : Node_Id;
  821.  
  822.          begin
  823.             if Is_Tagged_Type (T) or else Controlled_Type (T) then
  824.  
  825.                --    Actions inserted before:
  826.                --              Temp : constant ptr_T := new T'(Expression);
  827.                --   <no CW>    Temp._tag := T'tag;
  828.                --   <CTRL>     Adjust (Finalizable (Temp.all));
  829.                --   <CTRL>     Attach_To_Final_List (Finalizable (Temp.all));
  830.  
  831.                --  We analyze by hand the new internal allocator to avoid
  832.                --  any recursion and inappropriate call to Initialize
  833.  
  834.                Remove_Side_Effects (Exp);
  835.                Temp :=
  836.                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
  837.  
  838.                --  For a class wide allocation generate the following code:
  839.  
  840.                --    type Equiv_Record is record ... end record;
  841.                --    implicit subtype CW is <Class_Wide_Subytpe>;
  842.                --    temp : PtrT := new CW'(CW!(expr));
  843.  
  844.                if Is_Class_Wide_Type (T) then
  845.                   Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
  846.  
  847.                   Set_Expression (Expression (N),
  848.                     Make_Unchecked_Type_Conversion (Loc,
  849.                       Subtype_Mark => New_Reference_To (Entity (Indic), Loc),
  850.                       Expression   => Exp));
  851.  
  852.                   Analyze (Expression (N));
  853.                   Resolve (Expression (N), Entity (Indic));
  854.                end if;
  855.  
  856.                Node := Relocate_Node (N);
  857.                Set_Analyzed (Node);
  858.                Insert_Action (N,
  859.                  Make_Object_Declaration (Loc,
  860.                    Defining_Identifier => Temp,
  861.                    Constant_Present    => True,
  862.                    Object_Definition   => New_Reference_To (PtrT, Loc),
  863.                    Expression          => Node));
  864.  
  865.                if Is_Tagged_Type (T)
  866.                  and then not Is_Class_Wide_Type (T)
  867.                then
  868.                   Tag_Assign :=
  869.                     Make_Assignment_Statement (Loc,
  870.                       Name =>
  871.                         Make_Selected_Component (Loc,
  872.                           Prefix => New_Reference_To (Temp, Loc),
  873.                           Selector_Name =>
  874.                             New_Reference_To (Tag_Component (T), Loc)),
  875.  
  876.                       Expression =>
  877.                         Make_Unchecked_Type_Conversion (Loc,
  878.                           Subtype_Mark =>
  879.                             New_Reference_To (RTE (RE_Tag), Loc),
  880.                           Expression =>
  881.                             New_Reference_To (Access_Disp_Table (T), Loc)));
  882.  
  883.                   --  The previous assignment has to be done in any case
  884.  
  885.                   Set_Assignment_OK (Name (Tag_Assign));
  886.                   Insert_Action (N, Tag_Assign);
  887.                end if;
  888.  
  889.                if Controlled_Type (T) then
  890.                   declare
  891.                      Flist  : Node_Id;
  892.                      Attach : Entity_Id;
  893.  
  894.                   begin
  895.  
  896.                      --  If it is an allocation on the secondary stack
  897.                      --  (i.e. a returned value of a function), the
  898.                      --  Finalization chain must come from the caller thru
  899.                      --  an implicit parameter. ??? not implemented yet ???
  900.                      --  for now the value is not attached.
  901.  
  902.                      if Associated_Storage_Pool (PtrT) = RTE (RE_SS_Pool) then
  903.                         Flist :=
  904.                           New_Reference_To (RTE (RE_Global_Final_List), Loc);
  905.                         Attach := Standard_False;
  906.                      else
  907.                         Flist := Find_Final_List (PtrT);
  908.                         Attach := Standard_True;
  909.                      end if;
  910.  
  911.                      Insert_Actions (N,
  912.                        Make_Adjust_Call (
  913.                          Ref         =>
  914.  
  915.                            --  An unchecked conversion is needed in the
  916.                            --  classwide case because the designated type
  917.                            --  can be an ancestor of the subtype mark of
  918.                            --  the allocator.
  919.  
  920.                            Make_Unchecked_Type_Conversion (Loc,
  921.                              Subtype_Mark => New_Reference_To (T, Loc),
  922.                              Expression   =>
  923.                                Make_Explicit_Dereference (Loc,
  924.                                  New_Reference_To (Temp, Loc))),
  925.  
  926.                          Typ         => T,
  927.                          Flist_Ref   => Flist,
  928.                          With_Attach => New_Reference_To (Attach, Loc)));
  929.                   end;
  930.                end if;
  931.  
  932.                Rewrite_Substitute_Tree (N, New_Reference_To (Temp, Loc));
  933.                Analyze (N);
  934.                Resolve (N, PtrT);
  935.             end if;
  936.          end;
  937.  
  938.       --  In this case, an initialization routine may be required
  939.  
  940.       else
  941.          declare
  942.             T     : constant Entity_Id  := Entity (Expression (N));
  943.             Init  : constant Entity_Id  := Base_Init_Proc (T);
  944.             Arg1  : Node_Id;
  945.             Args  : List_Id;
  946.             Discr : Elmt_Id;
  947.             Eact  : Node_Id;
  948.  
  949.          begin
  950.             --  If there is no initialization procedure, then the only case
  951.             --  where we need to do anything is if the designated type is
  952.             --  itself a pointer, in which case we must make sure that it
  953.             --  is initialized to null.
  954.  
  955.             if No (Init) then
  956.  
  957.                if Is_Access_Type (T)
  958.                  or else (Is_Private_Type (T)
  959.                            and then Present (Underlying_Type (T))
  960.                            and then Is_Access_Type (Underlying_Type (T)))
  961.                then
  962.                   Rewrite_Substitute_Tree (Expression (N),
  963.                     Make_Qualified_Expression (Loc,
  964.                     Subtype_Mark => New_Occurrence_Of (T, Loc),
  965.                     Expression => Make_Null (Loc)));
  966.  
  967.                   Set_Etype (Expression (Expression (N)), T);
  968.                   Set_Paren_Count (Expression (Expression (N)), 1);
  969.                   Expand_N_Allocator (N);
  970.  
  971.                else
  972.                   null;
  973.                end if;
  974.  
  975.             --  Else we have the case that definitely needs a call to
  976.             --  the initialization procedure.
  977.  
  978.             else
  979.                Node := N;
  980.                Temp :=
  981.                  Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
  982.  
  983.                --  Construct argument list for the initialization routine call
  984.                --  The CPP constructor needs the address directly
  985.  
  986.                if Is_CPP_Class (T) then
  987.                   Arg1 := New_Reference_To (Temp, Loc);
  988.  
  989.                else
  990.                   Arg1 :=
  991.                     Make_Explicit_Dereference (Loc,
  992.                       Prefix => New_Reference_To (Temp, Loc));
  993.  
  994.                   --  The initialization procedure expects a specific type.
  995.                   --  if the context is access to class wide, indicate that
  996.                   --  the object being allocated has the right specific type.
  997.  
  998.                   if Is_Class_Wide_Type (Designated_Type (PtrT)) then
  999.                      Arg1 :=
  1000.                        Make_Unchecked_Type_Conversion (Loc,
  1001.                         Subtype_Mark => New_Reference_To (T,  Loc),
  1002.                         Expression => Arg1);
  1003.                   end if;
  1004.                end if;
  1005.  
  1006.                --  If designated type is a concurrent type or if it is a
  1007.                --  private type whose definition is a concurrent type,
  1008.                --  the first argument in the Init routine has to be
  1009.                --  unchecked conversion to the corresponding record type.
  1010.  
  1011.                if Is_Concurrent_Type (T) then
  1012.                   Arg1 :=
  1013.                     Make_Unchecked_Type_Conversion (Loc,
  1014.                       Subtype_Mark =>
  1015.                         New_Reference_To (Corresponding_Record_Type (T), Loc),
  1016.                       Expression => Arg1);
  1017.  
  1018.                elsif Is_Private_Type (T)
  1019.                  and then Is_Concurrent_Type (Full_View (T))
  1020.                then
  1021.                   Arg1 :=
  1022.                     Make_Unchecked_Type_Conversion (Loc,
  1023.                       Subtype_Mark =>
  1024.                         New_Reference_To (
  1025.                           Corresponding_Record_Type (Full_View (T)), Loc),
  1026.                       Expression => Arg1);
  1027.                end if;
  1028.  
  1029.                Args := New_List (Arg1);
  1030.  
  1031.                --  For the task case, pass the Master_Id of the access type
  1032.                --  as the value of the _Master parameter, and _Chain as the
  1033.                --  value of the _Chain parameter (_Chain will be defined as
  1034.                --  part of the generated code for the allocator).
  1035.  
  1036.                if Has_Tasks (T) then
  1037.  
  1038.                   if No (Master_Id (PtrT)) then
  1039.  
  1040.                      --  The designated type was an incomplete type, and
  1041.                      --  the access type did not get expanded. Salvage
  1042.                      --  it now. This may be a more general problem.
  1043.  
  1044.                      Expand_N_Full_Type_Declaration (Parent (PtrT));
  1045.                   end if;
  1046.  
  1047.                   Append_To (Args, New_Reference_To (Master_Id (PtrT), Loc));
  1048.                   Append_To (Args, Make_Identifier (Loc, Name_uChain));
  1049.                end if;
  1050.  
  1051.                --  Add discriminants if discriminated type
  1052.  
  1053.                if Has_Discriminants (T) then
  1054.                   Discr := First_Elmt (Discriminant_Constraint (T));
  1055.  
  1056.                   while Present (Discr) loop
  1057.                      Append (New_Copy (Elists.Node (Discr)), Args);
  1058.                      Discr := Next_Elmt (Discr);
  1059.                   end loop;
  1060.                end if;
  1061.  
  1062.                --  We set the allocator as analyzed so that when we analyze the
  1063.                --  expression actions node, we do not get an unwanted recursive
  1064.                --  expansion of the allocator expression.
  1065.  
  1066.                Set_Analyzed (N, True);
  1067.  
  1068.                --  Now we can rewrite the allocator. First see if it is
  1069.                --  already in an expression actions node, which will often
  1070.                --  be the case, because this is how we handle the case of
  1071.                --  discriminants being present. If so, we can just modify
  1072.                --  that expression actions node that is there, otherwise
  1073.                --  we must create an expression actions node.
  1074.  
  1075.                Eact := Parent (N);
  1076.  
  1077.                if Nkind (Eact) = N_Expression_Actions
  1078.                  and then Expression (Eact) = N
  1079.                then
  1080.                   Node := N;
  1081.  
  1082.                else
  1083.                   Rewrite_Substitute_Tree (N,
  1084.                     Make_Expression_Actions (Loc,
  1085.                       Actions    => New_List,
  1086.                       Expression => Relocate_Node (N)));
  1087.  
  1088.                   Eact := N;
  1089.                   Node := Expression (N);
  1090.                end if;
  1091.  
  1092.                --  Now we modify the expression actions node as follows
  1093.  
  1094.                --    input:   [... ; new T]
  1095.  
  1096.                --    output:  [... ;
  1097.                --              Temp : constant ptr_T := new (T);
  1098.                --              Init (Temp.all, ...);
  1099.                --      <CTRL>  Attach_To_Final_List (Finalizable (Temp.all));
  1100.                --      <CTRL>  Initialize (Finalizable (Temp.all));
  1101.                --              Temp]
  1102.  
  1103.                --  Here ptr_T is the pointer type for the allocator, and T
  1104.                --  is the subtype of the allocator.
  1105.  
  1106.                Append_To (Actions (Eact),
  1107.                  Make_Object_Declaration (Loc,
  1108.                    Defining_Identifier => Temp,
  1109.                    Constant_Present    => True,
  1110.                    Object_Definition   => New_Reference_To (PtrT, Loc),
  1111.                    Expression          => Node));
  1112.  
  1113.                --  Case of designated type is task or contains task
  1114.  
  1115.                if Has_Tasks (T) then
  1116.                   Build_Task_Allocate_Block (Actions (Eact), Node, Args);
  1117.  
  1118.                else
  1119.                   Append_To (Actions (Eact),
  1120.                     Make_Procedure_Call_Statement (Loc,
  1121.                       Name => New_Reference_To (Init, Loc),
  1122.                       Parameter_Associations => Args));
  1123.                end if;
  1124.  
  1125.                if Controlled_Type (T) then
  1126.                   Append_List_To (Actions (Eact),
  1127.                     Make_Init_Call (
  1128.                       Ref       => New_Copy_Tree (Arg1),
  1129.                       Typ       => T,
  1130.                       Flist_Ref => Find_Final_List (PtrT)));
  1131.                end if;
  1132.  
  1133.                Set_Expression (Eact, New_Reference_To (Temp, Loc));
  1134.                Analyze (Eact);
  1135.  
  1136.             end if;
  1137.          end;
  1138.       end if;
  1139.    end Expand_N_Allocator;
  1140.  
  1141.    -----------------------
  1142.    -- Expand_N_And_Then --
  1143.    -----------------------
  1144.  
  1145.    --  Expand into conditional expression if Actions present
  1146.  
  1147.    procedure Expand_N_And_Then (N : Node_Id) is
  1148.       Loc     : constant Source_Ptr := Sloc (N);
  1149.       Typ     : constant Entity_Id  := Etype (N);
  1150.       Actlist : List_Id;
  1151.  
  1152.    begin
  1153.       --  If Actions are present, we expand
  1154.  
  1155.       --     left and then right
  1156.  
  1157.       --  into
  1158.  
  1159.       --     if left then right else false end
  1160.  
  1161.       --  with the actions becoming the Then_Actions of the conditional
  1162.       --  expression. This conditional expression is then further expanded
  1163.       --  (and will eventually disappear)
  1164.  
  1165.       if Present (Actions (N)) then
  1166.          Actlist := Actions (N);
  1167.          Rewrite_Substitute_Tree (N,
  1168.             Make_Conditional_Expression (Loc,
  1169.               Expressions => New_List (
  1170.                 Left_Opnd (N),
  1171.                 Right_Opnd (N),
  1172.                 New_Occurrence_Of (Standard_False, Loc))));
  1173.  
  1174.          Set_Then_Actions (N, Actlist);
  1175.          Analyze (N);
  1176.          Resolve (N, Typ);
  1177.       end if;
  1178.    end Expand_N_And_Then;
  1179.  
  1180.    ------------------------------
  1181.    -- Expand_N_Concat_Multiple --
  1182.    ------------------------------
  1183.  
  1184.    procedure Expand_N_Concat_Multiple (N : Node_Id) is
  1185.    begin
  1186.       Expand_Concatenation (N, Expressions (N));
  1187.    end Expand_N_Concat_Multiple;
  1188.  
  1189.    -------------------------------------
  1190.    -- Expand_N_Conditional_Expression --
  1191.    -------------------------------------
  1192.  
  1193.    --  Expand into expression actions if then/else actions present
  1194.  
  1195.    procedure Expand_N_Conditional_Expression (N : Node_Id) is
  1196.       Loc    : constant Source_Ptr := Sloc (N);
  1197.       Cond   : constant Node_Id    := First (Expressions (N));
  1198.       Thenx  : constant Node_Id    := Next (Cond);
  1199.       Elsex  : constant Node_Id    := Next (Thenx);
  1200.       Typ    : constant Entity_Id  := Etype (N);
  1201.       Cnn    : Entity_Id;
  1202.       New_If : Node_Id;
  1203.  
  1204.    begin
  1205.       --  If either then or else actions are present, then given:
  1206.  
  1207.       --     if cond then then-expr else else-expr end
  1208.  
  1209.       --  we insert the following sequence of actions (using Insert_Actions):
  1210.  
  1211.       --      Cnn : typ;
  1212.       --      if cond then
  1213.       --         <<then actions>>
  1214.       --         Cnn := then-expr;
  1215.       --      else
  1216.       --         <<else actions>>
  1217.       --         Cnn := else-expr
  1218.       --      end if;
  1219.  
  1220.       --  and replace the conditional expression by a reference to Cnn.
  1221.  
  1222.       if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
  1223.          Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
  1224.  
  1225.          New_If :=
  1226.            Make_If_Statement (Loc,
  1227.              Condition => Relocate_Node (Cond),
  1228.  
  1229.              Then_Statements => New_List (
  1230.                Make_Assignment_Statement (Sloc (Thenx),
  1231.                  Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
  1232.                  Expression => Relocate_Node (Thenx))),
  1233.  
  1234.              Else_Statements => New_List (
  1235.                Make_Assignment_Statement (Sloc (Elsex),
  1236.                  Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
  1237.                  Expression => Relocate_Node (Elsex))));
  1238.  
  1239.          if Present (Then_Actions (N)) then
  1240.             Insert_List_Before
  1241.               (First (Then_Statements (New_If)), Then_Actions (N));
  1242.          end if;
  1243.  
  1244.          if Present (Else_Actions (N)) then
  1245.             Insert_List_Before
  1246.               (First (Else_Statements (New_If)), Else_Actions (N));
  1247.          end if;
  1248.  
  1249.          Rewrite_Substitute_Tree (N, New_Occurrence_Of (Cnn, Loc));
  1250.  
  1251.          Insert_Action (N,
  1252.            Make_Object_Declaration (Loc,
  1253.              Defining_Identifier => Cnn,
  1254.              Object_Definition   => New_Occurrence_Of (Typ, Loc)));
  1255.  
  1256.          Insert_Action (N, New_If);
  1257.  
  1258.          Analyze (N);
  1259.          Resolve (N, Typ);
  1260.       end if;
  1261.    end Expand_N_Conditional_Expression;
  1262.  
  1263.    -----------------
  1264.    -- Expand_N_In --
  1265.    -----------------
  1266.  
  1267.    procedure Expand_N_In (N : Node_Id) is
  1268.       Loc   : constant Source_Ptr := Sloc (N);
  1269.       Typ   : constant Entity_Id  := Etype (N);
  1270.  
  1271.    begin
  1272.       --  No expansion is required if we have an explicit range
  1273.  
  1274.       if Nkind (Right_Opnd (N)) = N_Range then
  1275.          return;
  1276.  
  1277.       --  Here right operand is a subtype mark
  1278.  
  1279.       else
  1280.          declare
  1281.             Subt : constant Entity_Id := Etype (Right_Opnd (N));
  1282.  
  1283.          begin
  1284.             --  For tagged type, do tagged membership operation
  1285.  
  1286.             if Is_Tagged_Type (Subt) then
  1287.                Rewrite_Substitute_Tree (N, Tagged_Membership (N));
  1288.                Analyze (N);
  1289.                Resolve (N, Typ);
  1290.  
  1291.             --  If type is its own base type, result is always true
  1292.  
  1293.             elsif Base_Type (Subt) = Subt then
  1294.                Rewrite_Substitute_Tree (N,
  1295.                  New_Reference_To (Standard_True, Loc));
  1296.                Analyze (N);
  1297.                Resolve (N, Typ);
  1298.  
  1299.             --  If type is scalar type, rewrite as x in t'first .. t'last
  1300.             --  This reason we do this is that the bounds may have the wrong
  1301.             --  type if they come from the original type definition.
  1302.  
  1303.             elsif Is_Scalar_Type (Subt) then
  1304.                Rewrite_Substitute_Tree (Right_Opnd (N),
  1305.                  Make_Range (Loc,
  1306.                    Low_Bound =>
  1307.                      Make_Attribute_Reference (Loc,
  1308.                        Attribute_Name => Name_First,
  1309.                        Prefix => New_Reference_To (Subt, Loc)),
  1310.  
  1311.                    High_Bound =>
  1312.                      Make_Attribute_Reference (Loc,
  1313.                        Attribute_Name => Name_Last,
  1314.                        Prefix => New_Reference_To (Subt, Loc))));
  1315.                Analyze (N);
  1316.                Resolve (N, Typ);
  1317.             end if;
  1318.          end;
  1319.       end if;
  1320.    end Expand_N_In;
  1321.  
  1322.    --------------------------------
  1323.    -- Expand_N_Indexed_Component --
  1324.    --------------------------------
  1325.  
  1326.    --  The only case we deal with is indexing a packed array, where we
  1327.    --  convert the reference to a reference to the apropriate bits in the
  1328.    --  object of the corresponding Packed_Array_Type. This processing is
  1329.    --  done only for a reference, not for an assignment left hand side,
  1330.    --  which is handled directly in Expand_N_Assignment.
  1331.  
  1332.    procedure Expand_N_Indexed_Component (N : Node_Id) is
  1333.    begin
  1334.       Apply_Subscript_Conversion_Checks (N);
  1335.       if Is_Packed (Etype (Prefix (N)))
  1336.         and then (Nkind (Parent (N)) /= N_Assignment_Statement
  1337.                    or else Name (Parent (N)) /= N)
  1338.       then
  1339.          Expand_Packed_Element_Get (N);
  1340.       end if;
  1341.    end Expand_N_Indexed_Component;
  1342.  
  1343.    ---------------------
  1344.    -- Expand_N_Not_In --
  1345.    ---------------------
  1346.  
  1347.    --  Replace a not in b by not (a in b) so that the expansions for (a in b)
  1348.    --  can be done. This avoids needing to duplicate this expansion code.
  1349.  
  1350.    procedure Expand_N_Not_In (N : Node_Id) is
  1351.       Loc  : constant Source_Ptr := Sloc (N);
  1352.       Typ  : constant Entity_Id  := Etype (N);
  1353.  
  1354.    begin
  1355.       Rewrite_Substitute_Tree (N,
  1356.         Make_Op_Not (Loc,
  1357.           Right_Opnd =>
  1358.             Make_In (Loc,
  1359.               Left_Opnd  => Left_Opnd (N),
  1360.               Right_Opnd => Right_Opnd (N))));
  1361.       Analyze (N);
  1362.       Resolve (N, Typ);
  1363.    end Expand_N_Not_In;
  1364.  
  1365.    ---------------------
  1366.    -- Expand_N_Op_Abs --
  1367.    ---------------------
  1368.  
  1369.    procedure Expand_N_Op_Abs (N : Node_Id) is
  1370.       Loc        : constant Source_Ptr := Sloc (N);
  1371.       Expr       : Multi_Use.Exp_Id;
  1372.       Added_Code : List_Id;
  1373.  
  1374.    begin
  1375.       if Software_Overflow_Checking
  1376.          and then Is_Signed_Integer_Type (Etype (N))
  1377.          and then Do_Overflow_Check (N)
  1378.       then
  1379.          --  Software overflow checking expands abs (expr) into
  1380.  
  1381.          --    (if expr >= 0 then expr else -expr)
  1382.  
  1383.          --  with the usual multiple use coding for expr
  1384.  
  1385.          Multi_Use.Prepare (Right_Opnd (N), Expr, Added_Code);
  1386.  
  1387.          Rewrite_Substitute_Tree (N,
  1388.            Multi_Use.Wrap (Added_Code,
  1389.              Make_Conditional_Expression (Loc,
  1390.                Expressions => New_List (
  1391.                  Make_Op_Ge (Loc,
  1392.                    Left_Opnd  => Multi_Use.New_Ref (Expr),
  1393.                    Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
  1394.  
  1395.                  Multi_Use.New_Ref (Expr),
  1396.  
  1397.                  Make_Op_Minus (Loc,
  1398.                    Right_Opnd  => Multi_Use.New_Ref (Expr))))));
  1399.  
  1400.          Analyze (N);
  1401.          Resolve (N, Etype (N));
  1402.       end if;
  1403.    end Expand_N_Op_Abs;
  1404.  
  1405.    ---------------------
  1406.    -- Expand_N_Op_Add --
  1407.    ---------------------
  1408.  
  1409.    procedure Expand_N_Op_Add (N : Node_Id) is
  1410.    begin
  1411.       if Software_Overflow_Checking
  1412.          and then Is_Signed_Integer_Type (Etype (N))
  1413.          and then Do_Overflow_Check (N)
  1414.       then
  1415.          Apply_Arithmetic_Overflow_Check (N);
  1416.       end if;
  1417.    end Expand_N_Op_Add;
  1418.  
  1419.    ---------------------
  1420.    -- Expand_N_Op_And --
  1421.    ---------------------
  1422.  
  1423.    procedure Expand_N_Op_And (N : Node_Id) is
  1424.    begin
  1425.       if Is_Array_Type (Etype (N)) then
  1426.          Expand_Boolean_Operator (N);
  1427.       end if;
  1428.    end Expand_N_Op_And;
  1429.  
  1430.    ------------------------
  1431.    -- Expand_N_Op_Concat --
  1432.    ------------------------
  1433.  
  1434.    procedure Expand_N_Op_Concat (N : Node_Id) is
  1435.       Loc      : constant Source_Ptr := Sloc (N);
  1436.       Lhs      : Node_Id   := Left_Opnd (N);
  1437.       Rhs      : Node_Id   := Right_Opnd (N);
  1438.       Ltyp     : Entity_Id := Base_Type (Etype (Lhs));
  1439.       Rtyp     : Entity_Id := Base_Type (Etype (Rhs));
  1440.       Comp_Typ : Entity_Id := Base_Type (Component_Type (Etype (N)));
  1441.  
  1442.    begin
  1443.       --  If left operand is a single component, replace by an aggregate
  1444.       --  of the form (1 => operand), as required by concatenation semantics.
  1445.  
  1446.       if Ltyp = Comp_Typ then
  1447.          Lhs :=
  1448.            Make_Aggregate (Loc,
  1449.              Component_Associations => New_List (
  1450.                Make_Component_Association (Loc,
  1451.                  Choices    => New_List (Make_Integer_Literal (Loc, Uint_1)),
  1452.                  Expression => Relocate_Node (Lhs))));
  1453.          Ltyp := Base_Type (Etype (N));
  1454.       end if;
  1455.  
  1456.       --  Similar handling for right operand
  1457.  
  1458.       if Rtyp = Comp_Typ then
  1459.          Rhs :=
  1460.            Make_Aggregate (Loc,
  1461.              Component_Associations => New_List (
  1462.                Make_Component_Association (Loc,
  1463.                  Choices    => New_List (Make_Integer_Literal (Loc, Uint_1)),
  1464.                  Expression => Relocate_Node (Rhs))));
  1465.          Rtyp := Base_Type (Etype (N));
  1466.       end if;
  1467.  
  1468.       --  Handle case of concatenating Standard.String with runtime call
  1469.  
  1470.       if Ltyp = Standard_String and then Rtyp = Standard_String then
  1471.          Rewrite_Substitute_Tree (N,
  1472.            Make_Function_Call (Loc,
  1473.              Name => New_Reference_To (RTE (RE_Str_Concat), Loc),
  1474.              Parameter_Associations => New_List (Lhs, Rhs)));
  1475.  
  1476.          Analyze (N);
  1477.          Resolve (N, Standard_String);
  1478.  
  1479.       --  For other than Standard.String, use general routine
  1480.  
  1481.       else
  1482.          Expand_Concatenation (N, New_List (Lhs, Rhs));
  1483.       end if;
  1484.  
  1485.    end Expand_N_Op_Concat;
  1486.  
  1487.    ------------------------
  1488.    -- Expand_N_Op_Divide --
  1489.    ------------------------
  1490.  
  1491.    procedure Expand_N_Op_Divide (N : Node_Id) is
  1492.       Typ  : constant Entity_Id := Etype (N);
  1493.       Ltyp : constant Entity_Id := Etype (Left_Opnd (N));
  1494.       Rtyp : constant Entity_Id := Etype (Right_Opnd (N));
  1495.  
  1496.    begin
  1497.       --  Do nothing if result type is universal fixed, this means that
  1498.       --  the node above us is a conversion node or a 'Round attribute
  1499.       --  reference, and we will build and expand the properly typed
  1500.       --  division node when we expand the parent node.
  1501.  
  1502.       if Typ = Universal_Fixed then
  1503.          return;
  1504.  
  1505.       --  Divisions with other fixed-point results. Note that we exclude
  1506.       --  the case where Treat_Fixed_As_Integer is set, since from a
  1507.       --  semantic point of view, these are just integer divisions.
  1508.  
  1509.       elsif Is_Fixed_Point_Type (Typ)
  1510.         and then not Treat_Fixed_As_Integer (N)
  1511.       then
  1512.          if Is_Integer_Type (Rtyp) then
  1513.             Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
  1514.          else
  1515.             Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
  1516.          end if;
  1517.  
  1518.       --  Other cases of division of fixed-point operands. Again we exclude
  1519.       --  the case where Treat_Fixed_As_Integer is set.
  1520.  
  1521.       elsif (Is_Fixed_Point_Type (Ltyp) or else
  1522.              Is_Fixed_Point_Type (Rtyp))
  1523.         and then not Treat_Fixed_As_Integer (N)
  1524.       then
  1525.          if Is_Integer_Type (Typ) then
  1526.             Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
  1527.          else
  1528.             pragma Assert (Is_Floating_Point_Type (Typ));
  1529.             Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
  1530.          end if;
  1531.  
  1532.       --  Non-fixed point cases, check for software overflow checking
  1533.  
  1534.       elsif Software_Overflow_Checking
  1535.          and then Is_Integer_Type (Typ)
  1536.          and then Do_Overflow_Check (N)
  1537.       then
  1538.          Expand_Zero_Divide_Check (N);
  1539.  
  1540.          if Is_Signed_Integer_Type (Etype (N)) then
  1541.             Apply_Arithmetic_Overflow_Check (N);
  1542.          end if;
  1543.       end if;
  1544.    end Expand_N_Op_Divide;
  1545.  
  1546.    --------------------
  1547.    -- Expand_N_Op_Eq --
  1548.    --------------------
  1549.  
  1550.    procedure Expand_N_Op_Eq (N : Node_Id) is
  1551.       Loc     : constant Source_Ptr := Sloc (N);
  1552.       Lhs     : constant Node_Id    := Left_Opnd (N);
  1553.       Rhs     : constant Node_Id    := Right_Opnd (N);
  1554.       Typl    : Entity_Id  := Etype (Lhs);
  1555.  
  1556.    begin
  1557.       if Ekind (Typl) = E_Private_Type then
  1558.          Typl := Underlying_Type (Typl);
  1559.       end if;
  1560.  
  1561.       Typl := Base_Type (Typl);
  1562.  
  1563.       if  Is_Array_Type (Typl) then
  1564.  
  1565.          if Is_Scalar_Type (Component_Type (Typl)) then
  1566.  
  1567.             --  The case of two constrained arrays can be left to Gigi
  1568.  
  1569.             if Nkind (Lhs) /= N_Expression_Actions
  1570.               and then Nkind (Rhs) /= N_Expression_Actions
  1571.             then
  1572.                null;
  1573.  
  1574.             --  Kludge to avoid a bug in Gigi (works only for Strings) ???
  1575.  
  1576.             elsif Typl = Standard_String then
  1577.                Rewrite_Substitute_Tree (N,
  1578.                  Make_Function_Call (Loc,
  1579.                    Name => New_Reference_To (RTE (RE_Str_Equal), Loc),
  1580.                    Parameter_Associations =>
  1581.                      New_List (New_Copy (Lhs), New_Copy (Rhs))));
  1582.  
  1583.                Analyze (N);
  1584.                Resolve (N, Standard_Boolean);
  1585.  
  1586.             --  Other cases, we hope Gigi will not blow up ???
  1587.  
  1588.             else
  1589.                null;
  1590.             end if;
  1591.          else
  1592.             Rewrite_Substitute_Tree (N,
  1593.               Expand_Array_Equality
  1594.                 (Loc, Typl, New_Copy (Lhs), New_Copy (Rhs)));
  1595.  
  1596.             Analyze (N);
  1597.             Resolve (N, Standard_Boolean);
  1598.          end if;
  1599.  
  1600.       elsif Is_Record_Type (Typl) then
  1601.  
  1602.          --  For tagged types, use the primitive "="
  1603.  
  1604.          if Is_Tagged_Type (Typl) then
  1605.             Rewrite_Substitute_Tree (N,
  1606.               Make_Function_Call (Loc,
  1607.                 Name =>
  1608.                   New_Reference_To (Find_Prim_Op (Typl, Name_Op_Eq), Loc),
  1609.  
  1610.                 Parameter_Associations => New_List (
  1611.                   Node1 => Relocate_Node (Lhs),
  1612.                   Node2 =>
  1613.                     Make_Unchecked_Type_Conversion (Loc,
  1614.                       Subtype_Mark => New_Reference_To (Etype (Lhs), Loc),
  1615.                       Expression   => Relocate_Node (Rhs)))));
  1616.  
  1617.             Analyze (N);
  1618.             Resolve (N, Standard_Boolean);
  1619.  
  1620.          --  If a type support function is present (for complex cases), use it
  1621.  
  1622.          elsif Present (TSS (Typl, Name_uEquality)) then
  1623.  
  1624.             Rewrite_Substitute_Tree (N,
  1625.               Make_Function_Call (Loc,
  1626.                 Name => New_Reference_To (TSS (Typl, Name_uEquality), Loc),
  1627.  
  1628.                 Parameter_Associations => New_List (
  1629.                   Node1 => Relocate_Node (Lhs),
  1630.                   Node2 => Relocate_Node (Rhs))));
  1631.  
  1632.             Analyze (N);
  1633.             Resolve (N, Standard_Boolean);
  1634.  
  1635.          --  Otherwise expand the component by component equality
  1636.  
  1637.          else
  1638.             declare
  1639.                use Multi_Use;
  1640.  
  1641.                Actions : constant List_Id := New_List;
  1642.                L       : Exp_Id;
  1643.                R       : Exp_Id;
  1644.  
  1645.             begin
  1646.                Multi_Use.New_Exp_Id (Lhs, Actions, L);
  1647.                Multi_Use.New_Exp_Id (Rhs, Actions, R);
  1648.  
  1649.                if Is_Empty_List (Actions) then
  1650.                   Rewrite_Substitute_Tree (N,
  1651.                     Expand_Record_Equality (Loc, Typl,
  1652.                       Multi_Use.New_Ref (L), Multi_Use.New_Ref (R)));
  1653.                else
  1654.                   Rewrite_Substitute_Tree (N,
  1655.                     Make_Expression_Actions (Loc,
  1656.                        Actions    => Actions,
  1657.                        Expression =>
  1658.                          Expand_Record_Equality (Loc, Typl,
  1659.                            Multi_Use.New_Ref (L),
  1660.                            Multi_Use.New_Ref (R))));
  1661.                end if;
  1662.  
  1663.                Analyze (N);
  1664.                Resolve (N, Standard_Boolean);
  1665.             end;
  1666.          end if;
  1667.       end if;
  1668.  
  1669.    end Expand_N_Op_Eq;
  1670.  
  1671.    -----------------------
  1672.    -- Expand_N_Op_Expon --
  1673.    -----------------------
  1674.  
  1675.    procedure Expand_N_Op_Expon (N : Node_Id) is
  1676.       Loc    : constant Source_Ptr := Sloc (N);
  1677.       Typ    : constant Entity_Id  := Etype (N);
  1678.       Btyp   : constant Entity_Id  := Root_Type (Typ);
  1679.       Max    : constant Uint       := Uint_4;
  1680.       Min    : constant Uint       := Uint_Minus_4;
  1681.       Base   : constant Node_Id    := New_Copy (Left_Opnd (N));
  1682.       Exp    : constant Node_Id    := New_Copy (Right_Opnd (N));
  1683.       Ovflo  : constant Boolean    := Do_Overflow_Check (N);
  1684.       Expv   : Uint;
  1685.       Xnode  : Node_Id;
  1686.       Temp   : Node_Id;
  1687.       Rent   : RE_Id;
  1688.       Ent    : Entity_Id;
  1689.       E_Base : Multi_Use.Exp_Id;
  1690.  
  1691.       Added_Code : List_Id;
  1692.  
  1693.    begin
  1694.       --  At this point the exponentiation must be dynamic since the static
  1695.       --  case has already been folded after Resolve by Eval_Op_Expon.
  1696.  
  1697.       --  Test for case of literal right argument
  1698.  
  1699.       if Nkind (Exp) = N_Integer_Literal then
  1700.          Expv := Intval (Exp);
  1701.  
  1702.          if (Ekind (Typ) in Float_Kind
  1703.                and then Expv >= Min
  1704.                and then Expv <= Max)
  1705.            or else
  1706.             (Ekind (Typ) in Integer_Kind
  1707.                and then Expv >= 0
  1708.                and then Expv <= Max)
  1709.          then
  1710.             Expv := abs Expv;
  1711.  
  1712.             --  X ** 0 = 1 (or 1.0)
  1713.  
  1714.             if Expv = 0 then
  1715.                if Ekind (Typ) in Integer_Kind then
  1716.                   Xnode := Make_Integer_Literal (Loc, Intval => Uint_1);
  1717.                else
  1718.                   Xnode := Make_Real_Literal (Loc, Ureal_1);
  1719.                end if;
  1720.  
  1721.             --  X ** 1 = X
  1722.  
  1723.             elsif Expv = 1 then
  1724.                Xnode := Base;
  1725.  
  1726.             --  X ** 2 = X * X
  1727.  
  1728.             elsif Expv = 2 then
  1729.                Multi_Use.Prepare (Base, E_Base, Added_Code);
  1730.                Xnode := Multi_Use.Wrap (Added_Code,
  1731.                  Make_Op_Multiply (Loc,
  1732.                    Left_Opnd  => Multi_Use.New_Ref (E_Base),
  1733.                    Right_Opnd => Multi_Use.New_Ref (E_Base)));
  1734.  
  1735.             --  X ** 3 = X * X * X
  1736.  
  1737.             elsif Expv = 3 then
  1738.                Multi_Use.Prepare (Base, E_Base, Added_Code);
  1739.                Xnode := Multi_Use.Wrap (Added_Code,
  1740.                  Make_Op_Multiply (Loc,
  1741.                    Left_Opnd =>
  1742.                      Make_Op_Multiply (Loc,
  1743.                        Left_Opnd  => Multi_Use.New_Ref (E_Base),
  1744.                        Right_Opnd => Multi_Use.New_Ref (E_Base)),
  1745.                    Right_Opnd  => Multi_Use.New_Ref (E_Base)));
  1746.  
  1747.             --  X ** 4  -> [Xn : constant base'type := base * base; Xn * Xn]
  1748.  
  1749.             elsif Expv = 4 then
  1750.                Multi_Use.Prepare (Base, E_Base, Added_Code);
  1751.                Temp :=
  1752.                  Make_Defining_Identifier (Loc, New_Internal_Name ('X'));
  1753.  
  1754.                Xnode :=
  1755.                  Make_Expression_Actions (Loc,
  1756.                    Actions => New_List (
  1757.                      Make_Object_Declaration (Loc,
  1758.                        Defining_Identifier => Temp,
  1759.                        Constant_Present    => True,
  1760.                        Object_Definition   => New_Reference_To (Typ, Loc),
  1761.                        Expression =>
  1762.                          Make_Op_Multiply (Loc,
  1763.                            Left_Opnd  => Multi_Use.New_Ref (E_Base),
  1764.                            Right_Opnd => Multi_Use.New_Ref (E_Base)))),
  1765.                    Expression =>
  1766.                      Make_Op_Multiply (Loc,
  1767.                        Left_Opnd  => New_Reference_To (Temp, Loc),
  1768.                        Right_Opnd => New_Reference_To (Temp, Loc)));
  1769.  
  1770.                if Present (Added_Code) then
  1771.                   Append_List (Actions (Xnode), Added_Code);
  1772.                   Set_Actions (Xnode, Added_Code);
  1773.                end if;
  1774.             end if;
  1775.  
  1776.             --  For non-negative case, we are all set
  1777.  
  1778.             if Intval (Exp) >= 0 then
  1779.                Rewrite_Substitute_Tree (N, Xnode);
  1780.  
  1781.             --  For negative cases, take reciprocal (base must be real)
  1782.  
  1783.             else
  1784.                Set_Paren_Count (Xnode, 1);
  1785.                Rewrite_Substitute_Tree (N,
  1786.                  Make_Op_Divide (Loc,
  1787.                    Left_Opnd   => Make_Real_Literal (Loc, Ureal_1),
  1788.                    Right_Opnd  => Xnode));
  1789.             end if;
  1790.  
  1791.             Analyze (N);
  1792.             Resolve (N, Typ);
  1793.             return;
  1794.  
  1795.          --  Don't fold cases of large literal exponents, and also don't fold
  1796.          --  cases of integer bases with negative literal exponents.
  1797.  
  1798.          end if;
  1799.  
  1800.       --  Don't fold cases where exponent is not integer literal
  1801.  
  1802.       end if;
  1803.  
  1804.       --  Fall through if exponentiation must be done using a runtime routine
  1805.       --  First deal with modular case.
  1806.  
  1807.       if Is_Modular_Integer_Type (Btyp) then
  1808.  
  1809.          --  Non-binary case, we call the special exponentiation routine for
  1810.          --  the non-binary case, converting the argument to Long_Long_Integer
  1811.          --  and passing the modulus value. Then the result is converted back
  1812.          --  to the base type.
  1813.  
  1814.          if Non_Binary_Modulus (Btyp) then
  1815.  
  1816.             Rewrite_Substitute_Tree (N,
  1817.               Make_Type_Conversion (Loc,
  1818.                 Subtype_Mark => New_Reference_To (Typ, Loc),
  1819.                 Expression   =>
  1820.                   Make_Function_Call (Loc,
  1821.                     Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
  1822.                     Parameter_Associations => New_List (
  1823.                       Make_Type_Conversion (Loc,
  1824.                         Subtype_Mark =>
  1825.                           New_Reference_To (Standard_Integer, Loc),
  1826.                         Expression => Base),
  1827.                       Make_Integer_Literal (Loc, Modulus (Btyp)),
  1828.                       Exp))));
  1829.  
  1830.          --  Binary case, in this case, we call one of two routines, either
  1831.          --  the unsigned integer case, or the unsigned long long integer
  1832.          --  case, with the final conversion doing the required truncation.
  1833.  
  1834.          else
  1835.             if UI_To_Int (Esize (Btyp)) <= Standard_Integer_Size then
  1836.                Ent := RTE (RE_Exp_Unsigned);
  1837.             else
  1838.                Ent := RTE (RE_Exp_Long_Long_Unsigned);
  1839.             end if;
  1840.  
  1841.             Rewrite_Substitute_Tree (N,
  1842.               Make_Type_Conversion (Loc,
  1843.                 Subtype_Mark => New_Reference_To (Typ, Loc),
  1844.                 Expression   =>
  1845.                   Make_Function_Call (Loc,
  1846.                     Name => New_Reference_To (Ent, Loc),
  1847.                     Parameter_Associations => New_List (
  1848.                       Make_Type_Conversion (Loc,
  1849.                         Subtype_Mark =>
  1850.                           New_Reference_To (Etype (First_Formal (Ent)), Loc),
  1851.                         Expression   => Base),
  1852.                       Exp))));
  1853.          end if;
  1854.  
  1855.          --  Common exit point for modular type case
  1856.  
  1857.          Analyze (N);
  1858.          Resolve (N, Typ);
  1859.          return;
  1860.  
  1861.       --  Signed integer cases
  1862.  
  1863.       elsif Btyp = Standard_Integer then
  1864.          if Ovflo then
  1865.             Rent := RE_Exp_Integer;
  1866.          else
  1867.             Rent := RE_Exn_Integer;
  1868.          end if;
  1869.  
  1870.       elsif Btyp = Standard_Short_Integer then
  1871.          if Ovflo then
  1872.             Rent := RE_Exp_Short_Integer;
  1873.          else
  1874.             Rent := RE_Exn_Short_Integer;
  1875.          end if;
  1876.  
  1877.       elsif Btyp = Standard_Short_Short_Integer then
  1878.          if Ovflo then
  1879.             Rent := RE_Exp_Short_Short_Integer;
  1880.          else
  1881.             Rent := RE_Exn_Short_Short_Integer;
  1882.          end if;
  1883.  
  1884.       elsif Btyp = Standard_Long_Integer then
  1885.          if Ovflo then
  1886.             Rent := RE_Exp_Long_Integer;
  1887.          else
  1888.             Rent := RE_Exn_Long_Integer;
  1889.          end if;
  1890.  
  1891.       elsif (Btyp = Standard_Long_Long_Integer
  1892.         or else Btyp = Universal_Integer)
  1893.       then
  1894.          if Ovflo then
  1895.             Rent := RE_Exp_Long_Long_Integer;
  1896.          else
  1897.             Rent := RE_Exn_Long_Long_Integer;
  1898.          end if;
  1899.  
  1900.       --  Floating-point cases
  1901.  
  1902.       elsif Btyp = Standard_Float then
  1903.          if Ovflo then
  1904.             Rent := RE_Exp_Float;
  1905.          else
  1906.             Rent := RE_Exn_Float;
  1907.          end if;
  1908.  
  1909.       elsif Btyp = Standard_Short_Float then
  1910.          if Ovflo then
  1911.             Rent := RE_Exp_Short_Float;
  1912.          else
  1913.             Rent := RE_Exn_Short_Float;
  1914.          end if;
  1915.  
  1916.       elsif Btyp = Standard_Long_Float then
  1917.          if Ovflo then
  1918.             Rent := RE_Exp_Long_Float;
  1919.          else
  1920.             Rent := RE_Exn_Long_Float;
  1921.          end if;
  1922.  
  1923.       elsif Btyp = Standard_Long_Long_Float
  1924.         or else Btyp = Universal_Real
  1925.       then
  1926.          if Ovflo then
  1927.             Rent := RE_Exp_Long_Long_Float;
  1928.          else
  1929.             Rent := RE_Exn_Long_Long_Float;
  1930.          end if;
  1931.  
  1932.       else
  1933.          pragma Assert (False); null;
  1934.       end if;
  1935.  
  1936.       --  Common processing for integer cases and floating-point cases.
  1937.       --  If we are in the base type, we can call runtime routine directly
  1938.  
  1939.       if Typ = Btyp
  1940.         and then Btyp /= Universal_Integer
  1941.         and then Btyp /= Universal_Real
  1942.       then
  1943.          Rewrite_Substitute_Tree (N,
  1944.            Make_Function_Call (Loc,
  1945.              Name => New_Reference_To (RTE (Rent), Loc),
  1946.              Parameter_Associations => New_List (Base, Exp)));
  1947.  
  1948.       --  Otherwise we have to introduce conversions (conversions are also
  1949.       --  required in the universal cases, since the runtime routine was
  1950.       --  typed using the largest integer or real case.
  1951.  
  1952.       else
  1953.          Rewrite_Substitute_Tree (N,
  1954.            Make_Type_Conversion (Loc,
  1955.              Subtype_Mark => New_Reference_To (Typ, Loc),
  1956.              Expression   =>
  1957.                Make_Function_Call (Loc,
  1958.                  Name => New_Reference_To (RTE (Rent), Loc),
  1959.                  Parameter_Associations => New_List (
  1960.                    Make_Type_Conversion (Loc,
  1961.                      Subtype_Mark => New_Reference_To (Btyp, Loc),
  1962.                      Expression   => Base),
  1963.                    Exp))));
  1964.       end if;
  1965.  
  1966.       Analyze (N);
  1967.       Resolve (N, Typ);
  1968.       return;
  1969.  
  1970.    end Expand_N_Op_Expon;
  1971.  
  1972.    --------------------
  1973.    -- Expand_N_Op_Ge --
  1974.    --------------------
  1975.  
  1976.    procedure Expand_N_Op_Ge (N : Node_Id) is
  1977.    begin
  1978.       Expand_Comparison_Operator (N);
  1979.    end Expand_N_Op_Ge;
  1980.  
  1981.    --------------------
  1982.    -- Expand_N_Op_Gt --
  1983.    --------------------
  1984.  
  1985.    procedure Expand_N_Op_Gt (N : Node_Id) is
  1986.    begin
  1987.       Expand_Comparison_Operator (N);
  1988.    end Expand_N_Op_Gt;
  1989.  
  1990.    --------------------
  1991.    -- Expand_N_Op_Le --
  1992.    --------------------
  1993.  
  1994.    procedure Expand_N_Op_Le (N : Node_Id) is
  1995.    begin
  1996.       Expand_Comparison_Operator (N);
  1997.    end Expand_N_Op_Le;
  1998.  
  1999.    --------------------
  2000.    -- Expand_N_Op_Lt --
  2001.    --------------------
  2002.  
  2003.    procedure Expand_N_Op_Lt (N : Node_Id) is
  2004.    begin
  2005.       Expand_Comparison_Operator (N);
  2006.    end Expand_N_Op_Lt;
  2007.  
  2008.    -----------------------
  2009.    -- Expand_N_Op_Minus --
  2010.    -----------------------
  2011.  
  2012.    procedure Expand_N_Op_Minus (N : Node_Id) is
  2013.       Loc : constant Source_Ptr := Sloc (N);
  2014.       Typ : constant Entity_Id  := Etype (N);
  2015.  
  2016.    begin
  2017.       if Software_Overflow_Checking
  2018.          and then Is_Signed_Integer_Type (Etype (N))
  2019.          and then Do_Overflow_Check (N)
  2020.       then
  2021.          --  Software overflow checking expands -expr into (0 - expr)
  2022.  
  2023.          Rewrite_Substitute_Tree (N,
  2024.            Make_Op_Subtract (Loc,
  2025.              Left_Opnd  => Make_Integer_Literal (Loc, Uint_0),
  2026.              Right_Opnd => Right_Opnd (N)));
  2027.  
  2028.          Analyze (N);
  2029.          Resolve (N, Typ);
  2030.       end if;
  2031.    end Expand_N_Op_Minus;
  2032.  
  2033.    ---------------------
  2034.    -- Expand_N_Op_Mod --
  2035.    ---------------------
  2036.  
  2037.    procedure Expand_N_Op_Mod (N : Node_Id) is
  2038.    begin
  2039.       if Software_Overflow_Checking
  2040.          and then Is_Integer_Type (Etype (N))
  2041.          and then Do_Overflow_Check (N)
  2042.       then
  2043.          Expand_Zero_Divide_Check (N);
  2044.       end if;
  2045.    end Expand_N_Op_Mod;
  2046.  
  2047.    --------------------------
  2048.    -- Expand_N_Op_Multiply --
  2049.    --------------------------
  2050.  
  2051.    procedure Expand_N_Op_Multiply (N : Node_Id) is
  2052.       Typ  : constant Entity_Id  := Etype (N);
  2053.       Ltyp : constant Entity_Id  := Etype (Left_Opnd (N));
  2054.       Rtyp : constant Entity_Id  := Etype (Right_Opnd (N));
  2055.  
  2056.    begin
  2057.       --  Do nothing if result type is universal fixed, this means that
  2058.       --  the node above us is a conversion node or a 'Round attribute
  2059.       --  reference, and we will build and expand the properly typed
  2060.       --  multiplication node when we expand the parent node.
  2061.  
  2062.       if Typ = Universal_Fixed then
  2063.          return;
  2064.  
  2065.       --  Multiplications with other fixed-point results. Note that we
  2066.       --  exclude the cases where Treat_Fixed_As_Integer is set, since
  2067.       --  from a semantic point of view, these are just integer multiplies.
  2068.  
  2069.       elsif Is_Fixed_Point_Type (Typ)
  2070.         and then not Treat_Fixed_As_Integer (N)
  2071.       then
  2072.          --  Case of fixed * integer => fixed
  2073.  
  2074.          if Is_Integer_Type (Rtyp) then
  2075.             Expand_Multiply_Fixed_By_Integer_Giving_Fixed (N);
  2076.  
  2077.          --  Case of integer * fixed => fixed
  2078.  
  2079.          elsif Is_Integer_Type (Ltyp) then
  2080.             Expand_Multiply_Integer_By_Fixed_Giving_Fixed (N);
  2081.  
  2082.          --  Case of fixed * fixed => fixed
  2083.  
  2084.          else
  2085.             Expand_Multiply_Fixed_By_Fixed_Giving_Fixed (N);
  2086.          end if;
  2087.  
  2088.       --  Other cases of multiplication of fixed-point operands. Again we
  2089.       --  exclude the cases where Treat_Fixed_As_Integer flag is set.
  2090.  
  2091.       elsif (Is_Fixed_Point_Type (Ltyp) or else
  2092.              Is_Fixed_Point_Type (Rtyp))
  2093.         and then not Treat_Fixed_As_Integer (N)
  2094.       then
  2095.          if Is_Integer_Type (Typ) then
  2096.             Expand_Multiply_Fixed_By_Fixed_Giving_Integer (N);
  2097.          else
  2098.             pragma Assert (Is_Floating_Point_Type (Typ));
  2099.             Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
  2100.          end if;
  2101.  
  2102.       --  Non-fixed point cases, check software overflow checking required
  2103.  
  2104.       elsif Software_Overflow_Checking
  2105.          and then Is_Signed_Integer_Type (Etype (N))
  2106.          and then Do_Overflow_Check (N)
  2107.       then
  2108.          Apply_Arithmetic_Overflow_Check (N);
  2109.       end if;
  2110.    end Expand_N_Op_Multiply;
  2111.  
  2112.    --------------------
  2113.    -- Expand_N_Op_Ne --
  2114.    --------------------
  2115.  
  2116.    --  Rewrite node as the negation of an equality operation, and reanalyze.
  2117.    --  The equality to be used is defined in the same scope and has the same
  2118.    --  signature. It must be set explicitly because in an instance it may not
  2119.    --  have the same visibility as in the generic unit.
  2120.  
  2121.    procedure Expand_N_Op_Ne (N : Node_Id) is
  2122.       Loc : constant Source_Ptr := Sloc (N);
  2123.       Neg : Node_Id;
  2124.       Ne  : constant Entity_Id := Entity (N);
  2125.       Eq  : Entity_Id;
  2126.  
  2127.    begin
  2128.       Neg := Make_Op_Not (Loc,
  2129.         Make_Op_Eq (Loc, Left_Opnd (N), Right_Opnd (N)));
  2130.  
  2131.       if Scope (Ne) /= Standard_Standard then
  2132.          Eq := First_Entity (Scope (Ne));
  2133.  
  2134.          while Present (Eq)
  2135.           and then (Chars (Eq) /= Name_Op_Eq
  2136.                      or else Next_Entity (Eq) /= Ne)
  2137.          loop
  2138.             Eq := Next_Entity (Eq);
  2139.          end loop;
  2140.  
  2141.          Set_Entity (Right_Opnd (Neg), Eq);
  2142.       end if;
  2143.  
  2144.       Rewrite_Substitute_Tree (N, Neg);
  2145.       Analyze (N);
  2146.       Resolve (N, Standard_Boolean);
  2147.    end Expand_N_Op_Ne;
  2148.  
  2149.    ---------------------
  2150.    -- Expand_N_Op_Not --
  2151.    ---------------------
  2152.  
  2153.    --  If the argument is other than a Boolean array type, there is no
  2154.    --  special expansion required.
  2155.  
  2156.    --  For the packed case, we call the special routine in Exp_Pakd, except
  2157.    --  that if the component size is greater than one, we use the standard
  2158.    --  routine generating a gruesome loop (it is so peculiar to have packed
  2159.    --  arrays with non-standard Boolean representations anyway, so it does
  2160.    --  not matter that we do not handle this case efficiently).
  2161.  
  2162.    --  For the unpacked case (and for the special packed case where we have
  2163.    --  non standard Booleans, as discussed above), we generate and insert
  2164.    --  into the tree the following function definition:
  2165.  
  2166.    --     function Nnnn (A : arr) is
  2167.    --       B : arr;
  2168.    --     begin
  2169.    --       for J in a'range loop
  2170.    --          B (J) := not A (J);
  2171.    --       end loop;
  2172.    --       return B;
  2173.    --     end Nnnn;
  2174.  
  2175.    --  Here arr is the actual subtype of the parameter (and hence always
  2176.    --  constrained). Then we replace the not with a call to this function.
  2177.  
  2178.    procedure Expand_N_Op_Not (N : Node_Id) is
  2179.       Loc  : constant Source_Ptr := Sloc (N);
  2180.       Typ  : constant Entity_Id  := Etype (N);
  2181.       Opnd : Node_Id;
  2182.       Arr  : Entity_Id;
  2183.       A    : Entity_Id;
  2184.       B    : Entity_Id;
  2185.       J    : Entity_Id;
  2186.       A_J  : Node_Id;
  2187.       B_J  : Node_Id;
  2188.  
  2189.       Func_Name      : Entity_Id;
  2190.       Loop_Statement : Node_Id;
  2191.  
  2192.    begin
  2193.       if not Is_Array_Type (Typ) then
  2194.          return;
  2195.  
  2196.       elsif Is_Packed (Typ) and then Esize (Component_Type (Typ)) = 1 then
  2197.          Expand_Packed_Not (N);
  2198.          return;
  2199.       end if;
  2200.  
  2201.       Opnd := Convert_To_Actual_Subtype (Right_Opnd (N));
  2202.       Arr := Etype (Opnd);
  2203.  
  2204.       A := Make_Defining_Identifier (Loc, Name_uA);
  2205.       B := Make_Defining_Identifier (Loc, Name_uB);
  2206.       J := Make_Defining_Identifier (Loc, Name_uJ);
  2207.  
  2208.       A_J :=
  2209.         Make_Indexed_Component (Loc,
  2210.           Prefix      => New_Reference_To (A, Loc),
  2211.           Expressions => New_List (New_Reference_To (J, Loc)));
  2212.  
  2213.       B_J :=
  2214.         Make_Indexed_Component (Loc,
  2215.           Prefix      => New_Reference_To (B, Loc),
  2216.           Expressions => New_List (New_Reference_To (J, Loc)));
  2217.  
  2218.       Loop_Statement :=
  2219.         Make_Loop_Statement (Loc,
  2220.           Identifier => Empty,
  2221.  
  2222.           Iteration_Scheme =>
  2223.             Make_Iteration_Scheme (Loc,
  2224.               Loop_Parameter_Specification =>
  2225.                 Make_Loop_Parameter_Specification (Loc,
  2226.                   Defining_Identifier => J,
  2227.                   Discrete_Subtype_Definition =>
  2228.                     Make_Attribute_Reference (Loc,
  2229.                       Prefix => Make_Identifier (Loc, Chars (A)),
  2230.                       Attribute_Name => Name_Range))),
  2231.  
  2232.           Statements => New_List (
  2233.             Make_Assignment_Statement (Loc,
  2234.               Name       => B_J,
  2235.               Expression => Make_Op_Not (Loc, A_J))));
  2236.  
  2237.       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
  2238.  
  2239.       Insert_Action (N,
  2240.         Make_Subprogram_Body (Loc,
  2241.           Specification =>
  2242.             Make_Function_Specification (Loc,
  2243.               Defining_Unit_Name => Func_Name,
  2244.               Parameter_Specifications => New_List (
  2245.                 Make_Parameter_Specification (Loc,
  2246.                   Defining_Identifier => A,
  2247.                   Parameter_Type      => New_Reference_To (Typ, Loc))),
  2248.               Subtype_Mark => New_Reference_To (Typ, Loc)),
  2249.  
  2250.           Declarations => New_List (
  2251.             Make_Object_Declaration (Loc,
  2252.               Defining_Identifier => B,
  2253.               Object_Definition   => New_Reference_To (Typ, Loc))),
  2254.  
  2255.           Handled_Statement_Sequence =>
  2256.             Make_Handled_Sequence_Of_Statements (Loc,
  2257.               Statements => New_List (
  2258.                 Loop_Statement,
  2259.                 Make_Return_Statement (Loc,
  2260.                   Expression =>
  2261.                     Make_Identifier (Loc, Chars (B)))))));
  2262.  
  2263.       Rewrite_Substitute_Tree (N,
  2264.         Make_Function_Call (Loc,
  2265.           Name => New_Reference_To (Func_Name, Loc),
  2266.           Parameter_Associations => New_List (Opnd)));
  2267.  
  2268.       Analyze (N);
  2269.       Resolve (N, Typ);
  2270.    end Expand_N_Op_Not;
  2271.  
  2272.    --------------------
  2273.    -- Expand_N_Op_Or --
  2274.    --------------------
  2275.  
  2276.    procedure Expand_N_Op_Or (N : Node_Id) is
  2277.    begin
  2278.       if Is_Array_Type (Etype (N)) then
  2279.          Expand_Boolean_Operator (N);
  2280.       end if;
  2281.    end Expand_N_Op_Or;
  2282.  
  2283.    ---------------------
  2284.    -- Expand_N_Op_Rem --
  2285.    ---------------------
  2286.  
  2287.    procedure Expand_N_Op_Rem (N : Node_Id) is
  2288.    begin
  2289.       if Software_Overflow_Checking
  2290.          and then Is_Integer_Type (Etype (N))
  2291.          and then Do_Overflow_Check (N)
  2292.       then
  2293.          Expand_Zero_Divide_Check (N);
  2294.       end if;
  2295.    end Expand_N_Op_Rem;
  2296.  
  2297.    --------------------------
  2298.    -- Expand_N_Op_Subtract --
  2299.    --------------------------
  2300.  
  2301.    procedure Expand_N_Op_Subtract (N : Node_Id) is
  2302.    begin
  2303.       if Software_Overflow_Checking
  2304.          and then Is_Signed_Integer_Type (Etype (N))
  2305.          and then Do_Overflow_Check (N)
  2306.       then
  2307.          Apply_Arithmetic_Overflow_Check (N);
  2308.       end if;
  2309.    end Expand_N_Op_Subtract;
  2310.  
  2311.    ---------------------
  2312.    -- Expand_N_Op_Xor --
  2313.    ---------------------
  2314.  
  2315.    procedure Expand_N_Op_Xor (N : Node_Id) is
  2316.    begin
  2317.       if Is_Array_Type (Etype (N)) then
  2318.          Expand_Boolean_Operator (N);
  2319.       end if;
  2320.    end Expand_N_Op_Xor;
  2321.  
  2322.    ----------------------
  2323.    -- Expand_N_Or_Else --
  2324.    ----------------------
  2325.  
  2326.    --  Expand into conditional expression if Actions present
  2327.  
  2328.    procedure Expand_N_Or_Else (N : Node_Id) is
  2329.       Loc     : constant Source_Ptr := Sloc (N);
  2330.       Typ     : constant Entity_Id  := Etype (N);
  2331.       Actlist : List_Id;
  2332.  
  2333.    begin
  2334.       --  If Actions are present, we expand
  2335.  
  2336.       --     left or else right
  2337.  
  2338.       --  into
  2339.  
  2340.       --     if left then True else right end
  2341.  
  2342.       --  with the actions becoming the Else_Actions of the conditional
  2343.       --  expression. This conditional expression is then further expanded
  2344.       --  (and will eventually disappear)
  2345.  
  2346.       if Present (Actions (N)) then
  2347.          Actlist := Actions (N);
  2348.          Rewrite_Substitute_Tree (N,
  2349.             Make_Conditional_Expression (Loc,
  2350.               Expressions => New_List (
  2351.                 Left_Opnd (N),
  2352.                 New_Occurrence_Of (Standard_True, Loc),
  2353.                 Right_Opnd (N))));
  2354.  
  2355.          Set_Else_Actions (N, Actlist);
  2356.          Analyze (N);
  2357.          Resolve (N, Typ);
  2358.       end if;
  2359.    end Expand_N_Or_Else;
  2360.  
  2361.    --------------------
  2362.    -- Expand_N_Slice --
  2363.    --------------------
  2364.  
  2365.    --  Build an implicit subtype declaration to represent the type delivered
  2366.    --  by the slice. This is an abbreviated version of an array subtype. We
  2367.    --  define an index subtype for the slice,  using either the subtype name
  2368.    --  or the discrete range of the slice. To be consistent with index usage
  2369.    --  elsewhere,  we create a list header to hold the single index. This list
  2370.    --  is not otherwise attached to the syntax tree.
  2371.  
  2372.    procedure Expand_N_Slice (N : Node_Id) is
  2373.       Loc           : constant Source_Ptr := Sloc (N);
  2374.       Index         : Node_Id;
  2375.       Index_List    : List_Id := New_List;
  2376.       Index_Subtype : Entity_Id;
  2377.       Index_Type    : Entity_Id;
  2378.       Slice_Subtype : Entity_Id;
  2379.  
  2380.    begin
  2381.       if Is_Entity_Name (Discrete_Range (N)) then
  2382.          Index_Subtype := Entity (Discrete_Range (N));
  2383.  
  2384.       else
  2385.          Index_Type    := Base_Type (Etype (Discrete_Range (N)));
  2386.          Index_Subtype := New_Itype (Subtype_Kind (Ekind (Index_Type)), N);
  2387.          Set_Scalar_Range (Index_Subtype, Discrete_Range (N));
  2388.          Set_Etype        (Index_Subtype, Index_Type);
  2389.          Set_Esize        (Index_Subtype, Esize (Index_Type));
  2390.       end if;
  2391.  
  2392.       Slice_Subtype := New_Itype (E_Array_Subtype, N);
  2393.       Index := New_Occurrence_Of (Index_Subtype, Loc);
  2394.       Set_Etype (Index, Index_Subtype);
  2395.       Append (Index, Index_List);
  2396.  
  2397.       Set_Component_Type (Slice_Subtype, Component_Type (Etype (N)));
  2398.       Set_First_Index    (Slice_Subtype, Index);
  2399.       Set_Etype          (Slice_Subtype, Base_Type (Etype (N)));
  2400.       Set_Is_Constrained (Slice_Subtype);
  2401.       Check_Compile_Time_Size (Slice_Subtype);
  2402.  
  2403.       --  The Etype of the existing Slice node is reset to this slice
  2404.       --  subtype. Its bounds are obtained from its first index.
  2405.  
  2406.       Set_Etype (N, Slice_Subtype);
  2407.    end Expand_N_Slice;
  2408.  
  2409.    ------------------------------
  2410.    -- Expand_N_Type_Conversion --
  2411.    ------------------------------
  2412.  
  2413.    procedure Expand_N_Type_Conversion (N : Node_Id) is
  2414.       Loc  : constant Source_Ptr := Sloc (N);
  2415.       Expr : constant Node_Id    := Expression (N);
  2416.       T    : constant Entity_Id  := Etype (N);
  2417.  
  2418.    begin
  2419.  
  2420.       --  When needed, that is to say when the expression is class-wide,
  2421.       --  Add runtime a tag check for (strict) downward conversion by using
  2422.       --  the membership test:
  2423.  
  2424.       --      [if Expr not in T'Class then raise Constraint_Error; end if; N]
  2425.  
  2426.       --  or in the access type case
  2427.  
  2428.       --      [if Expr /= null
  2429.       --         and then Expr.all not in Designated_Type (T)'Class
  2430.       --       then
  2431.       --          raise Constraint_Error;
  2432.       --       end if;
  2433.       --       N]
  2434.  
  2435.  
  2436.  
  2437.  
  2438.       if (Is_Access_Type (T)
  2439.            and then Is_Tagged_Type (Designated_Type (T)))
  2440.         or else Is_Tagged_Type (T)
  2441.       then
  2442.          declare
  2443.             E          : Multi_Use.Exp_Id;
  2444.             Expr_Type  : Entity_Id := Etype (Expr);
  2445.             Target_Typ : Entity_Id := T;
  2446.             Cond       : Node_Id;
  2447.  
  2448.          begin
  2449.             if Is_Access_Type (T) then
  2450.                Expr_Type  := Designated_Type (Expr_Type);
  2451.                Target_Typ := Designated_Type (T);
  2452.             end if;
  2453.  
  2454.             if Is_Class_Wide_Type (Expr_Type)
  2455.               and then Root_Type (Expr_Type) /=  Target_Typ
  2456.               and then Is_Ancestor (Root_Type (Expr_Type), Target_Typ)
  2457.               and then not Tag_Checks_Suppressed (Target_Typ)
  2458.             then
  2459.                --  The conversion is valid for any descendant of the
  2460.                --  target type
  2461.  
  2462.                Target_Typ := Class_Wide_Type (Target_Typ);
  2463.  
  2464.                Replace_Substitute_Tree (N,
  2465.                  Make_Expression_Actions (Loc,
  2466.                    Actions    => New_List,
  2467.                    Expression => Relocate_Node (N)));
  2468.  
  2469.                Multi_Use.New_Exp_Id (Expr, Actions (N), E);
  2470.                Replace_Substitute_Tree (Expr, Multi_Use.New_Ref (E));
  2471.  
  2472.                if Is_Access_Type (T) then
  2473.                   Cond :=
  2474.                      Make_And_Then (Loc,
  2475.                        Left_Opnd =>
  2476.                          Make_Op_Ne (Loc,
  2477.                            Left_Opnd => Multi_Use.New_Ref (E),
  2478.                            Right_Opnd => Make_Null (Loc)),
  2479.  
  2480.                        Right_Opnd =>
  2481.                          Make_Not_In (Loc,
  2482.                            Left_Opnd  =>
  2483.                              Make_Explicit_Dereference (Loc,
  2484.                                Prefix => Multi_Use.New_Ref (E)),
  2485.                            Right_Opnd => New_Reference_To (Target_Typ, Loc)));
  2486.  
  2487.                else
  2488.                   Cond :=
  2489.                     Make_Not_In (Loc,
  2490.                       Left_Opnd  => Multi_Use.New_Ref (E),
  2491.                       Right_Opnd => New_Reference_To (Target_Typ, Loc));
  2492.  
  2493.                end if;
  2494.  
  2495.                Append_To (Actions (N),
  2496.                  Make_If_Statement (Loc,
  2497.                    Condition       => Cond,
  2498.                    Then_Statements => New_List (New_Constraint_Error (Loc))));
  2499.  
  2500.                Change_Conversion_To_Unchecked (Expression (N));
  2501.                Analyze (N);
  2502.                Resolve (N, T);
  2503.             end if;
  2504.          end;
  2505.  
  2506.       --  Deal with cases where the operand is universal fixed, which means
  2507.       --  it must be a multiply or divide. In these cases, we simply replace
  2508.       --  the conversion by the multiply or divide node, retyping its result
  2509.       --  as the target type of the conversion. Note that all nodes have been
  2510.       --  analyzed already, so we don't need to reanalyze them.
  2511.  
  2512.       elsif Etype (Expr) = Universal_Fixed then
  2513.          if Nkind (Expr) = N_Op_Multiply then
  2514.             Replace_Substitute_Tree (N, Expr);
  2515.             Set_Etype (N, T);
  2516.             Expand_N_Op_Multiply (N);
  2517.  
  2518.          else
  2519.             pragma Assert (Nkind (Expr) = N_Op_Divide);
  2520.             Replace_Substitute_Tree (N, Expr);
  2521.             Set_Etype (N, T);
  2522.             Expand_N_Op_Divide (N);
  2523.          end if;
  2524.  
  2525.       --  Expansion of conversions whose source is a fixed-point type. Note
  2526.       --  we ignore cases where Conversion_OK is set, since from a semantic
  2527.       --  point of view, these are normal arithmetic conversions.
  2528.  
  2529.       elsif Is_Fixed_Point_Type (Etype (Expr))
  2530.         and then not Conversion_OK (N)
  2531.       then
  2532.          if Is_Fixed_Point_Type (T) then
  2533.             Expand_Convert_Fixed_To_Fixed (N);
  2534.          elsif Is_Integer_Type (T) then
  2535.             Expand_Convert_Fixed_To_Integer (N);
  2536.          else
  2537.             pragma Assert (Is_Floating_Point_Type (T));
  2538.             Expand_Convert_Fixed_To_Float (N);
  2539.          end if;
  2540.  
  2541.       --  Expansions of conversions whose result type is fixed-point. We
  2542.       --  exclude conversions with Conversion_OK set, since from a semantic
  2543.       --  point of view, these are just integer conversions.
  2544.  
  2545.       elsif Is_Fixed_Point_Type (T)
  2546.         and then not Conversion_OK (N)
  2547.       then
  2548.          if Is_Integer_Type (Etype (Expr)) then
  2549.             Expand_Convert_Integer_To_Fixed (N);
  2550.          else
  2551.             pragma Assert (Is_Floating_Point_Type (Etype (Expr)));
  2552.             Expand_Convert_Float_To_Fixed (N);
  2553.          end if;
  2554.  
  2555.       --  Expansion of float-to-integer conversions. Note that we also handle
  2556.       --  float-to-fixed here for the case where Conversion_OK is set. We do
  2557.       --  not have to explicitly test Conversion_OK, since if it is not set,
  2558.       --  one of the above two cases would have applied.
  2559.  
  2560.       --  We skip this expansion if the conversion node has Float_Truncate
  2561.       --  set, because in that case, Gigi does the correct conversion.
  2562.  
  2563.       elsif (Is_Integer_Type (T) or else
  2564.              Is_Fixed_Point_Type (T))
  2565.         and then Is_Floating_Point_Type (Etype (Expr))
  2566.         and then not Float_Truncate (N)
  2567.       then
  2568.          --  Special case, if the expression is a typ'Truncation attribute,
  2569.          --  then this attribute can be eliminated, and Float_Truncate set
  2570.          --  on the conversion node.
  2571.  
  2572.          if Nkind (Expr) = N_Attribute_Reference
  2573.            and then Attribute_Name (Expr) = Name_Truncation
  2574.          then
  2575.             Rewrite_Substitute_Tree (Expr,
  2576.               Relocate_Node (First (Expressions (Expr))));
  2577.             Set_Float_Truncate (N, True);
  2578.  
  2579.          --  Otherwise, we expand T (S) into
  2580.  
  2581.          --    [Tnn : constant rtyp := S;
  2582.          --       [if Tnn >= 0.0 then ityp^(Tnn + 0.5) else ityp^(Tnn - 0.5)]]
  2583.  
  2584.          --  where rtyp is the base type of the floating-point source type,
  2585.          --  and itype is the base type of the integer target type.
  2586.  
  2587.          else
  2588.             declare
  2589.                Tnn : constant Entity_Id :=
  2590.                        Make_Defining_Identifier
  2591.                          (Loc, New_Internal_Name ('T'));
  2592.  
  2593.                Ityp : constant Entity_Id := T;
  2594.                Rtyp : constant Entity_Id := Etype (Expr);
  2595.  
  2596.                function Truncate_Conversion (Expr : Node_Id) return Node_Id;
  2597.                --  Builds a type conversion with the Float_Truncate flag set,
  2598.                --  the given argument Expr as the source, and the base type'
  2599.                --  as the destination subtype. The Conversion_OK flag is
  2600.                --  copied from the parent cnversion node.
  2601.  
  2602.                function Truncate_Conversion (Expr : Node_Id) return Node_Id is
  2603.                   Cnode : constant Node_Id :=
  2604.                     Make_Type_Conversion (Loc,
  2605.                       Subtype_Mark => New_Reference_To (Ityp, Loc),
  2606.                       Expression => Expr);
  2607.                begin
  2608.                   Set_Float_Truncate (Cnode, True);
  2609.                   Set_Conversion_OK  (Cnode, Conversion_OK (N));
  2610.  
  2611.                   --  Set Etype in case Conversion_OK is set
  2612.  
  2613.                   Set_Etype (Cnode, T);
  2614.                   return Cnode;
  2615.                end Truncate_Conversion;
  2616.  
  2617.             begin
  2618.                Rewrite_Substitute_Tree (N,
  2619.                  Make_Expression_Actions (Loc,
  2620.                     Actions => New_List (
  2621.                       Make_Object_Declaration (Loc,
  2622.                         Defining_Identifier => Tnn,
  2623.                         Constant_Present    => True,
  2624.                         Object_Definition   => New_Reference_To (Rtyp, Loc),
  2625.                         Expression          => Expression (N))),
  2626.  
  2627.                     Expression =>
  2628.                       Make_Conditional_Expression (Loc, New_List (
  2629.                         Make_Op_Ge (Loc,
  2630.                           Left_Opnd  => New_Reference_To (Tnn, Loc),
  2631.                           Right_Opnd => Make_Real_Literal (Loc, Ureal_0)),
  2632.  
  2633.                         Truncate_Conversion (
  2634.                           Make_Op_Add (Loc,
  2635.                             Left_Opnd  => New_Reference_To (Tnn, Loc),
  2636.                             Right_Opnd =>
  2637.                               Make_Real_Literal (Loc, Ureal_Half))),
  2638.  
  2639.                         Truncate_Conversion (
  2640.                           Make_Op_Subtract (Loc,
  2641.                             Left_Opnd  => New_Reference_To (Tnn, Loc),
  2642.                             Right_Opnd =>
  2643.                               Make_Real_Literal (Loc, Ureal_Half)))))));
  2644.  
  2645.                Analyze (N);
  2646.                Resolve (N, T);
  2647.             end;
  2648.          end if;
  2649.  
  2650.       elsif Is_Array_Type (T) then
  2651.          if Is_Constrained (T) then
  2652.             Apply_Length_Check (Expr, T);
  2653.  
  2654.          else
  2655.             --  ??? this declare loop needs a name!
  2656.             declare
  2657.                Opnd_Index : Node_Id;
  2658.                Targ_Index : Node_Id;
  2659.  
  2660.                procedure Check_Array_Conversion
  2661.                  (Val : Node_Id; Bound : Node_Id; Lt : Boolean);
  2662.                --  Generate an Action to check that the bounds of the
  2663.                --  source value are within the constraints imposed by the
  2664.                --  target type for a conversion to an unconstrained type.
  2665.                --  Rule is 4.6(38).
  2666.                --  if Lt is True the condition that will raise Constraint_Error
  2667.                --  is Val < Bound otherwise it is Val > Bound
  2668.  
  2669.                procedure Check_Array_Conversion
  2670.                  (Val : Node_Id; Bound : Node_Id; Lt : Boolean)
  2671.                is
  2672.                   Cond : Node_Id;
  2673.  
  2674.                begin
  2675.                   if Lt then
  2676.                      Cond :=
  2677.                        Make_Op_Lt (Loc,
  2678.                          Left_Opnd =>
  2679.                            Convert_To (Etype (Targ_Index),
  2680.                              Duplicate_Subexpr (Val)),
  2681.                          Right_Opnd => Duplicate_Subexpr (Bound));
  2682.  
  2683.                   else
  2684.                      Cond :=
  2685.                        Make_Op_Gt (Loc,
  2686.                          Left_Opnd =>
  2687.                            Convert_To (Etype (Targ_Index),
  2688.                              Duplicate_Subexpr (Val)),
  2689.                          Right_Opnd => Duplicate_Subexpr (Bound));
  2690.                   end if;
  2691.  
  2692.                   Insert_Action (N,
  2693.                     Make_If_Statement (Loc,
  2694.                       Condition => Cond,
  2695.                       Then_Statements => New_List (
  2696.                         Make_Raise_Statement (Loc,
  2697.                           Name =>
  2698.                             New_Reference_To
  2699.                               (Standard_Constraint_Error, Loc)))));
  2700.                end Check_Array_Conversion;
  2701.  
  2702.             --  Start of processing for ???
  2703.  
  2704.             begin
  2705.                Opnd_Index := First_Index (Etype (Expr));
  2706.                Targ_Index := First_Index (T);
  2707.  
  2708.                while Opnd_Index /= Empty loop
  2709.                   if Nkind (Opnd_Index) = N_Range then
  2710.                      if Is_In_Range
  2711.                           (Low_Bound (Opnd_Index), Etype (Targ_Index))
  2712.                      then
  2713.                         null;
  2714.  
  2715.                      elsif Is_Out_Of_Range
  2716.                              (Low_Bound (Opnd_Index), Etype (Targ_Index))
  2717.                      then
  2718.                         Compile_Time_Constraint_Error
  2719.                           (Expr, "value out of range?");
  2720.  
  2721.                      else
  2722.                         Check_Array_Conversion (
  2723.                           Low_Bound (Opnd_Index),
  2724.                           Type_Low_Bound (Etype (Targ_Index)),
  2725.                           Lt => True);
  2726.                      end if;
  2727.  
  2728.                      if Is_In_Range
  2729.                           (High_Bound (Opnd_Index), Etype (Targ_Index))
  2730.                      then
  2731.                         null;
  2732.  
  2733.                      elsif Is_Out_Of_Range
  2734.                              (High_Bound (Opnd_Index), Etype (Targ_Index))
  2735.                      then
  2736.                         Compile_Time_Constraint_Error
  2737.                           (Expr, "value out of range?");
  2738.  
  2739.                      else
  2740.                         Check_Array_Conversion (
  2741.                           High_Bound (Opnd_Index),
  2742.                           Type_High_Bound (Etype (Targ_Index)),
  2743.                           Lt => False);
  2744.                      end if;
  2745.                   end if;
  2746.  
  2747.                   Opnd_Index := Next_Index (Opnd_Index);
  2748.                   Targ_Index := Next_Index (Targ_Index);
  2749.                end loop;
  2750.             end;
  2751.          end if;
  2752.       end if;
  2753.  
  2754.    end Expand_N_Type_Conversion;
  2755.  
  2756.    ----------------------------
  2757.    -- Expand_Record_Equality --
  2758.    ----------------------------
  2759.  
  2760.    --  For non-variant records, Equality is expanded when needed into:
  2761.  
  2762.    --      and then Lhs.Discr1 = Rhs.Discr1
  2763.    --      and then ...
  2764.    --      and then Lhs.Discrn = Rhs.Discrn
  2765.    --      and then Lhs.Cmp1 = Rhs.Cmp1
  2766.    --      and then ...
  2767.    --      and then Lhs.Cmpn = Rhs.Cmpn
  2768.  
  2769.    --  The expression is folded by the back-end for adjacent fields. This
  2770.    --  function is called for tagged record in only one occasion: for imple-
  2771.    --  menting predefined primitive equality (see Predefined_Primitives_Bodies)
  2772.    --  otherwise the primitive "=" is used directly.
  2773.  
  2774.    function Expand_Record_Equality
  2775.      (Loc  : Source_Ptr;
  2776.       Typ  : Entity_Id;
  2777.       Lhs  : Node_Id;
  2778.       Rhs  : Node_Id)
  2779.       return Node_Id
  2780.    is
  2781.       function Suitable_Element (C : Entity_Id) return Entity_Id;
  2782.       --  return the first field to compare beginning with C, skipping the
  2783.       --  inherited components
  2784.  
  2785.       function Suitable_Element (C : Entity_Id) return Entity_Id is
  2786.       begin
  2787.  
  2788.          if No (C) then
  2789.             return Empty;
  2790.  
  2791.          elsif (Ekind (C) /= E_Discriminant and then Ekind (C) /= E_Component)
  2792.            or else (Is_Tagged_Type (Typ)
  2793.              and then C /= Original_Record_Component (C))
  2794.          then
  2795.             return Suitable_Element (Next_Entity (C));
  2796.          else
  2797.             return C;
  2798.          end if;
  2799.       end Suitable_Element;
  2800.  
  2801.       Result : Node_Id;
  2802.       C      : Entity_Id;
  2803.  
  2804.    --  Start of processing for Expand_Record_Equality
  2805.  
  2806.    begin
  2807.       --  Generates the following code: (assuming that Typ has one Discr and
  2808.       --  component C2 is also a record)
  2809.  
  2810.       --   True
  2811.       --     and then Lhs.Discr1 = Rhs.Discr1
  2812.       --     and then Lhs.C1 = Rhs.C1
  2813.       --     and then Lhs.C2.C1=Rhs.C2.C1 and then ... Lhs.C2.Cn=Rhs.C2.Cn
  2814.       --     and then ...
  2815.       --     and then Lhs.Cmpn = Rhs.Cmpn
  2816.  
  2817.       Result := New_Reference_To (Standard_True, Loc);
  2818.       C := Suitable_Element (First_Entity (Typ));
  2819.  
  2820.       while Present (C) loop
  2821.  
  2822.          Result :=
  2823.            Make_And_Then (Loc,
  2824.              Left_Opnd  => Result,
  2825.              Right_Opnd =>
  2826.                Expand_Composite_Equality (Loc, Etype (C),
  2827.                 Lhs => Make_Selected_Component (Loc,
  2828.                          Prefix => Lhs,
  2829.                          Selector_Name => New_Reference_To (C, Loc)),
  2830.                 Rhs => Make_Selected_Component (Loc,
  2831.                          Prefix => Rhs,
  2832.                          Selector_Name => New_Reference_To (C, Loc))));
  2833.  
  2834.          C := Suitable_Element (Next_Entity (C));
  2835.       end loop;
  2836.  
  2837.       return Result;
  2838.    end Expand_Record_Equality;
  2839.  
  2840.    ---------------------------------
  2841.    -- Expand_N_Selected_Component --
  2842.    ---------------------------------
  2843.  
  2844.    --  If the selector is a discriminant of a concurrent object, rewrite the
  2845.    --  prefix to denote the corresponding record type.
  2846.  
  2847.    procedure Expand_N_Selected_Component (N : Node_Id) is
  2848.       Loc   : constant Source_Ptr := Sloc (N);
  2849.       P     : Node_Id   := Prefix (N);
  2850.       Ptyp  : Entity_Id := Etype (P);
  2851.       Sel   : Name_Id;
  2852.       New_N : Node_Id;
  2853.  
  2854.    begin
  2855.       if Is_Protected_Type (Ptyp) then
  2856.          Sel := Name_uObject;
  2857.       elsif Is_Task_Type (Ptyp) then
  2858.          Sel := Name_uTask_Id;
  2859.       else
  2860.          return;
  2861.       end if;
  2862.  
  2863.       if Ekind (Entity (Selector_Name (N))) = E_Discriminant then
  2864.          New_N :=
  2865.            Make_Selected_Component (Loc,
  2866.              Prefix =>
  2867.                Make_Unchecked_Type_Conversion (Loc,
  2868.                  Subtype_Mark =>
  2869.                    New_Reference_To (Corresponding_Record_Type (Ptyp), Loc),
  2870.                  Expression => New_Copy_Tree (P)),
  2871.              Selector_Name =>
  2872.                Make_Identifier (Loc, Chars (Selector_Name (N))));
  2873.  
  2874.          Rewrite_Substitute_Tree (N, New_N);
  2875.          Analyze (N);
  2876.       end if;
  2877.  
  2878.    end Expand_N_Selected_Component;
  2879.  
  2880.    ------------------------------
  2881.    -- Expand_Zero_Divide_Check --
  2882.    ------------------------------
  2883.  
  2884.    --  This routine is called only if a software zero divide check is needed,
  2885.    --  i.e. if the operation is a signed integer divide (or mod/rem) operation
  2886.    --  and software overflow checking is enabled, and Do_Overflow_Check is
  2887.    --  True. Given an expression a op b, the following check is inserted into
  2888.    --  the tree:
  2889.  
  2890.    --     if b = 0 then
  2891.    --        raise Constraint_Error;
  2892.    --     end if;
  2893.  
  2894.    --  The check is required if software overflow checking is enabled, the
  2895.    --  operation is for an integer type, and Do_Overflow_Check is True
  2896.  
  2897.    procedure Expand_Zero_Divide_Check (N : Node_Id) is
  2898.       Opnd : constant Node_Id    := Right_Opnd (N);
  2899.       Loc  : constant Source_Ptr := Sloc (Opnd);
  2900.  
  2901.    begin
  2902.       Insert_Action (N,
  2903.         Make_If_Statement (Loc,
  2904.           Condition =>
  2905.             Make_Op_Eq (Loc,
  2906.               Left_Opnd => Duplicate_Subexpr (Opnd),
  2907.               Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
  2908.               Then_Statements => New_List (
  2909.                 Make_Raise_Statement (Loc,
  2910.                   Name =>
  2911.                     New_Reference_To (
  2912.                       Standard_Constraint_Error, Loc)))));
  2913.    end Expand_Zero_Divide_Check;
  2914.  
  2915.    ------------------------------
  2916.    -- Make_Array_Comparison_Op --
  2917.    ------------------------------
  2918.  
  2919.    --  This is a hand-coded expansion of the following generic function:
  2920.  
  2921.    --  generic
  2922.    --    type elem is  (<>);
  2923.    --    type index is (<>);
  2924.    --    type a is array (index range <>) of elem;
  2925.    --
  2926.    --  function Gnnn (X : a; Y: a) return boolean is
  2927.    --    J : index := Y'first;
  2928.    --
  2929.    --  begin
  2930.    --    if X'length = 0 then
  2931.    --       return false;
  2932.    --
  2933.    --    elsif Y'length = 0 then
  2934.    --       return true;
  2935.    --
  2936.    --    else
  2937.    --      for I in X'range loop
  2938.    --        if X (I) = Y (J) then
  2939.    --          if J = Y'last then
  2940.    --            exit;
  2941.    --          else
  2942.    --            J := index'succ (J);
  2943.    --          end if;
  2944.    --
  2945.    --        else
  2946.    --           return X (I) > Y (J);
  2947.    --        end if;
  2948.    --      end loop;
  2949.    --
  2950.    --      return X'length > Y'length;
  2951.    --    end if;
  2952.    --  end Gnnn;
  2953.  
  2954.    --  If the flag Equal is true, the procedure generates the body for
  2955.    --  >= instead. This only affects the last return statement.
  2956.  
  2957.    --  Note that since we are essentially doing this expansion by hand, we
  2958.    --  do not need to generate an actual or formal generic part, just the
  2959.    --  instantiated function itself.
  2960.  
  2961.    function Make_Array_Comparison_Op
  2962.      (Typ   : Entity_Id;
  2963.       Loc   : Source_Ptr;
  2964.       Equal : Boolean)
  2965.       return  Node_Id
  2966.    is
  2967.       X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uX);
  2968.       Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uY);
  2969.       I : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uI);
  2970.       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
  2971.  
  2972.       Index : constant Entity_Id := Base_Type (Etype (First_Index (Typ)));
  2973.  
  2974.       Loop_Statement : Node_Id;
  2975.       Loop_Body      : Node_Id;
  2976.       If_Stat        : Node_Id;
  2977.       Inner_If       : Node_Id;
  2978.       Final_Expr     : Node_Id;
  2979.       Func_Body      : Node_Id;
  2980.       Func_Name      : Entity_Id;
  2981.       Formals        : List_Id;
  2982.       Length1        : Node_Id;
  2983.       Length2        : Node_Id;
  2984.  
  2985.    begin
  2986.       --  if J = Y'last then
  2987.       --     exit;
  2988.       --  else
  2989.       --     J := index'succ (J);
  2990.       --  end if;
  2991.  
  2992.       Inner_If :=
  2993.         Make_If_Statement (Loc,
  2994.           Condition =>
  2995.             Make_Op_Eq (Loc,
  2996.               Left_Opnd => New_Reference_To (J, Loc),
  2997.               Right_Opnd =>
  2998.                 Make_Attribute_Reference (Loc,
  2999.                   Prefix => New_Reference_To (Y, Loc),
  3000.                   Attribute_Name => Name_Last)),
  3001.  
  3002.           Then_Statements => New_List (
  3003.                 Make_Exit_Statement (Loc)),
  3004.  
  3005.           Else_Statements =>
  3006.             New_List (
  3007.               Make_Assignment_Statement (Loc,
  3008.                 Name => New_Reference_To (J, Loc),
  3009.                 Expression =>
  3010.                   Make_Attribute_Reference (Loc,
  3011.                     Prefix => New_Reference_To (Index, Loc),
  3012.                     Attribute_Name => Name_Succ,
  3013.                     Expressions => New_List (New_Reference_To (J, Loc))))));
  3014.  
  3015.       --  if X (I) = Y (J) then
  3016.       --     if ... end if;
  3017.       --  else
  3018.       --     return X (I) > Y (J);
  3019.       --  end if;
  3020.  
  3021.       Loop_Body :=
  3022.         Make_If_Statement (Loc,
  3023.           Condition =>
  3024.             Make_Op_Eq (Loc,
  3025.               Left_Opnd =>
  3026.                 Make_Indexed_Component (Loc,
  3027.                   Prefix      => New_Reference_To (X, Loc),
  3028.                   Expressions => New_List (New_Reference_To (I, Loc))),
  3029.  
  3030.               Right_Opnd =>
  3031.                 Make_Indexed_Component (Loc,
  3032.                   Prefix      => New_Reference_To (Y, Loc),
  3033.                   Expressions => New_List (New_Reference_To (J, Loc)))),
  3034.  
  3035.           Then_Statements => New_List (Inner_If),
  3036.  
  3037.           Else_Statements => New_List (
  3038.             Make_Return_Statement (Loc,
  3039.               Expression =>
  3040.                 Make_Op_Gt (Loc,
  3041.                   Left_Opnd =>
  3042.                     Make_Indexed_Component (Loc,
  3043.                       Prefix      => New_Reference_To (X, Loc),
  3044.                       Expressions => New_List (New_Reference_To (I, Loc))),
  3045.  
  3046.                   Right_Opnd =>
  3047.                     Make_Indexed_Component (Loc,
  3048.                       Prefix      => New_Reference_To (Y, Loc),
  3049.                       Expressions => New_List (
  3050.                         New_Reference_To (J, Loc)))))));
  3051.  
  3052.       --  for I in X'range loop
  3053.       --     if ... end if;
  3054.       --  end loop;
  3055.  
  3056.       Loop_Statement :=
  3057.         Make_Loop_Statement (Loc,
  3058.           Identifier => Empty,
  3059.  
  3060.           Iteration_Scheme =>
  3061.             Make_Iteration_Scheme (Loc,
  3062.               Loop_Parameter_Specification =>
  3063.                 Make_Loop_Parameter_Specification (Loc,
  3064.                   Defining_Identifier => I,
  3065.                   Discrete_Subtype_Definition =>
  3066.                     Make_Attribute_Reference (Loc,
  3067.                       Prefix => New_Reference_To (X, Loc),
  3068.                       Attribute_Name => Name_Range))),
  3069.  
  3070.           Statements => New_List (Loop_Body));
  3071.  
  3072.       --    if X'length = 0 then
  3073.       --       return false;
  3074.       --    elsif Y'length = 0 then
  3075.       --       return true;
  3076.       --    else
  3077.       --      for ... loop ... end loop;
  3078.       --      return X'length > Y'length;
  3079.       --    --  return X'length >= Y'length to implement >=.
  3080.       --    end if;
  3081.  
  3082.       Length1 :=
  3083.         Make_Attribute_Reference (Loc,
  3084.           Prefix => New_Reference_To (X, Loc),
  3085.           Attribute_Name => Name_Length);
  3086.  
  3087.       Length2 :=
  3088.         Make_Attribute_Reference (Loc,
  3089.           Prefix => New_Reference_To (Y, Loc),
  3090.           Attribute_Name => Name_Length);
  3091.  
  3092.       if Equal then
  3093.          Final_Expr :=
  3094.            Make_Op_Ge (Loc,
  3095.              Left_Opnd  => Length1,
  3096.              Right_Opnd => Length2);
  3097.       else
  3098.          Final_Expr :=
  3099.            Make_Op_Gt (Loc,
  3100.              Left_Opnd  => Length1,
  3101.              Right_Opnd => Length2);
  3102.       end if;
  3103.  
  3104.       If_Stat :=
  3105.         Make_If_Statement (Loc,
  3106.           Condition =>
  3107.             Make_Op_Eq (Loc,
  3108.               Left_Opnd =>
  3109.                 Make_Attribute_Reference (Loc,
  3110.                   Prefix => New_Reference_To (X, Loc),
  3111.                   Attribute_Name => Name_Length),
  3112.               Right_Opnd =>
  3113.                 Make_Integer_Literal (Loc, Uint_0)),
  3114.  
  3115.           Then_Statements =>
  3116.             New_List (
  3117.               Make_Return_Statement (Loc,
  3118.                 Expression => New_Reference_To (Standard_False, Loc))),
  3119.  
  3120.           Elsif_Parts => New_List (
  3121.             Make_Elsif_Part (Loc,
  3122.               Condition =>
  3123.                 Make_Op_Eq (Loc,
  3124.                   Left_Opnd =>
  3125.                     Make_Attribute_Reference (Loc,
  3126.                       Prefix => New_Reference_To (Y, Loc),
  3127.                       Attribute_Name => Name_Length),
  3128.                   Right_Opnd =>
  3129.                     Make_Integer_Literal (Loc, Uint_0)),
  3130.  
  3131.               Then_Statements =>
  3132.                 New_List (
  3133.                   Make_Return_Statement (Loc,
  3134.                      Expression => New_Reference_To (Standard_True, Loc))))),
  3135.  
  3136.           Else_Statements => New_List (
  3137.             Loop_Statement,
  3138.             Make_Return_Statement (Loc,
  3139.               Expression => Final_Expr)));
  3140.  
  3141.  
  3142.       --  (X : a; Y: a)
  3143.  
  3144.       Formals := New_List (
  3145.         Make_Parameter_Specification (Loc,
  3146.           Defining_Identifier => X,
  3147.           Parameter_Type      => New_Reference_To (Typ, Loc)),
  3148.  
  3149.         Make_Parameter_Specification (Loc,
  3150.           Defining_Identifier => Y,
  3151.           Parameter_Type      => New_Reference_To (Typ, Loc)));
  3152.  
  3153.       --  function Gnnn (...) return boolean is
  3154.       --    J : index := Y'first;
  3155.       --  begin
  3156.       --    if ... end if;
  3157.       --  end Gnnn;
  3158.  
  3159.       Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('G'));
  3160.  
  3161.       Func_Body :=
  3162.         Make_Subprogram_Body (Loc,
  3163.           Specification =>
  3164.             Make_Function_Specification (Loc,
  3165.               Defining_Unit_Name       => Func_Name,
  3166.               Parameter_Specifications => Formals,
  3167.               Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
  3168.  
  3169.           Declarations => New_List (
  3170.             Make_Object_Declaration (Loc,
  3171.               Defining_Identifier => J,
  3172.               Object_Definition   => New_Reference_To (Index, Loc),
  3173.               Expression =>
  3174.                 Make_Attribute_Reference (Loc,
  3175.                   Prefix => New_Reference_To (Y, Loc),
  3176.                   Attribute_Name => Name_First))),
  3177.  
  3178.           Handled_Statement_Sequence =>
  3179.             Make_Handled_Sequence_Of_Statements (Loc,
  3180.               Statements => New_List (If_Stat)));
  3181.  
  3182.       return Func_Body;
  3183.  
  3184.    end Make_Array_Comparison_Op;
  3185.  
  3186.    ---------------------------
  3187.    -- Make_Boolean_Array_Op --
  3188.    ---------------------------
  3189.  
  3190.    --  For logical operations on boolean arrays, expand in line the
  3191.    --  following, replacing 'and' with 'or' or 'xor' where needed:
  3192.  
  3193.    --    function Annn (A : typ; B: typ) return typ is
  3194.    --       C : typ;
  3195.    --    begin
  3196.    --       for J in A'range loop
  3197.    --          C (J) := A (J) op B (J);
  3198.    --       end loop;
  3199.    --       return C;
  3200.    --    end Annn;
  3201.  
  3202.    --  Here typ is the array type (either an an array of boolean in the normal
  3203.    --  case, or an array of unsigned in the packed case).
  3204.  
  3205.    function Make_Boolean_Array_Op
  3206.      (Typ  : Entity_Id;
  3207.       N    : Node_Id)
  3208.       return Node_Id
  3209.    is
  3210.       Loc : constant Source_Ptr := Sloc (N);
  3211.  
  3212.       A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
  3213.       B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
  3214.       C : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uC);
  3215.       J : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uJ);
  3216.  
  3217.       A_J : Node_Id;
  3218.       B_J : Node_Id;
  3219.       C_J : Node_Id;
  3220.       Op  : Node_Id;
  3221.  
  3222.       Formals        : List_Id;
  3223.       Func_Name      : Entity_Id;
  3224.       Func_Body      : Node_Id;
  3225.       Loop_Statement : Node_Id;
  3226.  
  3227.    begin
  3228.       A_J :=
  3229.         Make_Indexed_Component (Loc,
  3230.           Prefix      => New_Reference_To (A, Loc),
  3231.           Expressions => New_List (New_Reference_To (J, Loc)));
  3232.  
  3233.       B_J :=
  3234.         Make_Indexed_Component (Loc,
  3235.           Prefix      => New_Reference_To (B, Loc),
  3236.           Expressions => New_List (New_Reference_To (J, Loc)));
  3237.  
  3238.       C_J :=
  3239.         Make_Indexed_Component (Loc,
  3240.           Prefix      => New_Reference_To (C, Loc),
  3241.           Expressions => New_List (New_Reference_To (J, Loc)));
  3242.  
  3243.       if Nkind (N) = N_Op_And then
  3244.          Op :=
  3245.            Make_Op_And (Loc,
  3246.              Left_Opnd  => A_J,
  3247.              Right_Opnd => B_J);
  3248.  
  3249.       elsif Nkind (N) = N_Op_Or then
  3250.          Op :=
  3251.            Make_Op_Or (Loc,
  3252.              Left_Opnd  => A_J,
  3253.              Right_Opnd => B_J);
  3254.  
  3255.       else
  3256.          Op :=
  3257.            Make_Op_Xor (Loc,
  3258.              Left_Opnd  => A_J,
  3259.              Right_Opnd => B_J);
  3260.       end if;
  3261.  
  3262.       Loop_Statement :=
  3263.         Make_Loop_Statement (Loc,
  3264.           Identifier => Empty,
  3265.  
  3266.           Iteration_Scheme =>
  3267.             Make_Iteration_Scheme (Loc,
  3268.               Loop_Parameter_Specification =>
  3269.                 Make_Loop_Parameter_Specification (Loc,
  3270.                   Defining_Identifier => J,
  3271.                   Discrete_Subtype_Definition =>
  3272.                     Make_Attribute_Reference (Loc,
  3273.                       Prefix => New_Reference_To (A, Loc),
  3274.                       Attribute_Name => Name_Range))),
  3275.  
  3276.           Statements => New_List (
  3277.             Make_Assignment_Statement (Loc,
  3278.               Name       => C_J,
  3279.               Expression => Op)));
  3280.  
  3281.       Formals := New_List (
  3282.         Make_Parameter_Specification (Loc,
  3283.           Defining_Identifier => A,
  3284.           Parameter_Type      => New_Reference_To (Typ, Loc)),
  3285.  
  3286.         Make_Parameter_Specification (Loc,
  3287.           Defining_Identifier => B,
  3288.           Parameter_Type      => New_Reference_To (Typ, Loc)));
  3289.  
  3290.       Func_Name :=
  3291.         Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
  3292.  
  3293.       Func_Body :=
  3294.         Make_Subprogram_Body (Loc,
  3295.           Specification =>
  3296.             Make_Function_Specification (Loc,
  3297.               Defining_Unit_Name       => Func_Name,
  3298.               Parameter_Specifications => Formals,
  3299.               Subtype_Mark             => New_Reference_To (Typ, Loc)),
  3300.  
  3301.           Declarations => New_List (
  3302.             Make_Object_Declaration (Loc,
  3303.               Defining_Identifier => C,
  3304.               Object_Definition   => New_Reference_To (Typ, Loc))),
  3305.  
  3306.           Handled_Statement_Sequence =>
  3307.             Make_Handled_Sequence_Of_Statements (Loc,
  3308.               Statements => New_List (
  3309.                 Loop_Statement,
  3310.                 Make_Return_Statement (Loc,
  3311.                   Expression => New_Reference_To (C, Loc)))));
  3312.  
  3313.       return Func_Body;
  3314.    end Make_Boolean_Array_Op;
  3315.  
  3316.    ------------------------
  3317.    --  Tagged_Membership --
  3318.    ------------------------
  3319.  
  3320.    --  There are two different cases to consider depending on whether
  3321.    --  the right operand is a class-wide type or not. If not we just
  3322.    --  compare the actual tag of the left expr to the target type tag:
  3323.    --
  3324.    --     Left_Expr.Tag = Right_Type'Tag;
  3325.    --
  3326.    --  If it is a class-wide type we use the RT function CW_Membership which
  3327.    --  is usually implemented by looking in the ancestor tables contained in
  3328.    --  the dispatch table pointed by Left_Expr.Tag for Typ'Tag
  3329.  
  3330.    function Tagged_Membership (N : Node_Id) return Node_Id is
  3331.       Left  : constant Node_Id    := Left_Opnd  (N);
  3332.       Right : constant Node_Id    := Right_Opnd (N);
  3333.       Loc   : constant Source_Ptr := Sloc (N);
  3334.  
  3335.       Left_Type  : Entity_Id;
  3336.       Right_Type : Entity_Id;
  3337.       Obj_Tag    : Node_Id;
  3338.  
  3339.    begin
  3340.       Left_Type  := Etype (Left);
  3341.       Right_Type := Etype (Right);
  3342.  
  3343.       if Is_Class_Wide_Type (Left_Type) then
  3344.          Left_Type := Root_Type (Left_Type);
  3345.       end if;
  3346.  
  3347.       Obj_Tag :=
  3348.         Make_Selected_Component (Loc,
  3349.           Prefix        => Relocate_Node (Left),
  3350.           Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
  3351.  
  3352.       if Is_Class_Wide_Type (Right_Type) then
  3353.          return
  3354.            Make_DT_Access_Action (Left_Type,
  3355.              Action => CW_Membership,
  3356.              Args   => New_List (
  3357.                Obj_Tag,
  3358.                New_Reference_To (
  3359.                  Access_Disp_Table (Root_Type (Right_Type)), Loc)));
  3360.       else
  3361.          return
  3362.            Make_Op_Eq (Loc,
  3363.            Left_Opnd  => Obj_Tag,
  3364.            Right_Opnd =>
  3365.              New_Reference_To (Access_Disp_Table (Right_Type), Loc));
  3366.       end if;
  3367.  
  3368.    end Tagged_Membership;
  3369.  
  3370. end Exp_Ch4;
  3371.