Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             S E M _ C H 1 3                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1992-2012, 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 Aspects;  use Aspects;

with Atree;    use Atree;

with Checks;   use Checks;

with Einfo;    use Einfo;

with Elists;   use Elists;

with Errout;   use Errout;

with Exp_Disp; use Exp_Disp;

with Exp_Tss;  use Exp_Tss;

with Exp_Util; use Exp_Util;

with Lib;      use Lib;

with Lib.Xref; use Lib.Xref;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Nmake;    use Nmake;

with Opt;      use Opt;

with Restrict; use Restrict;

with Rident;   use Rident;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Aux;  use Sem_Aux;

with Sem_Ch3;  use Sem_Ch3;

with Sem_Ch6;  use Sem_Ch6;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Dim;  use Sem_Dim;

with Sem_Eval; use Sem_Eval;

with Sem_Res;  use Sem_Res;

with Sem_Type; use Sem_Type;

with Sem_Util; use Sem_Util;

with Sem_Warn; use Sem_Warn;

with Sinput;   use Sinput;

with Snames;   use Snames;

with Stand;    use Stand;

with Sinfo;    use Sinfo;

with Stringt;  use Stringt;

with Targparm; use Targparm;

with Ttypes;   use Ttypes;

with Tbuild;   use Tbuild;

with Urealp;   use Urealp;

with Warnsw;   use Warnsw;

with GNAT.Heap_Sort_G;

