Allow target to override gnu-user.h crti and crtn

[official-gcc.git] / gcc / ada / layout.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               L A Y O U T                                --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2001-2018, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Atree;    use Atree;
with Debug;    use Debug;
with Einfo;    use Einfo;
with Errout;   use Errout;
with Opt;      use Opt;
with Sem_Aux;  use Sem_Aux;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Snames;   use Snames;
with Ttypes;   use Ttypes;
with Uintp;    use Uintp;

package body Layout is

   ------------------------
   -- Local Declarations --
   ------------------------

   SSU : constant Int := Ttypes.System_Storage_Unit;
   --  Short hand for System_Storage_Unit

   -----------------------
   -- Local Subprograms --
   -----------------------

   procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id);
   --  Given an array type or an array subtype E, compute whether its size
   --  depends on the value of one or more discriminants and set the flag
   --  Size_Depends_On_Discriminant accordingly. This need not be called
   --  in front end layout mode since it does the computation on its own.

   procedure Set_Composite_Alignment (E : Entity_Id);
   --  This procedure is called for record types and subtypes, and also for
   --  atomic array types and subtypes. If no alignment is set, and the size
   --  is 2 or 4 (or 8 if the word size is 8), then the alignment is set to
   --  match the size.

   ----------------------------
   -- Adjust_Esize_Alignment --
   ----------------------------

   procedure Adjust_Esize_Alignment (E : Entity_Id) is
      Abits     : Int;
      Esize_Set : Boolean;

   begin
      --  Nothing to do if size unknown

      if Unknown_Esize (E) then
         return;
      end if;

      --  Determine if size is constrained by an attribute definition clause
      --  which must be obeyed. If so, we cannot increase the size in this
      --  routine.

      --  For a type, the issue is whether an object size clause has been set.
      --  A normal size clause constrains only the value size (RM_Size)

      if Is_Type (E) then
         Esize_Set := Has_Object_Size_Clause (E);

      --  For an object, the issue is whether a size clause is present

      else
         Esize_Set := Has_Size_Clause (E);
      end if;

      --  If size is known it must be a multiple of the storage unit size

      if Esize (E) mod SSU /= 0 then

         --  If not, and size specified, then give error

         if Esize_Set then
            Error_Msg_NE
              ("size for& not a multiple of storage unit size",
               Size_Clause (E), E);
            return;

         --  Otherwise bump up size to a storage unit boundary

         else
            Set_Esize (E, (Esize (E) + SSU - 1) / SSU * SSU);
         end if;
      end if;

      --  Now we have the size set, it must be a multiple of the alignment
      --  nothing more we can do here if the alignment is unknown here.

      if Unknown_Alignment (E) then
         return;
      end if;

      --  At this point both the Esize and Alignment are known, so we need
      --  to make sure they are consistent.

      Abits := UI_To_Int (Alignment (E)) * SSU;

      if Esize (E) mod Abits = 0 then
         return;
      end if;

      --  Here we have a situation where the Esize is not a multiple of the
      --  alignment. We must either increase Esize or reduce the alignment to
      --  correct this situation.

      --  The case in which we can decrease the alignment is where the
      --  alignment was not set by an alignment clause, and the type in
      --  question is a discrete type, where it is definitely safe to reduce
      --  the alignment. For example:

      --    t : integer range 1 .. 2;
      --    for t'size use 8;

      --  In this situation, the initial alignment of t is 4, copied from
      --  the Integer base type, but it is safe to reduce it to 1 at this
      --  stage, since we will only be loading a single storage unit.

      if Is_Discrete_Type (Etype (E)) and then not Has_Alignment_Clause (E)
      then
         loop
            Abits := Abits / 2;
            exit when Esize (E) mod Abits = 0;
         end loop;

         Init_Alignment (E, Abits / SSU);
         return;
      end if;

      --  Now the only possible approach left is to increase the Esize but we
      --  can't do that if the size was set by a specific clause.

      if Esize_Set then
         Error_Msg_NE
           ("size for& is not a multiple of alignment",
            Size_Clause (E), E);

      --  Otherwise we can indeed increase the size to a multiple of alignment

      else
         Set_Esize (E, ((Esize (E) + (Abits - 1)) / Abits) * Abits);
      end if;
   end Adjust_Esize_Alignment;

   ------------------------------------------
   -- Compute_Size_Depends_On_Discriminant --
   ------------------------------------------

   procedure Compute_Size_Depends_On_Discriminant (E : Entity_Id) is
      Indx : Node_Id;
      Ityp : Entity_Id;
      Lo   : Node_Id;
      Hi   : Node_Id;
      Res  : Boolean := False;

   begin
      --  Loop to process array indexes

      Indx := First_Index (E);
      while Present (Indx) loop
         Ityp := Etype (Indx);

         --  If an index of the array is a generic formal type then there is
         --  no point in determining a size for the array type.

         if Is_Generic_Type (Ityp) then
            return;
         end if;

         Lo := Type_Low_Bound (Ityp);
         Hi := Type_High_Bound (Ityp);

         if (Nkind (Lo) = N_Identifier
              and then Ekind (Entity (Lo)) = E_Discriminant)
           or else
            (Nkind (Hi) = N_Identifier
              and then Ekind (Entity (Hi)) = E_Discriminant)
         then
            Res := True;
         end if;

         Next_Index (Indx);
      end loop;

      if Res then
         Set_Size_Depends_On_Discriminant (E);
      end if;
   end Compute_Size_Depends_On_Discriminant;

   -------------------
   -- Layout_Object --
   -------------------

   procedure Layout_Object (E : Entity_Id) is
      pragma Unreferenced (E);
   begin
      --  Nothing to do for now, assume backend does the layout

      return;
   end Layout_Object;

   -----------------
   -- Layout_Type --
   -----------------

   procedure Layout_Type (E : Entity_Id) is
      Desig_Type : Entity_Id;

   begin
      --  For string literal types, for now, kill the size always, this is
      --  because gigi does not like or need the size to be set ???

      if Ekind (E) = E_String_Literal_Subtype then
         Set_Esize (E, Uint_0);
         Set_RM_Size (E, Uint_0);
         return;
      end if;

      --  For access types, set size/alignment. This is system address size,
      --  except for fat pointers (unconstrained array access types), where the
      --  size is two times the address size, to accommodate the two pointers
      --  that are required for a fat pointer (data and template). Note that
      --  E_Access_Protected_Subprogram_Type is not an access type for this
      --  purpose since it is not a pointer but is equivalent to a record. For
      --  access subtypes, copy the size from the base type since Gigi
      --  represents them the same way.

      if Is_Access_Type (E) then
         Desig_Type := Underlying_Type (Designated_Type (E));

         --  If we only have a limited view of the type, see whether the
         --  non-limited view is available.

         if From_Limited_With (Designated_Type (E))
           and then Ekind (Designated_Type (E)) = E_Incomplete_Type
           and then Present (Non_Limited_View (Designated_Type (E)))
         then
            Desig_Type := Non_Limited_View (Designated_Type (E));
         end if;

         --  If Esize already set (e.g. by a size clause), then nothing further
         --  to be done here.

         if Known_Esize (E) then
            null;

         --  Access to subprogram is a strange beast, and we let the backend
         --  figure out what is needed (it may be some kind of fat pointer,
         --  including the static link for example.

         elsif Is_Access_Protected_Subprogram_Type (E) then
            null;

         --  For access subtypes, copy the size information from base type

         elsif Ekind (E) = E_Access_Subtype then
            Set_Size_Info (E, Base_Type (E));
            Set_RM_Size   (E, RM_Size (Base_Type (E)));

         --  For other access types, we use either address size, or, if a fat
         --  pointer is used (pointer-to-unconstrained array case), twice the
         --  address size to accommodate a fat pointer.

         elsif Present (Desig_Type)
           and then Is_Array_Type (Desig_Type)
           and then not Is_Constrained (Desig_Type)
           and then not Has_Completion_In_Body (Desig_Type)

           --  Debug Flag -gnatd6 says make all pointers to unconstrained thin

           and then not Debug_Flag_6
         then
            Init_Size (E, 2 * System_Address_Size);

            --  Check for bad convention set

            if Warn_On_Export_Import
              and then
                (Convention (E) = Convention_C
                   or else
                 Convention (E) = Convention_CPP)
            then
               Error_Msg_N
                 ("?x?this access type does not correspond to C pointer", E);
            end if;

         --  If the designated type is a limited view it is unanalyzed. We can
         --  examine the declaration itself to determine whether it will need a
         --  fat pointer.

         elsif Present (Desig_Type)
           and then Present (Parent (Desig_Type))
           and then Nkind (Parent (Desig_Type)) = N_Full_Type_Declaration
           and then Nkind (Type_Definition (Parent (Desig_Type))) =
                                             N_Unconstrained_Array_Definition
           and then not Debug_Flag_6
         then
            Init_Size (E, 2 * System_Address_Size);

         --  If unnesting subprograms, subprogram access types contain the
         --  address of both the subprogram and an activation record. But if we
         --  set that, we'll get a warning on different unchecked conversion
         --  sizes in the RTS. So leave unset in that case.

         elsif Unnest_Subprogram_Mode
           and then Is_Access_Subprogram_Type (E)
         then
            null;

         --  Normal case of thin pointer

         else
            Init_Size (E, System_Address_Size);
         end if;

         Set_Elem_Alignment (E);

      --  Scalar types: set size and alignment

      elsif Is_Scalar_Type (E) then

         --  For discrete types, the RM_Size and Esize must be set already,
         --  since this is part of the earlier processing and the front end is
         --  always required to lay out the sizes of such types (since they are
         --  available as static attributes). All we do is to check that this
         --  rule is indeed obeyed.

         if Is_Discrete_Type (E) then

            --  If the RM_Size is not set, then here is where we set it

            --  Note: an RM_Size of zero looks like not set here, but this
            --  is a rare case, and we can simply reset it without any harm.

            if not Known_RM_Size (E) then
               Set_Discrete_RM_Size (E);
            end if;

            --  If Esize for a discrete type is not set then set it

            if not Known_Esize (E) then
               declare
                  S : Int := 8;

               begin
                  loop
                     --  If size is big enough, set it and exit

                     if S >= RM_Size (E) then
                        Init_Esize (E, S);
                        exit;

                     --  If the RM_Size is greater than 64 (happens only when
                     --  strange values are specified by the user, then Esize
                     --  is simply a copy of RM_Size, it will be further
                     --  refined later on)

                     elsif S = 64 then
                        Set_Esize (E, RM_Size (E));
                        exit;

                     --  Otherwise double possible size and keep trying

                     else
                        S := S * 2;
                     end if;
                  end loop;
               end;
            end if;

         --  For non-discrete scalar types, if the RM_Size is not set, then set
         --  it now to a copy of the Esize if the Esize is set.

         else
            if Known_Esize (E) and then Unknown_RM_Size (E) then
               Set_RM_Size (E, Esize (E));
            end if;
         end if;

         Set_Elem_Alignment (E);

      --  Non-elementary (composite) types

      else
         --  For packed arrays, take size and alignment values from the packed
         --  array type if a packed array type has been created and the fields
         --  are not currently set.

         if Is_Array_Type (E)
           and then Present (Packed_Array_Impl_Type (E))
         then
            declare
               PAT : constant Entity_Id := Packed_Array_Impl_Type (E);

            begin
               if Unknown_Esize (E) then
                  Set_Esize     (E, Esize     (PAT));
               end if;

               if Unknown_RM_Size (E) then
                  Set_RM_Size   (E, RM_Size   (PAT));
               end if;

               if Unknown_Alignment (E) then
                  Set_Alignment (E, Alignment (PAT));
               end if;
            end;
         end if;

         --  If Esize is set, and RM_Size is not, RM_Size is copied from Esize.
         --  At least for now this seems reasonable, and is in any case needed
         --  for compatibility with old versions of gigi.

         if Known_Esize (E) and then Unknown_RM_Size (E) then
            Set_RM_Size (E, Esize (E));
         end if;

         --  For array base types, set component size if object size of the
         --  component type is known and is a small power of 2 (8, 16, 32, 64),
         --  since this is what will always be used.

         if Ekind (E) = E_Array_Type and then Unknown_Component_Size (E) then
            declare
               CT : constant Entity_Id := Component_Type (E);

            begin
               --  For some reason, access types can cause trouble, So let's
               --  just do this for scalar types ???

               if Present (CT)
                 and then Is_Scalar_Type (CT)
                 and then Known_Static_Esize (CT)
               then
                  declare
                     S : constant Uint := Esize (CT);
                  begin
                     if Addressable (S) then
                        Set_Component_Size (E, S);
                     end if;
                  end;
               end if;
            end;
         end if;
      end if;

      --  Even if the backend performs the layout, we still do a little in
      --  the front end

      --  Processing for record types

      if Is_Record_Type (E) then

         --  Special remaining processing for record types with a known
         --  size of 16, 32, or 64 bits whose alignment is not yet set.
         --  For these types, we set a corresponding alignment matching
         --  the size if possible, or as large as possible if not.

         if Convention (E) = Convention_Ada and then not Debug_Flag_Q then
            Set_Composite_Alignment (E);
         end if;

      --  Processing for array types

      elsif Is_Array_Type (E) then

         --  For arrays that are required to be atomic/VFA, we do the same
         --  processing as described above for short records, since we
         --  really need to have the alignment set for the whole array.

         if Is_Atomic_Or_VFA (E) and then not Debug_Flag_Q then
            Set_Composite_Alignment (E);
         end if;

         --  For unpacked array types, set an alignment of 1 if we know
         --  that the component alignment is not greater than 1. The reason
         --  we do this is to avoid unnecessary copying of slices of such
         --  arrays when passed to subprogram parameters (see special test
         --  in Exp_Ch6.Expand_Actuals).

         if not Is_Packed (E) and then Unknown_Alignment (E) then
            if Known_Static_Component_Size (E)
              and then Component_Size (E) = 1
            then
               Set_Alignment (E, Uint_1);
            end if;
         end if;

         --  We need to know whether the size depends on the value of one
         --  or more discriminants to select the return mechanism. Skip if
         --  errors are present, to prevent cascaded messages.

         if Serious_Errors_Detected = 0 then
            Compute_Size_Depends_On_Discriminant (E);
         end if;
      end if;

      --  Final step is to check that Esize and RM_Size are compatible

      if Known_Static_Esize (E) and then Known_Static_RM_Size (E) then
         if Esize (E) < RM_Size (E) then

            --  Esize is less than RM_Size. That's not good. First we test
            --  whether this was set deliberately with an Object_Size clause
            --  and if so, object to the clause.

            if Has_Object_Size_Clause (E) then
               Error_Msg_Uint_1 := RM_Size (E);
               Error_Msg_F
                 ("object size is too small, minimum allowed is ^",
                  Expression (Get_Attribute_Definition_Clause
                                             (E, Attribute_Object_Size)));
            end if;

            --  Adjust Esize up to RM_Size value

            declare
               Size : constant Uint := RM_Size (E);

            begin
               Set_Esize (E, RM_Size (E));

               --  For scalar types, increase Object_Size to power of 2, but
               --  not less than a storage unit in any case (i.e., normally
               --  this means it will be storage-unit addressable).

               if Is_Scalar_Type (E) then
                  if Size <= SSU then
                     Init_Esize (E, SSU);
                  elsif Size <= 16 then
                     Init_Esize (E, 16);
                  elsif Size <= 32 then
                     Init_Esize (E, 32);
                  else
                     Set_Esize  (E, (Size + 63) / 64 * 64);
                  end if;

                  --  Finally, make sure that alignment is consistent with
                  --  the newly assigned size.

                  while Alignment (E) * SSU < Esize (E)
                    and then Alignment (E) < Maximum_Alignment
                  loop
                     Set_Alignment (E, 2 * Alignment (E));
                  end loop;
               end if;
            end;
         end if;
      end if;
   end Layout_Type;

   -----------------------------
   -- Set_Composite_Alignment --
   -----------------------------

   procedure Set_Composite_Alignment (E : Entity_Id) is
      Siz   : Uint;
      Align : Nat;

   begin
      --  If alignment is already set, then nothing to do

      if Known_Alignment (E) then
         return;
      end if;

      --  Alignment is not known, see if we can set it, taking into account
      --  the setting of the Optimize_Alignment mode.

      --  If Optimize_Alignment is set to Space, then we try to give packed
      --  records an aligmment of 1, unless there is some reason we can't.

      if Optimize_Alignment_Space (E)
        and then Is_Record_Type (E)
        and then Is_Packed (E)
      then
         --  No effect for record with atomic/VFA components

         if Is_Atomic_Or_VFA (E) then
            Error_Msg_N ("Optimize_Alignment has no effect for &??", E);

            if Is_Atomic (E) then
               Error_Msg_N
                 ("\pragma ignored for atomic record??", E);
            else
               Error_Msg_N
                 ("\pragma ignored for bolatile full access record??", E);
            end if;

            return;
         end if;

         --  No effect if independent components

         if Has_Independent_Components (E) then
            Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
            Error_Msg_N
              ("\pragma ignored for record with independent components??", E);
            return;
         end if;

         --  No effect if any component is atomic/VFA or is a by-reference type

         declare
            Ent : Entity_Id;

         begin
            Ent := First_Component_Or_Discriminant (E);
            while Present (Ent) loop
               if Is_By_Reference_Type (Etype (Ent))
                 or else Is_Atomic_Or_VFA (Etype (Ent))
                 or else Is_Atomic_Or_VFA (Ent)
               then
                  Error_Msg_N ("Optimize_Alignment has no effect for &??", E);

                  if Is_Atomic (Etype (Ent)) or else Is_Atomic (Ent) then
                     Error_Msg_N
                       ("\pragma is ignored if atomic "
                        & "components present??", E);
                  else
                     Error_Msg_N
                       ("\pragma is ignored if bolatile full access "
                        & "components present??", E);
                  end if;

                  return;
               else
                  Next_Component_Or_Discriminant (Ent);
               end if;
            end loop;
         end;

         --  Optimize_Alignment has no effect on variable length record

         if not Size_Known_At_Compile_Time (E) then
            Error_Msg_N ("Optimize_Alignment has no effect for &??", E);
            Error_Msg_N ("\pragma is ignored for variable length record??", E);
            return;
         end if;

         --  All tests passed, we can set alignment to 1

         Align := 1;

      --  Not a record, or not packed

      else
         --  The only other cases we worry about here are where the size is
         --  statically known at compile time.

         if Known_Static_Esize (E) then
            Siz := Esize (E);
         elsif Unknown_Esize (E) and then Known_Static_RM_Size (E) then
            Siz := RM_Size (E);
         else
            return;
         end if;

         --  Size is known, alignment is not set

         --  Reset alignment to match size if the known size is exactly 2, 4,
         --  or 8 storage units.

         if Siz = 2 * SSU then
            Align := 2;
         elsif Siz = 4 * SSU then
            Align := 4;
         elsif Siz = 8 * SSU then
            Align := 8;

            --  If Optimize_Alignment is set to Space, then make sure the
            --  alignment matches the size, for example, if the size is 17
            --  bytes then we want an alignment of 1 for the type.

         elsif Optimize_Alignment_Space (E) then
            if Siz mod (8 * SSU) = 0 then
               Align := 8;
            elsif Siz mod (4 * SSU) = 0 then
               Align := 4;
            elsif Siz mod (2 * SSU) = 0 then
               Align := 2;
            else
               Align := 1;
            end if;

            --  If Optimize_Alignment is set to Time, then we reset for odd
            --  "in between sizes", for example a 17 bit record is given an
            --  alignment of 4.

         elsif Optimize_Alignment_Time (E)
           and then Siz > SSU
           and then Siz <= 8 * SSU
         then
            if Siz <= 2 * SSU then
               Align := 2;
            elsif Siz <= 4 * SSU then
               Align := 4;
            else -- Siz <= 8 * SSU then
               Align := 8;
            end if;

            --  No special alignment fiddling needed

         else
            return;
         end if;
      end if;

      --  Here we have Set Align to the proposed improved value. Make sure the
      --  value set does not exceed Maximum_Alignment for the target.

      if Align > Maximum_Alignment then
         Align := Maximum_Alignment;
      end if;

      --  Further processing for record types only to reduce the alignment
      --  set by the above processing in some specific cases. We do not
      --  do this for atomic/VFA records, since we need max alignment there,

      if Is_Record_Type (E) and then not Is_Atomic_Or_VFA (E) then

         --  For records, there is generally no point in setting alignment
         --  higher than word size since we cannot do better than move by
         --  words in any case. Omit this if we are optimizing for time,
         --  since conceivably we may be able to do better.

         if Align > System_Word_Size / SSU
           and then not Optimize_Alignment_Time (E)
         then
            Align := System_Word_Size / SSU;
         end if;

         --  Check components. If any component requires a higher alignment,
         --  then we set that higher alignment in any case. Don't do this if
         --  we have Optimize_Alignment set to Space. Note that that covers
         --  the case of packed records, where we already set alignment to 1.

         if not Optimize_Alignment_Space (E) then
            declare
               Comp : Entity_Id;

            begin
               Comp := First_Component (E);
               while Present (Comp) loop
                  if Known_Alignment (Etype (Comp)) then
                     declare
                        Calign : constant Uint := Alignment (Etype (Comp));

                     begin
                        --  The cases to process are when the alignment of the
                        --  component type is larger than the alignment we have
                        --  so far, and either there is no component clause for
                        --  the component, or the length set by the component
                        --  clause matches the length of the component type.

                        if Calign > Align
                          and then
                            (Unknown_Esize (Comp)
                              or else (Known_Static_Esize (Comp)
                                        and then
                                       Esize (Comp) = Calign * SSU))
                        then
                           Align := UI_To_Int (Calign);
                        end if;
                     end;
                  end if;

                  Next_Component (Comp);
               end loop;
            end;
         end if;
      end if;

      --  Set chosen alignment, and increase Esize if necessary to match the
      --  chosen alignment.

      Set_Alignment (E, UI_From_Int (Align));

      if Known_Static_Esize (E)
        and then Esize (E) < Align * SSU
      then
         Set_Esize (E, UI_From_Int (Align * SSU));
      end if;
   end Set_Composite_Alignment;

   --------------------------
   -- Set_Discrete_RM_Size --
   --------------------------

   procedure Set_Discrete_RM_Size (Def_Id : Entity_Id) is
      FST : constant Entity_Id := First_Subtype (Def_Id);

   begin
      --  All discrete types except for the base types in standard are
      --  constrained, so indicate this by setting Is_Constrained.

      Set_Is_Constrained (Def_Id);

      --  Set generic types to have an unknown size, since the representation
      --  of a generic type is irrelevant, in view of the fact that they have
      --  nothing to do with code.

      if Is_Generic_Type (Root_Type (FST)) then
         Set_RM_Size (Def_Id, Uint_0);

      --  If the subtype statically matches the first subtype, then it is
      --  required to have exactly the same layout. This is required by
      --  aliasing considerations.

      elsif Def_Id /= FST and then
        Subtypes_Statically_Match (Def_Id, FST)
      then
         Set_RM_Size   (Def_Id, RM_Size (FST));
         Set_Size_Info (Def_Id, FST);

      --  In all other cases the RM_Size is set to the minimum size. Note that
      --  this routine is never called for subtypes for which the RM_Size is
      --  set explicitly by an attribute clause.

      else
         Set_RM_Size (Def_Id, UI_From_Int (Minimum_Size (Def_Id)));
      end if;
   end Set_Discrete_RM_Size;

   ------------------------
   -- Set_Elem_Alignment --
   ------------------------

   procedure Set_Elem_Alignment (E : Entity_Id; Align : Nat := 0) is
   begin
      --  Do not set alignment for packed array types, this is handled in the
      --  backend.

      if Is_Packed_Array_Impl_Type (E) then
         return;

      --  If there is an alignment clause, then we respect it

      elsif Has_Alignment_Clause (E) then
         return;

      --  If the size is not set, then don't attempt to set the alignment. This
      --  happens in the backend layout case for access-to-subprogram types.

      elsif not Known_Static_Esize (E) then
         return;

      --  For access types, do not set the alignment if the size is less than
      --  the allowed minimum size. This avoids cascaded error messages.

      elsif Is_Access_Type (E) and then Esize (E) < System_Address_Size then
         return;
      end if;

      --  We attempt to set the alignment in all the other cases

      declare
         S : Int;
         A : Nat;
         M : Nat;

      begin
         --  The given Esize may be larger that int'last because of a previous
         --  error, and the call to UI_To_Int will fail, so use default.

         if Esize (E) / SSU > Ttypes.Maximum_Alignment then
            S := Ttypes.Maximum_Alignment;

         --  If this is an access type and the target doesn't have strict
         --  alignment, then cap the alignment to that of a regular access
         --  type. This will avoid giving fat pointers twice the usual
         --  alignment for no practical benefit since the misalignment doesn't
         --  really matter.

         elsif Is_Access_Type (E)
           and then not Target_Strict_Alignment
         then
            S := System_Address_Size / SSU;

         else
            S := UI_To_Int (Esize (E)) / SSU;
         end if;

         --  If the default alignment of "double" floating-point types is
         --  specifically capped, enforce the cap.

         if Ttypes.Target_Double_Float_Alignment > 0
           and then S = 8
           and then Is_Floating_Point_Type (E)
         then
            M := Ttypes.Target_Double_Float_Alignment;

         --  If the default alignment of "double" or larger scalar types is
         --  specifically capped, enforce the cap.

         elsif Ttypes.Target_Double_Scalar_Alignment > 0
           and then S >= 8
           and then Is_Scalar_Type (E)
         then
            M := Ttypes.Target_Double_Scalar_Alignment;

         --  Otherwise enforce the overall alignment cap

         else
            M := Ttypes.Maximum_Alignment;
         end if;

         --  We calculate the alignment as the largest power-of-two multiple
         --  of System.Storage_Unit that does not exceed the object size of
         --  the type and the maximum allowed alignment, if none was specified.
         --  Otherwise we only cap it to the maximum allowed alignment.

         if Align = 0 then
            A := 1;
            while 2 * A <= S and then 2 * A <= M loop
               A := 2 * A;
            end loop;
         else
            A := Nat'Min (Align, M);
         end if;

         --  If alignment is currently not set, then we can safely set it to
         --  this new calculated value.

         if Unknown_Alignment (E) then
            Init_Alignment (E, A);

         --  Cases where we have inherited an alignment

         --  For constructed types, always reset the alignment, these are
         --  generally invisible to the user anyway, and that way we are
         --  sure that no constructed types have weird alignments.

         elsif not Comes_From_Source (E) then
            Init_Alignment (E, A);

         --  If this inherited alignment is the same as the one we computed,
         --  then obviously everything is fine, and we do not need to reset it.

         elsif Alignment (E) = A then
            null;

         else
            --  Now we come to the difficult cases of subtypes for which we
            --  have inherited an alignment different from the computed one.
            --  We resort to the presence of alignment and size clauses to
            --  guide our choices. Note that they can generally be present
            --  only on the first subtype (except for Object_Size) and that
            --  we need to look at the Rep_Item chain to correctly handle
            --  derived types.

            declare
               FST : constant Entity_Id := First_Subtype (E);

               function Has_Attribute_Clause
                 (E  : Entity_Id;
                  Id : Attribute_Id) return Boolean;
               --  Wrapper around Get_Attribute_Definition_Clause which tests
               --  for the presence of the specified attribute clause.

               --------------------------
               -- Has_Attribute_Clause --
               --------------------------

               function Has_Attribute_Clause
                 (E  : Entity_Id;
                  Id : Attribute_Id) return Boolean is
               begin
                  return Present (Get_Attribute_Definition_Clause (E, Id));
               end Has_Attribute_Clause;

            begin
               --  If the alignment comes from a clause, then we respect it.
               --  Consider for example:

               --    type R is new Character;
               --    for R'Alignment use 1;
               --    for R'Size use 16;
               --    subtype S is R;

               --  Here R has a specified size of 16 and a specified alignment
               --  of 1, and it seems right for S to inherit both values.

               if Has_Attribute_Clause (FST, Attribute_Alignment) then
                  null;

               --  Now we come to the cases where we have inherited alignment
               --  and size, and overridden the size but not the alignment.

               elsif Has_Attribute_Clause (FST, Attribute_Size)
                 or else Has_Attribute_Clause (FST, Attribute_Object_Size)
                 or else Has_Attribute_Clause (E, Attribute_Object_Size)
               then
                  --  This is tricky, it might be thought that we should try to
                  --  inherit the alignment, since that's what the RM implies,
                  --  but that leads to complex rules and oddities. Consider
                  --  for example:

                  --    type R is new Character;
                  --    for R'Size use 16;

                  --  It seems quite bogus in this case to inherit an alignment
                  --  of 1 from the parent type Character. Furthermore, if that
                  --  is what the programmer really wanted for some odd reason,
                  --  then he could specify the alignment directly.

                  --  Moreover we really don't want to inherit the alignment in
                  --  the case of a specified Object_Size for a subtype, since
                  --  there would be no way of overriding to give a reasonable
                  --  value (as we don't have an Object_Alignment attribute).
                  --  Consider for example:

                  --    subtype R is Character;
                  --    for R'Object_Size use 16;

                  --  If we inherit the alignment of 1, then it will be very
                  --  inefficient for the subtype and this cannot be fixed.

                  --  So we make the decision that if Size (or Object_Size) is
                  --  given and the alignment is not specified with a clause,
                  --  we reset the alignment to the appropriate value for the
                  --  specified size. This is a nice simple rule to implement
                  --  and document.

                  --  There is a theoretical glitch, which is that a confirming
                  --  size clause could now change the alignment, which, if we
                  --  really think that confirming rep clauses should have no
                  --  effect, could be seen as a no-no. However that's already
                  --  implemented by Alignment_Check_For_Size_Change so we do
                  --  not change the philosophy here.

                  --  Historical note: in versions prior to Nov 6th, 2011, an
                  --  odd distinction was made between inherited alignments
                  --  larger than the computed alignment (where the larger
                  --  alignment was inherited) and inherited alignments smaller
                  --  than the computed alignment (where the smaller alignment
                  --  was overridden). This was a dubious fix to get around an
                  --  ACATS problem which seems to have disappeared anyway, and
                  --  in any case, this peculiarity was never documented.

                  Init_Alignment (E, A);

               --  If no Size (or Object_Size) was specified, then we have
               --  inherited the object size, so we should also inherit the
               --  alignment and not modify it.

               else
                  null;
               end if;
            end;
         end if;
      end;
   end Set_Elem_Alignment;

end Layout;