package body Sem_Ch13 is

   SSU : constant Pos := System_Storage_Unit;

   --  Convenient short hand for commonly used constant

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);

   --  This routine is called after setting one of the sizes of type entity

   --  Typ to Size. The purpose is to deal with the situation of a derived

   --  type whose inherited alignment is no longer appropriate for the new

   --  size value. In this case, we reset the Alignment to unknown.

   procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id);

   --  If Typ has predicates (indicated by Has_Predicates being set for Typ,

   --  then either there are pragma Invariant entries on the rep chain for the

   --  type (note that Predicate aspects are converted to pragma Predicate), or

   --  there are inherited aspects from a parent type, or ancestor subtypes.

   --  This procedure builds the spec and body for the Predicate function that

   --  tests these predicates. N is the freeze node for the type. The spec of

   --  the function is inserted before the freeze node, and the body of the

   --  function is inserted after the freeze node.

   procedure Build_Static_Predicate

     (Typ  : Entity_Id;

      Expr : Node_Id;

      Nam  : Name_Id);

   --  Given a predicated type Typ, where Typ is a discrete static subtype,

   --  whose predicate expression is Expr, tests if Expr is a static predicate,

   --  and if so, builds the predicate range list. Nam is the name of the one

   --  argument to the predicate function. Occurrences of the type name in the

   --  predicate expression have been replaced by identifier references to this

   --  name, which is unique, so any identifier with Chars matching Nam must be

   --  a reference to the type. If the predicate is non-static, this procedure

   --  returns doing nothing. If the predicate is static, then the predicate

   --  list is stored in Static_Predicate (Typ), and the Expr is rewritten as

   --  a canonicalized membership operation.

   function Get_Alignment_Value (Expr : Node_Id) return Uint;

   --  Given the expression for an alignment value, returns the corresponding

   --  Uint value. If the value is inappropriate, then error messages are

   --  posted as required, and a value of No_Uint is returned.

   function Is_Operational_Item (N : Node_Id) return Boolean;

   --  A specification for a stream attribute is allowed before the full type

   --  is declared, as explained in AI-00137 and the corrigendum. Attributes

   --  that do not specify a representation characteristic are operational

   --  attributes.

   procedure New_Stream_Subprogram

     (N    : Node_Id;

      Ent  : Entity_Id;

      Subp : Entity_Id;

      Nam  : TSS_Name_Type);

   --  Create a subprogram renaming of a given stream attribute to the

   --  designated subprogram and then in the tagged case, provide this as a

   --  primitive operation, or in the non-tagged case make an appropriate TSS

   --  entry. This is more properly an expansion activity than just semantics,

   --  but the presence of user-defined stream functions for limited types is a

   --  legality check, which is why this takes place here rather than in

   --  exp_ch13, where it was previously. Nam indicates the name of the TSS

   --  function to be generated.

   --

   --  To avoid elaboration anomalies with freeze nodes, for untagged types

   --  we generate both a subprogram declaration and a subprogram renaming

   --  declaration, so that the attribute specification is handled as a

   --  renaming_as_body. For tagged types, the specification is one of the

   --  primitive specs.

   generic

      with procedure Replace_Type_Reference (N : Node_Id);

   procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id);

   --  This is used to scan an expression for a predicate or invariant aspect

   --  replacing occurrences of the name TName (the name of the subtype to

   --  which the aspect applies) with appropriate references to the parameter

   --  of the predicate function or invariant procedure. The procedure passed

   --  as a generic parameter does the actual replacement of node N, which is

   --  either a simple direct reference to TName, or a selected component that

   --  represents an appropriately qualified occurrence of TName.

   procedure Set_Biased

     (E      : Entity_Id;

      N      : Node_Id;

      Msg    : String;

      Biased : Boolean := True);

   --  If Biased is True, sets Has_Biased_Representation flag for E, and

   --  outputs a warning message at node N if Warn_On_Biased_Representation is

   --  is True. This warning inserts the string Msg to describe the construct

   --  causing biasing.

   ----------------------------------------------

   -- Table for Validate_Unchecked_Conversions --

   ----------------------------------------------

   --  The following table collects unchecked conversions for validation.

   --  Entries are made by Validate_Unchecked_Conversion and then the call

   --  to Validate_Unchecked_Conversions does the actual error checking and

   --  posting of warnings. The reason for this delayed processing is to take

   --  advantage of back-annotations of size and alignment values performed by

   --  the back end.

   --  Note: the reason we store a Source_Ptr value instead of a Node_Id is

   --  that by the time Validate_Unchecked_Conversions is called, Sprint will

   --  already have modified all Sloc values if the -gnatD option is set.

   type UC_Entry is record

      Eloc   : Source_Ptr; -- node used for posting warnings

      Source : Entity_Id;  -- source type for unchecked conversion

      Target : Entity_Id;  -- target type for unchecked conversion

   end record;

   package Unchecked_Conversions is new Table.Table (

     Table_Component_Type => UC_Entry,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 1,

     Table_Initial        => 50,

     Table_Increment      => 200,

     Table_Name           => "Unchecked_Conversions");

   ----------------------------------------

   -- Table for Validate_Address_Clauses --

   ----------------------------------------

   --  If an address clause has the form

   --    for X'Address use Expr

   --  where Expr is of the form Y'Address or recursively is a reference to a

   --  constant of either of these forms, and X and Y are entities of objects,

   --  then if Y has a smaller alignment than X, that merits a warning about

   --  possible bad alignment. The following table collects address clauses of

   --  this kind. We put these in a table so that they can be checked after the

   --  back end has completed annotation of the alignments of objects, since we

   --  can catch more cases that way.

   type Address_Clause_Check_Record is record

      N : Node_Id;

      --  The address clause

      X : Entity_Id;

      --  The entity of the object overlaying Y

      Y : Entity_Id;

      --  The entity of the object being overlaid

      Off : Boolean;

      --  Whether the address is offset within Y

   end record;

   package Address_Clause_Checks is new Table.Table (

     Table_Component_Type => Address_Clause_Check_Record,

     Table_Index_Type     => Int,

     Table_Low_Bound      => 1,

     Table_Initial        => 20,

     Table_Increment      => 200,

     Table_Name           => "Address_Clause_Checks");

   -----------------------------------------

   -- Adjust_Record_For_Reverse_Bit_Order --

   -----------------------------------------

   procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is

      Comp : Node_Id;

      CC   : Node_Id;

   begin

      --  Processing depends on version of Ada

      --  For Ada 95, we just renumber bits within a storage unit. We do the

      --  same for Ada 83 mode, since we recognize the Bit_Order attribute in

      --  Ada 83, and are free to add this extension.

      if Ada_Version < Ada_2005 then

         Comp := First_Component_Or_Discriminant (R);

         while Present (Comp) loop

            CC := Component_Clause (Comp);

            --  If component clause is present, then deal with the non-default

            --  bit order case for Ada 95 mode.

            --  We only do this processing for the base type, and in fact that

            --  is important, since otherwise if there are record subtypes, we

            --  could reverse the bits once for each subtype, which is wrong.

            if Present (CC)

              and then Ekind (R) = E_Record_Type

            then

               declare

                  CFB : constant Uint    := Component_Bit_Offset (Comp);

                  CSZ : constant Uint    := Esize (Comp);

                  CLC : constant Node_Id := Component_Clause (Comp);

                  Pos : constant Node_Id := Position (CLC);

                  FB  : constant Node_Id := First_Bit (CLC);

                  Storage_Unit_Offset : constant Uint :=

                                          CFB / System_Storage_Unit;

                  Start_Bit : constant Uint :=

                                CFB mod System_Storage_Unit;

               begin

                  --  Cases where field goes over storage unit boundary

                  if Start_Bit + CSZ > System_Storage_Unit then

                     --  Allow multi-byte field but generate warning

                     if Start_Bit mod System_Storage_Unit = 0

                       and then CSZ mod System_Storage_Unit = 0

                     then

                        Error_Msg_N

                          ("multi-byte field specified with non-standard"

                           & " Bit_Order?", CLC);

                        if Bytes_Big_Endian then

                           Error_Msg_N

                             ("bytes are not reversed "

                              & "(component is big-endian)?", CLC);

                        else

                           Error_Msg_N

                             ("bytes are not reversed "

                              & "(component is little-endian)?", CLC);

                        end if;

                        --  Do not allow non-contiguous field

                     else

                        Error_Msg_N

                          ("attempt to specify non-contiguous field "

                           & "not permitted", CLC);

                        Error_Msg_N

                          ("\caused by non-standard Bit_Order "

                           & "specified", CLC);

                        Error_Msg_N

                          ("\consider possibility of using "

                           & "Ada 2005 mode here", CLC);

                     end if;

                  --  Case where field fits in one storage unit

                  else

                     --  Give warning if suspicious component clause

                     if Intval (FB) >= System_Storage_Unit

                       and then Warn_On_Reverse_Bit_Order

                     then

                        Error_Msg_N

                          ("?Bit_Order clause does not affect " &

                           "byte ordering", Pos);

                        Error_Msg_Uint_1 :=

                          Intval (Pos) + Intval (FB) /

                          System_Storage_Unit;

                        Error_Msg_N

                          ("?position normalized to ^ before bit " &

                           "order interpreted", Pos);

                     end if;

                     --  Here is where we fix up the Component_Bit_Offset value

                     --  to account for the reverse bit order. Some examples of

                     --  what needs to be done are:

                     --    First_Bit .. Last_Bit     Component_Bit_Offset

                     --      old          new          old       new

                     --     0 .. 0       7 .. 7         0         7

                     --     0 .. 1       6 .. 7         0         6

                     --     0 .. 2       5 .. 7         0         5

                     --     0 .. 7       0 .. 7         0         4

                     --     1 .. 1       6 .. 6         1         6

                     --     1 .. 4       3 .. 6         1         3

                     --     4 .. 7       0 .. 3         4         0

                     --  The rule is that the first bit is is obtained by

                     --  subtracting the old ending bit from storage_unit - 1.

                     Set_Component_Bit_Offset

                       (Comp,

                        (Storage_Unit_Offset * System_Storage_Unit) +

                          (System_Storage_Unit - 1) -

                          (Start_Bit + CSZ - 1));

                     Set_Normalized_First_Bit

                       (Comp,

                        Component_Bit_Offset (Comp) mod

                          System_Storage_Unit);

                  end if;

               end;

            end if;

            Next_Component_Or_Discriminant (Comp);

         end loop;

      --  For Ada 2005, we do machine scalar processing, as fully described In

      --  AI-133. This involves gathering all components which start at the

      --  same byte offset and processing them together. Same approach is still

      --  valid in later versions including Ada 2012.

      else

         declare

            Max_Machine_Scalar_Size : constant Uint :=

                                        UI_From_Int

                                          (Standard_Long_Long_Integer_Size);

            --  We use this as the maximum machine scalar size

            Num_CC : Natural;

            SSU    : constant Uint := UI_From_Int (System_Storage_Unit);

         begin

            --  This first loop through components does two things. First it

            --  deals with the case of components with component clauses whose

            --  length is greater than the maximum machine scalar size (either

            --  accepting them or rejecting as needed). Second, it counts the

            --  number of components with component clauses whose length does

            --  not exceed this maximum for later processing.

            Num_CC := 0;

            Comp   := First_Component_Or_Discriminant (R);

            while Present (Comp) loop

               CC := Component_Clause (Comp);

               if Present (CC) then

                  declare

                     Fbit : constant Uint :=

                              Static_Integer (First_Bit (CC));

                     Lbit : constant Uint :=

                              Static_Integer (Last_Bit (CC));

                  begin

                     --  Case of component with last bit >= max machine scalar

                     if Lbit >= Max_Machine_Scalar_Size then

                        --  This is allowed only if first bit is zero, and

                        --  last bit + 1 is a multiple of storage unit size.

                        if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then

                           --  This is the case to give a warning if enabled

                           if Warn_On_Reverse_Bit_Order then

                              Error_Msg_N

                                ("multi-byte field specified with "

                                 & "  non-standard Bit_Order?", CC);

                              if Bytes_Big_Endian then

                                 Error_Msg_N

                                   ("\bytes are not reversed "

                                    & "(component is big-endian)?", CC);

                              else

                                 Error_Msg_N

                                   ("\bytes are not reversed "

                                    & "(component is little-endian)?", CC);

                              end if;

                           end if;

                        --  Give error message for RM 13.4.1(10) violation

                        else

                           Error_Msg_FE

                             ("machine scalar rules not followed for&",

                              First_Bit (CC), Comp);

                           Error_Msg_Uint_1 := Lbit;

                           Error_Msg_Uint_2 := Max_Machine_Scalar_Size;

                           Error_Msg_F

                             ("\last bit (^) exceeds maximum machine "

                              & "scalar size (^)",

                              First_Bit (CC));

                           if (Lbit + 1) mod SSU /= 0 then

                              Error_Msg_Uint_1 := SSU;

                              Error_Msg_F

                                ("\and is not a multiple of Storage_Unit (^) "

                                 & "(RM 13.4.1(10))",

                                 First_Bit (CC));

                           else

                              Error_Msg_Uint_1 := Fbit;

                              Error_Msg_F

                                ("\and first bit (^) is non-zero "

                                 & "(RM 13.4.1(10))",

                                 First_Bit (CC));

                           end if;

                        end if;

                     --  OK case of machine scalar related component clause,

                     --  For now, just count them.

                     else

                        Num_CC := Num_CC + 1;

                     end if;

                  end;

               end if;

               Next_Component_Or_Discriminant (Comp);

            end loop;

            --  We need to sort the component clauses on the basis of the

            --  Position values in the clause, so we can group clauses with

            --  the same Position. together to determine the relevant machine

            --  scalar size.

            Sort_CC : declare

               Comps : array (0 .. Num_CC) of Entity_Id;

               --  Array to collect component and discriminant entities. The

               --  data starts at index 1, the 0'th entry is for the sort

               --  routine.

               function CP_Lt (Op1, Op2 : Natural) return Boolean;

               --  Compare routine for Sort

               procedure CP_Move (From : Natural; To : Natural);

               --  Move routine for Sort

               package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);

               Start : Natural;

               Stop  : Natural;

               --  Start and stop positions in the component list of the set of

               --  components with the same starting position (that constitute

               --  components in a single machine scalar).

               MaxL  : Uint;

               --  Maximum last bit value of any component in this set

               MSS   : Uint;

               --  Corresponding machine scalar size

               -----------

               -- CP_Lt --

               -----------

               function CP_Lt (Op1, Op2 : Natural) return Boolean is

               begin

                  return Position (Component_Clause (Comps (Op1))) <

                    Position (Component_Clause (Comps (Op2)));

               end CP_Lt;

               -------------

               -- CP_Move --

               -------------

               procedure CP_Move (From : Natural; To : Natural) is

               begin

                  Comps (To) := Comps (From);

               end CP_Move;

               --  Start of processing for Sort_CC

            begin

               --  Collect the machine scalar relevant component clauses

               Num_CC := 0;

               Comp   := First_Component_Or_Discriminant (R);

               while Present (Comp) loop

                  declare

                     CC   : constant Node_Id := Component_Clause (Comp);

                  begin

                     --  Collect only component clauses whose last bit is less

                     --  than machine scalar size. Any component clause whose

                     --  last bit exceeds this value does not take part in

                     --  machine scalar layout considerations. The test for

                     --  Error_Posted makes sure we exclude component clauses

                     --  for which we already posted an error.

                     if Present (CC)

                       and then not Error_Posted (Last_Bit (CC))

                       and then Static_Integer (Last_Bit (CC)) <

                                                    Max_Machine_Scalar_Size

                     then

                        Num_CC := Num_CC + 1;

                        Comps (Num_CC) := Comp;

                     end if;

                  end;

                  Next_Component_Or_Discriminant (Comp);

               end loop;

               --  Sort by ascending position number

               Sorting.Sort (Num_CC);

               --  We now have all the components whose size does not exceed

               --  the max machine scalar value, sorted by starting position.

               --  In this loop we gather groups of clauses starting at the

               --  same position, to process them in accordance with AI-133.

               Stop := 0;

               while Stop < Num_CC loop

                  Start := Stop + 1;

                  Stop  := Start;

                  MaxL  :=

                    Static_Integer

                      (Last_Bit (Component_Clause (Comps (Start))));

                  while Stop < Num_CC loop

                     if Static_Integer

                          (Position (Component_Clause (Comps (Stop + 1)))) =

                        Static_Integer

                          (Position (Component_Clause (Comps (Stop))))

                     then

                        Stop := Stop + 1;

                        MaxL :=

                          UI_Max

                            (MaxL,

                             Static_Integer

                               (Last_Bit

                                  (Component_Clause (Comps (Stop)))));

                     else

                        exit;

                     end if;

                  end loop;

                  --  Now we have a group of component clauses from Start to

                  --  Stop whose positions are identical, and MaxL is the

                  --  maximum last bit value of any of these components.

                  --  We need to determine the corresponding machine scalar

                  --  size. This loop assumes that machine scalar sizes are

                  --  even, and that each possible machine scalar has twice

                  --  as many bits as the next smaller one.

                  MSS := Max_Machine_Scalar_Size;

                  while MSS mod 2 = 0

                    and then (MSS / 2) >= SSU

                    and then (MSS / 2) > MaxL

                  loop

                     MSS := MSS / 2;

                  end loop;

                  --  Here is where we fix up the Component_Bit_Offset value

                  --  to account for the reverse bit order. Some examples of

                  --  what needs to be done for the case of a machine scalar

                  --  size of 8 are:

                  --    First_Bit .. Last_Bit     Component_Bit_Offset

                  --      old          new          old       new

                  --     0 .. 0       7 .. 7         0         7

                  --     0 .. 1       6 .. 7         0         6

                  --     0 .. 2       5 .. 7         0         5

                  --     0 .. 7       0 .. 7         0         4

                  --     1 .. 1       6 .. 6         1         6

                  --     1 .. 4       3 .. 6         1         3

                  --     4 .. 7       0 .. 3         4         0

                  --  The rule is that the first bit is obtained by subtracting

                  --  the old ending bit from machine scalar size - 1.

                  for C in Start .. Stop loop

                     declare

                        Comp : constant Entity_Id := Comps (C);

                        CC   : constant Node_Id   :=

                                 Component_Clause (Comp);

                        LB   : constant Uint :=

                                 Static_Integer (Last_Bit (CC));

                        NFB  : constant Uint := MSS - Uint_1 - LB;

                        NLB  : constant Uint := NFB + Esize (Comp) - 1;

                        Pos  : constant Uint :=

                                 Static_Integer (Position (CC));

                     begin

                        if Warn_On_Reverse_Bit_Order then

                           Error_Msg_Uint_1 := MSS;

                           Error_Msg_N

                             ("info: reverse bit order in machine " &

                              "scalar of length^?", First_Bit (CC));

                           Error_Msg_Uint_1 := NFB;

                           Error_Msg_Uint_2 := NLB;

                           if Bytes_Big_Endian then

                              Error_Msg_NE

                                ("?\info: big-endian range for "

                                 & "component & is ^ .. ^",

                                 First_Bit (CC), Comp);

                           else

                              Error_Msg_NE

                                ("?\info: little-endian range "

                                 & "for component & is ^ .. ^",

                                 First_Bit (CC), Comp);

                           end if;

                        end if;

                        Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);

                        Set_Normalized_First_Bit (Comp, NFB mod SSU);

                     end;

                  end loop;

               end loop;

            end Sort_CC;

         end;

      end if;

   end Adjust_Record_For_Reverse_Bit_Order;

   -------------------------------------

   -- Alignment_Check_For_Size_Change --

   -------------------------------------

   procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint) is

   begin

      --  If the alignment is known, and not set by a rep clause, and is

      --  inconsistent with the size being set, then reset it to unknown,

      --  we assume in this case that the size overrides the inherited

      --  alignment, and that the alignment must be recomputed.

      if Known_Alignment (Typ)

        and then not Has_Alignment_Clause (Typ)

        and then Size mod (Alignment (Typ) * SSU) /= 0

      then

         Init_Alignment (Typ);

      end if;

   end Alignment_Check_For_Size_Change;

   -----------------------------------

   -- Analyze_Aspect_Specifications --

   -----------------------------------

   procedure Analyze_Aspect_Specifications (N : Node_Id; E : Entity_Id) is

      Aspect : Node_Id;

      Aitem  : Node_Id;

      Ent    : Node_Id;

      L : constant List_Id := Aspect_Specifications (N);

      Ins_Node : Node_Id := N;

      --  Insert pragmas (except Pre/Post/Invariant/Predicate) after this node

      --  The general processing involves building an attribute definition

      --  clause or a pragma node that corresponds to the aspect. Then one

      --  of two things happens:

      --  If we are required to delay the evaluation of this aspect to the

      --  freeze point, we attach the corresponding pragma/attribute definition

      --  clause to the aspect specification node, which is then placed in the

      --  Rep Item chain. In this case we mark the entity by setting the flag

      --  Has_Delayed_Aspects and we evaluate the rep item at the freeze point.

      --  If no delay is required, we just insert the pragma or attribute

      --  after the declaration, and it will get processed by the normal

      --  circuit. The From_Aspect_Specification flag is set on the pragma

      --  or attribute definition node in either case to activate special

      --  processing (e.g. not traversing the list of homonyms for inline).

      Delay_Required : Boolean := False;

      --  Set True if delay is required

   begin

      pragma Assert (Present (L));

      --  Loop through aspects

      Aspect := First (L);

      Aspect_Loop : while Present (Aspect) loop

         declare

            Loc  : constant Source_Ptr := Sloc (Aspect);

            Id   : constant Node_Id    := Identifier (Aspect);

            Expr : constant Node_Id    := Expression (Aspect);

            Nam  : constant Name_Id    := Chars (Id);

            A_Id : constant Aspect_Id  := Get_Aspect_Id (Nam);

            Anod : Node_Id;

            Eloc : Source_Ptr := No_Location;

            --  Source location of expression, modified when we split PPC's. It

            --  is set below when Expr is present.

            procedure Check_False_Aspect_For_Derived_Type;

            --  This procedure checks for the case of a false aspect for a

            --  derived type, which improperly tries to cancel an aspect

            --  inherited from the parent;

            -----------------------------------------

            -- Check_False_Aspect_For_Derived_Type --

            -----------------------------------------

            procedure Check_False_Aspect_For_Derived_Type is

            begin

               --  We are only checking derived types

               if not Is_Derived_Type (E) then

                  return;

               end if;

               case A_Id is

                  when Aspect_Atomic | Aspect_Shared =>

                     if not Is_Atomic (E) then

                        return;

                     end if;

                  when Aspect_Atomic_Components =>

                     if not Has_Atomic_Components (E) then

                        return;

                     end if;

                  when Aspect_Discard_Names =>

                     if not Discard_Names (E) then

                        return;

                     end if;

                  when Aspect_Pack =>

                     if not Is_Packed (E) then

                        return;

                     end if;

                  when Aspect_Unchecked_Union =>

                     if not Is_Unchecked_Union (E) then

                        return;

                     end if;

                  when Aspect_Volatile =>

                     if not Is_Volatile (E) then

                        return;

                     end if;

                  when Aspect_Volatile_Components =>

                     if not Has_Volatile_Components (E) then

                        return;

                     end if;

                  when others =>

                     return;

               end case;

               --  Fall through means we are canceling an inherited aspect