URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [sem.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                  S E M                                   --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2009, 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.                                     --
--                                                                          --
-- You should have received a copy of the GNU General Public License along  --
-- with this program; see file COPYING3.  If not see                        --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- 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 Debug_A;  use Debug_A;
with Elists;   use Elists;
with Errout;   use Errout;
with Expander; use Expander;
with Fname;    use Fname;
with HLO;      use HLO;
with Lib;      use Lib;
with Lib.Load; use Lib.Load;
with Nlists;   use Nlists;
with Output;   use Output;
with Sem_Attr; use Sem_Attr;
with Sem_Ch2;  use Sem_Ch2;
with Sem_Ch3;  use Sem_Ch3;
with Sem_Ch4;  use Sem_Ch4;
with Sem_Ch5;  use Sem_Ch5;
with Sem_Ch6;  use Sem_Ch6;
with Sem_Ch7;  use Sem_Ch7;
with Sem_Ch8;  use Sem_Ch8;
with Sem_Ch9;  use Sem_Ch9;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch11; use Sem_Ch11;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo;    use Sinfo;
with Stand;    use Stand;
with Uintp;    use Uintp;
with Uname;    use Uname;
 
with Unchecked_Deallocation;
 
pragma Warnings (Off, Sem_Util);
--  Suppress warnings of unused with for Sem_Util (used only in asserts)
 
package body Sem is
 
   Debug_Unit_Walk : Boolean renames Debug_Flag_Dot_WW;
   --  Controls debugging printouts for Walk_Library_Items
 
   Outer_Generic_Scope : Entity_Id := Empty;
   --  Global reference to the outer scope that is generic. In a non
   --  generic context, it is empty. At the moment, it is only used
   --  for avoiding freezing of external references in generics.
 
   Comp_Unit_List : Elist_Id := No_Elist;
   --  Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes
   --  processed by Semantics, in an appropriate order. Initialized to
   --  No_Elist, because it's too early to call New_Elmt_List; we will set it
   --  to New_Elmt_List on first use.
 
   generic
      with procedure Action (Withed_Unit : Node_Id);
   procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean);
   --  Walk all the with clauses of CU, and call Action for the with'ed
   --  unit. Ignore limited withs, unless Include_Limited is True.
   --  CU must be an N_Compilation_Unit.
 
   generic
      with procedure Action (Withed_Unit : Node_Id);
   procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean);
   --  Same as Walk_Withs_Immediate, but also include with clauses on subunits
   --  of this unit, since they count as dependences on their parent library
   --  item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
 
   procedure Write_Unit_Info
     (Unit_Num : Unit_Number_Type;
      Item     : Node_Id;
      Prefix   : String := "";
      Withs    : Boolean := False);
   --  Print out debugging information about the unit. Prefix precedes the rest
   --  of the printout. If Withs is True, we print out units with'ed by this
   --  unit (not counting limited withs).
 
   -------------
   -- Analyze --
   -------------
 
   procedure Analyze (N : Node_Id) is
   begin
      Debug_A_Entry ("analyzing  ", N);
 
      --  Immediate return if already analyzed
 
      if Analyzed (N) then
         Debug_A_Exit ("analyzing  ", N, "  (done, analyzed already)");
         return;
      end if;
 
      --  Otherwise processing depends on the node kind
 
      case Nkind (N) is
 
         when N_Abort_Statement =>
            Analyze_Abort_Statement (N);
 
         when N_Abstract_Subprogram_Declaration =>
            Analyze_Abstract_Subprogram_Declaration (N);
 
         when N_Accept_Alternative =>
            Analyze_Accept_Alternative (N);
 
         when N_Accept_Statement =>
            Analyze_Accept_Statement (N);
 
         when N_Aggregate =>
            Analyze_Aggregate (N);
 
         when N_Allocator =>
            Analyze_Allocator (N);
 
         when N_And_Then =>
            Analyze_Short_Circuit (N);
 
         when N_Assignment_Statement =>
            Analyze_Assignment (N);
 
         when N_Asynchronous_Select =>
            Analyze_Asynchronous_Select (N);
 
         when N_At_Clause =>
            Analyze_At_Clause (N);
 
         when N_Attribute_Reference =>
            Analyze_Attribute (N);
 
         when N_Attribute_Definition_Clause   =>
            Analyze_Attribute_Definition_Clause (N);
 
         when N_Block_Statement =>
            Analyze_Block_Statement (N);
 
         when N_Case_Statement =>
            Analyze_Case_Statement (N);
 
         when N_Character_Literal =>
            Analyze_Character_Literal (N);
 
         when N_Code_Statement =>
            Analyze_Code_Statement (N);
 
         when N_Compilation_Unit =>
            Analyze_Compilation_Unit (N);
 
         when N_Component_Declaration =>
            Analyze_Component_Declaration (N);
 
         when N_Conditional_Expression =>
            Analyze_Conditional_Expression (N);
 
         when N_Conditional_Entry_Call =>
            Analyze_Conditional_Entry_Call (N);
 
         when N_Delay_Alternative =>
            Analyze_Delay_Alternative (N);
 
         when N_Delay_Relative_Statement =>
            Analyze_Delay_Relative (N);
 
         when N_Delay_Until_Statement =>
            Analyze_Delay_Until (N);
 
         when N_Entry_Body =>
            Analyze_Entry_Body (N);
 
         when N_Entry_Body_Formal_Part =>
            Analyze_Entry_Body_Formal_Part (N);
 
         when N_Entry_Call_Alternative =>
            Analyze_Entry_Call_Alternative (N);
 
         when N_Entry_Declaration =>
            Analyze_Entry_Declaration (N);
 
         when N_Entry_Index_Specification     =>
            Analyze_Entry_Index_Specification (N);
 
         when N_Enumeration_Representation_Clause =>
            Analyze_Enumeration_Representation_Clause (N);
 
         when N_Exception_Declaration =>
            Analyze_Exception_Declaration (N);
 
         when N_Exception_Renaming_Declaration =>
            Analyze_Exception_Renaming (N);
 
         when N_Exit_Statement =>
            Analyze_Exit_Statement (N);
 
         when N_Expanded_Name =>
            Analyze_Expanded_Name (N);
 
         when N_Explicit_Dereference =>
            Analyze_Explicit_Dereference (N);
 
         when N_Extended_Return_Statement =>
            Analyze_Extended_Return_Statement (N);
 
         when N_Extension_Aggregate =>
            Analyze_Aggregate (N);
 
         when N_Formal_Object_Declaration =>
            Analyze_Formal_Object_Declaration (N);
 
         when N_Formal_Package_Declaration =>
            Analyze_Formal_Package (N);
 
         when N_Formal_Subprogram_Declaration =>
            Analyze_Formal_Subprogram (N);
 
         when N_Formal_Type_Declaration =>
            Analyze_Formal_Type_Declaration (N);
 
         when N_Free_Statement =>
            Analyze_Free_Statement (N);
 
         when N_Freeze_Entity =>
            Analyze_Freeze_Entity (N);
 
         when N_Full_Type_Declaration =>
            Analyze_Type_Declaration (N);
 
         when N_Function_Call =>
            Analyze_Function_Call (N);
 
         when N_Function_Instantiation =>
            Analyze_Function_Instantiation (N);
 
         when N_Generic_Function_Renaming_Declaration =>
            Analyze_Generic_Function_Renaming (N);
 
         when N_Generic_Package_Declaration =>
            Analyze_Generic_Package_Declaration (N);
 
         when N_Generic_Package_Renaming_Declaration =>
            Analyze_Generic_Package_Renaming (N);
 
         when N_Generic_Procedure_Renaming_Declaration =>
            Analyze_Generic_Procedure_Renaming (N);
 
         when N_Generic_Subprogram_Declaration =>
            Analyze_Generic_Subprogram_Declaration (N);
 
         when N_Goto_Statement =>
            Analyze_Goto_Statement (N);
 
         when N_Handled_Sequence_Of_Statements =>
            Analyze_Handled_Statements (N);
 
         when N_Identifier =>
            Analyze_Identifier (N);
 
         when N_If_Statement =>
            Analyze_If_Statement (N);
 
         when N_Implicit_Label_Declaration =>
            Analyze_Implicit_Label_Declaration (N);
 
         when N_In =>
            Analyze_Membership_Op (N);
 
         when N_Incomplete_Type_Declaration =>
            Analyze_Incomplete_Type_Decl (N);
 
         when N_Indexed_Component =>
            Analyze_Indexed_Component_Form (N);
 
         when N_Integer_Literal =>
            Analyze_Integer_Literal (N);
 
         when N_Itype_Reference =>
            Analyze_Itype_Reference (N);
 
         when N_Label =>
            Analyze_Label (N);
 
         when N_Loop_Statement =>
            Analyze_Loop_Statement (N);
 
         when N_Not_In =>
            Analyze_Membership_Op (N);
 
         when N_Null =>
            Analyze_Null (N);
 
         when N_Null_Statement =>
            Analyze_Null_Statement (N);
 
         when N_Number_Declaration =>
            Analyze_Number_Declaration (N);
 
         when N_Object_Declaration =>
            Analyze_Object_Declaration (N);
 
         when N_Object_Renaming_Declaration  =>
            Analyze_Object_Renaming (N);
 
         when N_Operator_Symbol =>
            Analyze_Operator_Symbol (N);
 
         when N_Op_Abs =>
            Analyze_Unary_Op (N);
 
         when N_Op_Add =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_And =>
            Analyze_Logical_Op (N);
 
         when N_Op_Concat =>
            Analyze_Concatenation (N);
 
         when N_Op_Divide =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Eq =>
            Analyze_Equality_Op (N);
 
         when N_Op_Expon =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Ge =>
            Analyze_Comparison_Op (N);
 
         when N_Op_Gt =>
            Analyze_Comparison_Op (N);
 
         when N_Op_Le =>
            Analyze_Comparison_Op (N);
 
         when N_Op_Lt =>
            Analyze_Comparison_Op (N);
 
         when N_Op_Minus =>
            Analyze_Unary_Op (N);
 
         when N_Op_Mod =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Multiply =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Ne =>
            Analyze_Equality_Op (N);
 
         when N_Op_Not =>
            Analyze_Negation (N);
 
         when N_Op_Or =>
            Analyze_Logical_Op (N);
 
         when N_Op_Plus =>
            Analyze_Unary_Op (N);
 
         when N_Op_Rem =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Rotate_Left =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Rotate_Right =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Shift_Left =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Shift_Right =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Shift_Right_Arithmetic =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Subtract =>
            Analyze_Arithmetic_Op (N);
 
         when N_Op_Xor =>
            Analyze_Logical_Op (N);
 
         when N_Or_Else =>
            Analyze_Short_Circuit (N);
 
         when N_Others_Choice =>
            Analyze_Others_Choice (N);
 
         when N_Package_Body =>
            Analyze_Package_Body (N);
 
         when N_Package_Body_Stub =>
            Analyze_Package_Body_Stub (N);
 
         when N_Package_Declaration =>
            Analyze_Package_Declaration (N);
 
         when N_Package_Instantiation =>
            Analyze_Package_Instantiation (N);
 
         when N_Package_Renaming_Declaration =>
            Analyze_Package_Renaming (N);
 
         when N_Package_Specification =>
            Analyze_Package_Specification (N);
 
         when N_Parameter_Association =>
            Analyze_Parameter_Association (N);
 
         when N_Pragma =>
            Analyze_Pragma (N);
 
         when N_Private_Extension_Declaration =>
            Analyze_Private_Extension_Declaration (N);
 
         when N_Private_Type_Declaration =>
            Analyze_Private_Type_Declaration (N);
 
         when N_Procedure_Call_Statement =>
            Analyze_Procedure_Call (N);
 
         when N_Procedure_Instantiation =>
            Analyze_Procedure_Instantiation (N);
 
         when N_Protected_Body =>
            Analyze_Protected_Body (N);
 
         when N_Protected_Body_Stub =>
            Analyze_Protected_Body_Stub (N);
 
         when N_Protected_Definition =>
            Analyze_Protected_Definition (N);
 
         when N_Protected_Type_Declaration =>
            Analyze_Protected_Type (N);
 
         when N_Qualified_Expression =>
            Analyze_Qualified_Expression (N);
 
         when N_Raise_Statement =>
            Analyze_Raise_Statement (N);
 
         when N_Raise_xxx_Error =>
            Analyze_Raise_xxx_Error (N);
 
         when N_Range =>
            Analyze_Range (N);
 
         when N_Range_Constraint =>
            Analyze_Range (Range_Expression (N));
 
         when N_Real_Literal =>
            Analyze_Real_Literal (N);
 
         when N_Record_Representation_Clause =>
            Analyze_Record_Representation_Clause (N);
 
         when N_Reference =>
            Analyze_Reference (N);
 
         when N_Requeue_Statement =>
            Analyze_Requeue (N);
 
         when N_Simple_Return_Statement =>
            Analyze_Simple_Return_Statement (N);
 
         when N_Selected_Component =>
            Find_Selected_Component (N);
            --  ??? why not Analyze_Selected_Component, needs comments
 
         when N_Selective_Accept =>
            Analyze_Selective_Accept (N);
 
         when N_Single_Protected_Declaration =>
            Analyze_Single_Protected (N);
 
         when N_Single_Task_Declaration =>
            Analyze_Single_Task (N);
 
         when N_Slice =>
            Analyze_Slice (N);
 
         when N_String_Literal =>
            Analyze_String_Literal (N);
 
         when N_Subprogram_Body =>
            Analyze_Subprogram_Body (N);
 
         when N_Subprogram_Body_Stub =>
            Analyze_Subprogram_Body_Stub (N);
 
         when N_Subprogram_Declaration =>
            Analyze_Subprogram_Declaration (N);
 
         when N_Subprogram_Info =>
            Analyze_Subprogram_Info (N);
 
         when N_Subprogram_Renaming_Declaration =>
            Analyze_Subprogram_Renaming (N);
 
         when N_Subtype_Declaration =>
            Analyze_Subtype_Declaration (N);
 
         when N_Subtype_Indication =>
            Analyze_Subtype_Indication (N);
 
         when N_Subunit =>
            Analyze_Subunit (N);
 
         when N_Task_Body =>
            Analyze_Task_Body (N);
 
         when N_Task_Body_Stub =>
            Analyze_Task_Body_Stub (N);
 
         when N_Task_Definition =>
            Analyze_Task_Definition (N);
 
         when N_Task_Type_Declaration =>
            Analyze_Task_Type (N);
 
         when N_Terminate_Alternative =>
            Analyze_Terminate_Alternative (N);
 
         when N_Timed_Entry_Call =>
            Analyze_Timed_Entry_Call (N);
 
         when N_Triggering_Alternative =>
            Analyze_Triggering_Alternative (N);
 
         when N_Type_Conversion =>
            Analyze_Type_Conversion (N);
 
         when N_Unchecked_Expression =>
            Analyze_Unchecked_Expression (N);
 
         when N_Unchecked_Type_Conversion =>
            Analyze_Unchecked_Type_Conversion (N);
 
         when N_Use_Package_Clause =>
            Analyze_Use_Package (N);
 
         when N_Use_Type_Clause =>
            Analyze_Use_Type (N);
 
         when N_Validate_Unchecked_Conversion =>
            null;
 
         when N_Variant_Part =>
            Analyze_Variant_Part (N);
 
         when N_With_Clause =>
            Analyze_With_Clause (N);
 
         --  A call to analyze the Empty node is an error, but most likely
         --  it is an error caused by an attempt to analyze a malformed
         --  piece of tree caused by some other error, so if there have
         --  been any other errors, we just ignore it, otherwise it is
         --  a real internal error which we complain about.
 
         --  We must also consider the case of call to a runtime function
         --  that is not available in the configurable runtime.
 
         when N_Empty =>
            pragma Assert (Serious_Errors_Detected /= 0
              or else Configurable_Run_Time_Violations /= 0);
            null;
 
         --  A call to analyze the error node is simply ignored, to avoid
         --  causing cascaded errors (happens of course only in error cases)
 
         when N_Error =>
            null;
 
         --  Push/Pop nodes normally don't come through an analyze call. An
         --  exception is the dummy ones bracketing a subprogram body. In any
         --  case there is nothing to be done to analyze such nodes.
 
         when N_Push_Pop_xxx_Label =>
            null;
 
         --  SCIL nodes don't need analysis because they are decorated when
         --  they are built. They are added to the tree by Insert_Actions and
         --  the call to analyze them is generated when the full list is
         --  analyzed.
 
         when
           N_SCIL_Dispatch_Table_Object_Init        |
           N_SCIL_Dispatch_Table_Tag_Init           |
           N_SCIL_Dispatching_Call                  |
           N_SCIL_Membership_Test                   |
           N_SCIL_Tag_Init                          =>
            null;
 
         --  For the remaining node types, we generate compiler abort, because
         --  these nodes are always analyzed within the Sem_Chn routines and
         --  there should never be a case of making a call to the main Analyze
         --  routine for these node kinds. For example, an N_Access_Definition
         --  node appears only in the context of a type declaration, and is
         --  processed by the analyze routine for type declarations.
 
         when
           N_Abortable_Part                         |
           N_Access_Definition                      |
           N_Access_Function_Definition             |
           N_Access_Procedure_Definition            |
           N_Access_To_Object_Definition            |
           N_Case_Statement_Alternative             |
           N_Compilation_Unit_Aux                   |
           N_Component_Association                  |
           N_Component_Clause                       |
           N_Component_Definition                   |
           N_Component_List                         |
           N_Constrained_Array_Definition           |
           N_Decimal_Fixed_Point_Definition         |
           N_Defining_Character_Literal             |
           N_Defining_Identifier                    |
           N_Defining_Operator_Symbol               |
           N_Defining_Program_Unit_Name             |
           N_Delta_Constraint                       |
           N_Derived_Type_Definition                |
           N_Designator                             |
           N_Digits_Constraint                      |
           N_Discriminant_Association               |
           N_Discriminant_Specification             |
           N_Elsif_Part                             |
           N_Entry_Call_Statement                   |
           N_Enumeration_Type_Definition            |
           N_Exception_Handler                      |
           N_Floating_Point_Definition              |
           N_Formal_Decimal_Fixed_Point_Definition  |
           N_Formal_Derived_Type_Definition         |
           N_Formal_Discrete_Type_Definition        |
           N_Formal_Floating_Point_Definition       |
           N_Formal_Modular_Type_Definition         |
           N_Formal_Ordinary_Fixed_Point_Definition |
           N_Formal_Private_Type_Definition         |
           N_Formal_Signed_Integer_Type_Definition  |
           N_Function_Specification                 |
           N_Generic_Association                    |
           N_Index_Or_Discriminant_Constraint       |
           N_Iteration_Scheme                       |
           N_Loop_Parameter_Specification           |
           N_Mod_Clause                             |
           N_Modular_Type_Definition                |
           N_Ordinary_Fixed_Point_Definition        |
           N_Parameter_Specification                |
           N_Pragma_Argument_Association            |
           N_Procedure_Specification                |
           N_Real_Range_Specification               |
           N_Record_Definition                      |
           N_Signed_Integer_Type_Definition         |
           N_Unconstrained_Array_Definition         |
           N_Unused_At_Start                        |
           N_Unused_At_End                          |
           N_Variant                                =>
 
            raise Program_Error;
      end case;
 
      Debug_A_Exit ("analyzing  ", N, "  (done)");
 
      --  Now that we have analyzed the node, we call the expander to perform
      --  possible expansion. We skip this for subexpressions, because we don't
      --  have the type yet, and the expander will need to know the type before
      --  it can do its job. For subexpression nodes, the call to the expander
      --  happens in Sem_Res.Resolve. A special exception is Raise_xxx_Error,
      --  which can appear in a statement context, and needs expanding now in
      --  the case (distinguished by Etype, as documented in Sinfo).
 
      --  The Analyzed flag is also set at this point for non-subexpression
      --  nodes (in the case of subexpression nodes, we can't set the flag yet,
      --  since resolution and expansion have not yet been completed). Note
      --  that for N_Raise_xxx_Error we have to distinguish the expression
      --  case from the statement case.
 
      if Nkind (N) not in N_Subexpr
        or else (Nkind (N) in N_Raise_xxx_Error
                  and then Etype (N) = Standard_Void_Type)
      then
         Expand (N);
      end if;
   end Analyze;
 
   --  Version with check(s) suppressed
 
   procedure Analyze (N : Node_Id; Suppress : Check_Id) is
   begin
      if Suppress = All_Checks then
         declare
            Svg : constant Suppress_Array := Scope_Suppress;
         begin
            Scope_Suppress := (others => True);
            Analyze (N);
            Scope_Suppress := Svg;
         end;
 
      else
         declare
            Svg : constant Boolean := Scope_Suppress (Suppress);
         begin
            Scope_Suppress (Suppress) := True;
            Analyze (N);
            Scope_Suppress (Suppress) := Svg;
         end;
      end if;
   end Analyze;
 
   ------------------
   -- Analyze_List --
   ------------------
 
   procedure Analyze_List (L : List_Id) is
      Node : Node_Id;
 
   begin
      Node := First (L);
      while Present (Node) loop
         Analyze (Node);
         Next (Node);
      end loop;
   end Analyze_List;
 
   --  Version with check(s) suppressed
 
   procedure Analyze_List (L : List_Id; Suppress : Check_Id) is
   begin
      if Suppress = All_Checks then
         declare
            Svg : constant Suppress_Array := Scope_Suppress;
         begin
            Scope_Suppress := (others => True);
            Analyze_List (L);
            Scope_Suppress := Svg;
         end;
 
      else
         declare
            Svg : constant Boolean := Scope_Suppress (Suppress);
         begin
            Scope_Suppress (Suppress) := True;
            Analyze_List (L);
            Scope_Suppress (Suppress) := Svg;
         end;
      end if;
   end Analyze_List;
 
   --------------------------
   -- Copy_Suppress_Status --
   --------------------------
 
   procedure Copy_Suppress_Status
     (C    : Check_Id;
      From : Entity_Id;
      To   : Entity_Id)
   is
      Found : Boolean;
      pragma Warnings (Off, Found);
 
      procedure Search_Stack
        (Top   : Suppress_Stack_Entry_Ptr;
         Found : out Boolean);
      --  Search given suppress stack for matching entry for entity. If found
      --  then set Checks_May_Be_Suppressed on To, and push an appropriate
      --  entry for To onto the local suppress stack.
 
      ------------------
      -- Search_Stack --
      ------------------
 
      procedure Search_Stack
        (Top   : Suppress_Stack_Entry_Ptr;
         Found : out Boolean)
      is
         Ptr : Suppress_Stack_Entry_Ptr;
 
      begin
         Ptr := Top;
         while Ptr /= null loop
            if Ptr.Entity = From
              and then (Ptr.Check = All_Checks or else Ptr.Check = C)
            then
               if Ptr.Suppress then
                  Set_Checks_May_Be_Suppressed (To, True);
                  Push_Local_Suppress_Stack_Entry
                    (Entity   => To,
                     Check    => C,
                     Suppress => True);
                  Found := True;
                  return;
               end if;
            end if;
 
            Ptr := Ptr.Prev;
         end loop;
 
         Found := False;
         return;
      end Search_Stack;
 
   --  Start of processing for Copy_Suppress_Status
 
   begin
      if not Checks_May_Be_Suppressed (From) then
         return;
      end if;
 
      --  First search the local entity suppress stack, we search this in
      --  reverse order so that we get the innermost entry that applies to
      --  this case if there are nested entries. Note that for the purpose
      --  of this procedure we are ONLY looking for entries corresponding
      --  to a two-argument Suppress, where the second argument matches From.
 
      Search_Stack (Global_Suppress_Stack_Top, Found);
 
      if Found then
         return;
      end if;
 
      --  Now search the global entity suppress table for a matching entry
      --  We also search this in reverse order so that if there are multiple
      --  pragmas for the same entity, the last one applies.
 
      Search_Stack (Local_Suppress_Stack_Top, Found);
   end Copy_Suppress_Status;
 
   -------------------------
   -- Enter_Generic_Scope --
   -------------------------
 
   procedure Enter_Generic_Scope (S : Entity_Id) is
   begin
      if No (Outer_Generic_Scope) then
         Outer_Generic_Scope := S;
      end if;
   end Enter_Generic_Scope;
 
   ------------------------
   -- Exit_Generic_Scope --
   ------------------------
 
   procedure Exit_Generic_Scope  (S : Entity_Id) is
   begin
      if S = Outer_Generic_Scope then
         Outer_Generic_Scope := Empty;
      end if;
   end Exit_Generic_Scope;
 
   -----------------------
   -- Explicit_Suppress --
   -----------------------
 
   function Explicit_Suppress (E : Entity_Id; C : Check_Id) return Boolean is
      Ptr : Suppress_Stack_Entry_Ptr;
 
   begin
      if not Checks_May_Be_Suppressed (E) then
         return False;
 
      else
         Ptr := Global_Suppress_Stack_Top;
         while Ptr /= null loop
            if Ptr.Entity = E
              and then (Ptr.Check = All_Checks or else Ptr.Check = C)
            then
               return Ptr.Suppress;
            end if;
 
            Ptr := Ptr.Prev;
         end loop;
      end if;
 
      return False;
   end Explicit_Suppress;
 
   -----------------------------
   -- External_Ref_In_Generic --
   -----------------------------
 
   function External_Ref_In_Generic (E : Entity_Id) return Boolean is
      Scop : Entity_Id;
 
   begin
      --  Entity is global if defined outside of current outer_generic_scope:
      --  Either the entity has a smaller depth that the outer generic, or it
      --  is in a different compilation unit, or it is defined within a unit
      --  in the same compilation, that is not within the outer_generic.
 
      if No (Outer_Generic_Scope) then
         return False;
 
      elsif Scope_Depth (Scope (E)) < Scope_Depth (Outer_Generic_Scope)
        or else not In_Same_Source_Unit (E, Outer_Generic_Scope)
      then
         return True;
 
      else
         Scop := Scope (E);
 
         while Present (Scop) loop
            if Scop = Outer_Generic_Scope then
               return False;
            elsif Scope_Depth (Scop) < Scope_Depth (Outer_Generic_Scope) then
               return True;
            else
               Scop := Scope (Scop);
            end if;
         end loop;
 
         return True;
      end if;
   end External_Ref_In_Generic;
 
   ----------------
   -- Initialize --
   ----------------
 
   procedure Initialize is
      Next : Suppress_Stack_Entry_Ptr;
 
      procedure Free is new Unchecked_Deallocation
        (Suppress_Stack_Entry, Suppress_Stack_Entry_Ptr);
 
   begin
      --  Free any global suppress stack entries from a previous invocation
      --  of the compiler (in the normal case this loop does nothing).
 
      while Suppress_Stack_Entries /= null loop
         Next := Global_Suppress_Stack_Top.Next;
         Free (Suppress_Stack_Entries);
         Suppress_Stack_Entries := Next;
      end loop;
 
      Local_Suppress_Stack_Top := null;
      Global_Suppress_Stack_Top := null;
 
      --  Clear scope stack, and reset global variables
 
      Scope_Stack.Init;
      Unloaded_Subunits := False;
   end Initialize;
 
   ------------------------------
   -- Insert_After_And_Analyze --
   ------------------------------
 
   procedure Insert_After_And_Analyze (N : Node_Id; M : Node_Id) is
      Node : Node_Id;
 
   begin
      if Present (M) then
 
         --  If we are not at the end of the list, then the easiest
         --  coding is simply to insert before our successor
 
         if Present (Next (N)) then
            Insert_Before_And_Analyze (Next (N), M);
 
         --  Case of inserting at the end of the list
 
         else
            --  Capture the Node_Id of the node to be inserted. This Node_Id
            --  will still be the same after the insert operation.
 
            Node := M;
            Insert_After (N, M);
 
            --  Now just analyze from the inserted node to the end of
            --  the new list (note that this properly handles the case
            --  where any of the analyze calls result in the insertion of
            --  nodes after the analyzed node, expecting analysis).
 
            while Present (Node) loop
               Analyze (Node);
               Mark_Rewrite_Insertion (Node);
               Next (Node);
            end loop;
         end if;
      end if;
   end Insert_After_And_Analyze;
 
   --  Version with check(s) suppressed
 
   procedure Insert_After_And_Analyze
     (N        : Node_Id;
      M        : Node_Id;
      Suppress : Check_Id)
   is
   begin
      if Suppress = All_Checks then
         declare
            Svg : constant Suppress_Array := Scope_Suppress;
         begin
            Scope_Suppress := (others => True);
            Insert_After_And_Analyze (N, M);
            Scope_Suppress := Svg;
         end;
 
      else
         declare
            Svg : constant Boolean := Scope_Suppress (Suppress);
         begin
            Scope_Suppress (Suppress) := True;
            Insert_After_And_Analyze (N, M);
            Scope_Suppress (Suppress) := Svg;
         end;
      end if;
   end Insert_After_And_Analyze;
 
   -------------------------------
   -- Insert_Before_And_Analyze --
   -------------------------------
 
   procedure Insert_Before_And_Analyze (N : Node_Id; M : Node_Id) is
      Node : Node_Id;
 
   begin
      if Present (M) then
 
         --  Capture the Node_Id of the first list node to be inserted.
         --  This will still be the first node after the insert operation,
         --  since Insert_List_After does not modify the Node_Id values.
 
         Node := M;
         Insert_Before (N, M);
 
         --  The insertion does not change the Id's of any of the nodes in
         --  the list, and they are still linked, so we can simply loop from
         --  the original first node until we meet the node before which the
         --  insertion is occurring. Note that this properly handles the case
         --  where any of the analyzed nodes insert nodes after themselves,
         --  expecting them to get analyzed.
 
         while Node /= N loop
            Analyze (Node);
            Mark_Rewrite_Insertion (Node);
            Next (Node);
         end loop;
      end if;
   end Insert_Before_And_Analyze;
 
   --  Version with check(s) suppressed
 
   procedure Insert_Before_And_Analyze
     (N        : Node_Id;
      M        : Node_Id;
      Suppress : Check_Id)
   is
   begin
      if Suppress = All_Checks then
         declare
            Svg : constant Suppress_Array := Scope_Suppress;
         begin
            Scope_Suppress := (others => True);
            Insert_Before_And_Analyze (N, M);
            Scope_Suppress := Svg;
         end;
 
      else
         declare
            Svg : constant Boolean := Scope_Suppress (Suppress);
         begin
            Scope_Suppress (Suppress) := True;
            Insert_Before_And_Analyze (N, M);
            Scope_Suppress (Suppress) := Svg;
         end;
      end if;
   end Insert_Before_And_Analyze;
 
   -----------------------------------
   -- Insert_List_After_And_Analyze --
   -----------------------------------
 
   procedure Insert_List_After_And_Analyze (N : Node_Id; L : List_Id) is
      After : constant Node_Id := Next (N);
      Node  : Node_Id;
 
   begin
      if Is_Non_Empty_List (L) then
 
         --  Capture the Node_Id of the first list node to be inserted.
         --  This will still be the first node after the insert operation,
         --  since Insert_List_After does not modify the Node_Id values.
 
         Node := First (L);
         Insert_List_After (N, L);
 
         --  Now just analyze from the original first node until we get to
         --  the successor of the original insertion point (which may be
         --  Empty if the insertion point was at the end of the list). Note
         --  that this properly handles the case where any of the analyze
         --  calls result in the insertion of nodes after the analyzed
         --  node (possibly calling this routine recursively).
 
         while Node /= After loop
            Analyze (Node);
            Mark_Rewrite_Insertion (Node);
            Next (Node);
         end loop;
      end if;
   end Insert_List_After_And_Analyze;
 
   --  Version with check(s) suppressed
 
   procedure Insert_List_After_And_Analyze
     (N : Node_Id; L : List_Id; Suppress : Check_Id)
   is
   begin
      if Suppress = All_Checks then
         declare
            Svg : constant Suppress_Array := Scope_Suppress;
         begin
            Scope_Suppress := (others => True);
            Insert_List_After_And_Analyze (N, L);
            Scope_Suppress := Svg;
         end;
 
      else
         declare
            Svg : constant Boolean := Scope_Suppress (Suppress);
         begin
            Scope_Suppress (Suppress) := True;
            Insert_List_After_And_Analyze (N, L);
            Scope_Suppress (Suppress) := Svg;
         end;
      end if;
   end Insert_List_After_And_Analyze;
 
   ------------------------------------
   -- Insert_List_Before_And_Analyze --
   ------------------------------------
 
   procedure Insert_List_Before_And_Analyze (N : Node_Id; L : List_Id) is
      Node : Node_Id;
 
   begin
      if Is_Non_Empty_List (L) then
 
         --  Capture the Node_Id of the first list node to be inserted.
         --  This will still be the first node after the insert operation,
         --  since Insert_List_After does not modify the Node_Id values.
 
         Node := First (L);
         Insert_List_Before (N, L);
 
         --  The insertion does not change the Id's of any of the nodes in
         --  the list, and they are still linked, so we can simply loop from
         --  the original first node until we meet the node before which the
         --  insertion is occurring. Note that this properly handles the case
         --  where any of the analyzed nodes insert nodes after themselves,
         --  expecting them to get analyzed.
 
         while Node /= N loop
            Analyze (Node);
            Mark_Rewrite_Insertion (Node);
            Next (Node);
         end loop;
      end if;
   end Insert_List_Before_And_Analyze;
 
   --  Version with check(s) suppressed
 
   procedure Insert_List_Before_And_Analyze
     (N : Node_Id; L : List_Id; Suppress : Check_Id)
   is
   begin
      if Suppress = All_Checks then
         declare
            Svg : constant Suppress_Array := Scope_Suppress;
         begin
            Scope_Suppress := (others => True);
            Insert_List_Before_And_Analyze (N, L);
            Scope_Suppress := Svg;
         end;
 
      else
         declare
            Svg : constant Boolean := Scope_Suppress (Suppress);
         begin
            Scope_Suppress (Suppress) := True;
            Insert_List_Before_And_Analyze (N, L);
            Scope_Suppress (Suppress) := Svg;
         end;
      end if;
   end Insert_List_Before_And_Analyze;
 
   -------------------------
   -- Is_Check_Suppressed --
   -------------------------
 
   function Is_Check_Suppressed (E : Entity_Id; C : Check_Id) return Boolean is
 
      Ptr : Suppress_Stack_Entry_Ptr;
 
   begin
      --  First search the local entity suppress stack, we search this from the
      --  top of the stack down, so that we get the innermost entry that
      --  applies to this case if there are nested entries.
 
      Ptr := Local_Suppress_Stack_Top;
      while Ptr /= null loop
         if (Ptr.Entity = Empty or else Ptr.Entity = E)
           and then (Ptr.Check = All_Checks or else Ptr.Check = C)
         then
            return Ptr.Suppress;
         end if;
 
         Ptr := Ptr.Prev;
      end loop;
 
      --  Now search the global entity suppress table for a matching entry
      --  We also search this from the top down so that if there are multiple
      --  pragmas for the same entity, the last one applies (not clear what
      --  or whether the RM specifies this handling, but it seems reasonable).
 
      Ptr := Global_Suppress_Stack_Top;
      while Ptr /= null loop
         if (Ptr.Entity = Empty or else Ptr.Entity = E)
           and then (Ptr.Check = All_Checks or else Ptr.Check = C)
         then
            return Ptr.Suppress;
         end if;
 
         Ptr := Ptr.Prev;
      end loop;
 
      --  If we did not find a matching entry, then use the normal scope
      --  suppress value after all (actually this will be the global setting
      --  since it clearly was not overridden at any point). For a predefined
      --  check, we test the specific flag. For a user defined check, we check
      --  the All_Checks flag.
 
      if C in Predefined_Check_Id then
         return Scope_Suppress (C);
      else
         return Scope_Suppress (All_Checks);
      end if;
   end Is_Check_Suppressed;
 
   ----------
   -- Lock --
   ----------
 
   procedure Lock is
   begin
      Scope_Stack.Locked := True;
      Scope_Stack.Release;
   end Lock;
 
   --------------------------------------
   -- Push_Global_Suppress_Stack_Entry --
   --------------------------------------
 
   procedure Push_Global_Suppress_Stack_Entry
     (Entity   : Entity_Id;
      Check    : Check_Id;
      Suppress : Boolean)
   is
   begin
      Global_Suppress_Stack_Top :=
        new Suppress_Stack_Entry'
          (Entity   => Entity,
           Check    => Check,
           Suppress => Suppress,
           Prev     => Global_Suppress_Stack_Top,
           Next     => Suppress_Stack_Entries);
      Suppress_Stack_Entries := Global_Suppress_Stack_Top;
      return;
 
   end Push_Global_Suppress_Stack_Entry;
 
   -------------------------------------
   -- Push_Local_Suppress_Stack_Entry --
   -------------------------------------
 
   procedure Push_Local_Suppress_Stack_Entry
     (Entity   : Entity_Id;
      Check    : Check_Id;
      Suppress : Boolean)
   is
   begin
      Local_Suppress_Stack_Top :=
        new Suppress_Stack_Entry'
          (Entity   => Entity,
           Check    => Check,
           Suppress => Suppress,
           Prev     => Local_Suppress_Stack_Top,
           Next     => Suppress_Stack_Entries);
      Suppress_Stack_Entries := Local_Suppress_Stack_Top;
 
      return;
   end Push_Local_Suppress_Stack_Entry;
 
   ---------------
   -- Semantics --
   ---------------
 
   procedure Semantics (Comp_Unit : Node_Id) is
 
      --  The following locations save the corresponding global flags and
      --  variables so that they can be restored on completion. This is
      --  needed so that calls to Rtsfind start with the proper default
      --  values for these variables, and also that such calls do not
      --  disturb the settings for units being analyzed at a higher level.
 
      S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit;
      S_Full_Analysis    : constant Boolean          := Full_Analysis;
      S_GNAT_Mode        : constant Boolean          := GNAT_Mode;
      S_Global_Dis_Names : constant Boolean          := Global_Discard_Names;
      S_In_Spec_Expr     : constant Boolean          := In_Spec_Expression;
      S_Inside_A_Generic : constant Boolean          := Inside_A_Generic;
      S_New_Nodes_OK     : constant Int              := New_Nodes_OK;
      S_Outer_Gen_Scope  : constant Entity_Id        := Outer_Generic_Scope;
 
      Generic_Main : constant Boolean :=
                       Nkind (Unit (Cunit (Main_Unit)))
                         in N_Generic_Declaration;
      --  If the main unit is generic, every compiled unit, including its
      --  context, is compiled with expansion disabled.
 
      Save_Config_Switches : Config_Switches_Type;
      --  Variable used to save values of config switches while we analyze
      --  the new unit, to be restored on exit for proper recursive behavior.
 
      procedure Do_Analyze;
      --  Procedure to analyze the compilation unit. This is called more
      --  than once when the high level optimizer is activated.
 
      ----------------
      -- Do_Analyze --
      ----------------
 
      procedure Do_Analyze is
      begin
         Save_Scope_Stack;
         Push_Scope (Standard_Standard);
         Scope_Suppress := Suppress_Options;
         Scope_Stack.Table
           (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
         Scope_Stack.Table
           (Scope_Stack.Last).Is_Active_Stack_Base := True;
         Outer_Generic_Scope := Empty;
 
         --  Now analyze the top level compilation unit node
 
         Analyze (Comp_Unit);
 
         --  Check for scope mismatch on exit from compilation
 
         pragma Assert (Current_Scope = Standard_Standard
                          or else Comp_Unit = Cunit (Main_Unit));
 
         --  Then pop entry for Standard, and pop implicit types
 
         Pop_Scope;
         Restore_Scope_Stack;
      end Do_Analyze;
 
      Already_Analyzed : constant Boolean := Analyzed (Comp_Unit);
 
   --  Start of processing for Semantics
 
   begin
      if Debug_Unit_Walk then
         if Already_Analyzed then
            Write_Str ("(done)");
         end if;
 
         Write_Unit_Info
           (Get_Cunit_Unit_Number (Comp_Unit),
            Unit (Comp_Unit),
            Prefix => "--> ");
         Indent;
      end if;
 
      Compiler_State   := Analyzing;
      Current_Sem_Unit := Get_Cunit_Unit_Number (Comp_Unit);
 
      --  Compile predefined units with GNAT_Mode set to True, to properly
      --  process the categorization stuff. However, do not set GNAT_Mode
      --  to True for the renamings units (Text_IO, IO_Exceptions, Direct_IO,
      --  Sequential_IO) as this would prevent pragma Extend_System from being
      --  taken into account, for example when Text_IO is renaming DEC.Text_IO.
 
      --  Cleaner might be to do the kludge at the point of excluding the
      --  pragma (do not exclude for renamings ???)
 
      if Is_Predefined_File_Name
           (Unit_File_Name (Current_Sem_Unit), Renamings_Included => False)
      then
         GNAT_Mode := True;
      end if;
 
      if Generic_Main then
         Expander_Mode_Save_And_Set (False);
      else
         Expander_Mode_Save_And_Set
           (Operating_Mode = Generate_Code or Debug_Flag_X);
      end if;
 
      Full_Analysis      := True;
      Inside_A_Generic   := False;
      In_Spec_Expression := False;
 
      Set_Comes_From_Source_Default (False);
      Save_Opt_Config_Switches (Save_Config_Switches);
      Set_Opt_Config_Switches
        (Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)),
         Current_Sem_Unit = Main_Unit);
 
      --  Only do analysis of unit that has not already been analyzed
 
      if not Analyzed (Comp_Unit) then
         Initialize_Version (Current_Sem_Unit);
         if HLO_Active then
            Expander_Mode_Save_And_Set (False);
            New_Nodes_OK := 1;
            Do_Analyze;
            Reset_Analyzed_Flags (Comp_Unit);
            Expander_Mode_Restore;
            High_Level_Optimize (Comp_Unit);
            New_Nodes_OK := 0;
         end if;
 
         --  Do analysis, and then append the compilation unit onto the
         --  Comp_Unit_List, if appropriate. This is done after analysis, so
         --  if this unit depends on some others, they have already been
         --  appended. We ignore bodies, except for the main unit itself. We
         --  have also to guard against ill-formed subunits that have an
         --  improper context.
 
         Do_Analyze;
 
         if Present (Comp_Unit)
           and then Nkind (Unit (Comp_Unit)) in N_Proper_Body
           and then not In_Extended_Main_Source_Unit (Comp_Unit)
         then
            null;
 
         else
            --  Initialize if first time
 
            if No (Comp_Unit_List) then
               Comp_Unit_List := New_Elmt_List;
            end if;
 
            Append_Elmt (Comp_Unit, Comp_Unit_List);
 
            if Debug_Unit_Walk then
               Write_Str ("Appending ");
               Write_Unit_Info
                 (Get_Cunit_Unit_Number (Comp_Unit), Unit (Comp_Unit));
            end if;
         end if;
      end if;
 
      --  Save indication of dynamic elaboration checks for ALI file
 
      Set_Dynamic_Elab (Current_Sem_Unit, Dynamic_Elaboration_Checks);
 
      --  Restore settings of saved switches to entry values
 
      Current_Sem_Unit     := S_Current_Sem_Unit;
      Full_Analysis        := S_Full_Analysis;
      Global_Discard_Names := S_Global_Dis_Names;
      GNAT_Mode            := S_GNAT_Mode;
      In_Spec_Expression   := S_In_Spec_Expr;
      Inside_A_Generic     := S_Inside_A_Generic;
      New_Nodes_OK         := S_New_Nodes_OK;
      Outer_Generic_Scope  := S_Outer_Gen_Scope;
 
      Restore_Opt_Config_Switches (Save_Config_Switches);
      Expander_Mode_Restore;
 
      if Debug_Unit_Walk then
         Outdent;
 
         if Already_Analyzed then
            Write_Str ("(done)");
         end if;
 
         Write_Unit_Info
           (Get_Cunit_Unit_Number (Comp_Unit),
            Unit (Comp_Unit),
            Prefix => "<-- ");
      end if;
   end Semantics;
 
   ------------------------
   -- Walk_Library_Items --
   ------------------------
 
   procedure Walk_Library_Items is
      type Unit_Number_Set is array (Main_Unit .. Last_Unit) of Boolean;
      pragma Pack (Unit_Number_Set);
      Seen, Done : Unit_Number_Set := (others => False);
      --  Seen (X) is True after we have seen unit X in the walk. This is used
      --  to prevent processing the same unit more than once. Done (X) is True
      --  after we have fully processed X, and is used only for debugging
      --  printouts and assertions.
 
      Do_Main : Boolean := False;
      --  Flag to delay processing the main body until after all other units.
      --  This is needed because the spec of the main unit may appear in the
      --  context of some other unit. We do not want this to force processing
      --  of the main body before all other units have been processed.
 
      procedure Do_Action (CU : Node_Id; Item : Node_Id);
      --  Calls Action, with some validity checks
 
      procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id);
      --  Calls Do_Action, first on the units with'ed by this one, then on
      --  this unit. If it's an instance body, do the spec first. If it is
      --  an instance spec, do the body last.
 
      ---------------
      -- Do_Action --
      ---------------
 
      procedure Do_Action (CU : Node_Id; Item : Node_Id) is
      begin
         --  This calls Action at the end. All the preceding code is just
         --  assertions and debugging output.
 
         pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
 
         case Nkind (Item) is
            when N_Generic_Subprogram_Declaration        |
                 N_Generic_Package_Declaration           |
                 N_Package_Declaration                   |
                 N_Subprogram_Declaration                |
                 N_Subprogram_Renaming_Declaration       |
                 N_Package_Renaming_Declaration          |
                 N_Generic_Function_Renaming_Declaration |
                 N_Generic_Package_Renaming_Declaration  |
                 N_Generic_Procedure_Renaming_Declaration =>
 
               --  Specs are OK
 
               null;
 
            when N_Package_Body  =>
 
               --  Package bodies are processed immediately after the
               --  corresponding spec.
 
               null;
 
            when  N_Subprogram_Body =>
 
               --  A subprogram body must be the main unit
 
               pragma Assert (Acts_As_Spec (CU)
                               or else CU = Cunit (Main_Unit));
               null;
 
            --  All other cases cannot happen
 
            when N_Function_Instantiation  |
                 N_Procedure_Instantiation |
                 N_Package_Instantiation   =>
               pragma Assert (False, "instantiation");
               null;
 
            when N_Subunit =>
               pragma Assert (False, "subunit");
               null;
 
            when others =>
               pragma Assert (False);
               null;
         end case;
 
         if Present (CU) then
            pragma Assert (Item /= Stand.Standard_Package_Node);
            pragma Assert (Item = Unit (CU));
 
            declare
               Unit_Num : constant Unit_Number_Type :=
                            Get_Cunit_Unit_Number (CU);
 
               procedure Assert_Done (Withed_Unit : Node_Id);
               --  Assert Withed_Unit is already Done, unless it's a body. It
               --  might seem strange for a with_clause to refer to a body, but
               --  this happens in the case of a generic instantiation, which
               --  gets transformed into the instance body (and the instance
               --  spec is also created). With clauses pointing to the
               --  instantiation end up pointing to the instance body.
 
               -----------------
               -- Assert_Done --
               -----------------
 
               procedure Assert_Done (Withed_Unit : Node_Id) is
               begin
                  if not Done (Get_Cunit_Unit_Number (Withed_Unit)) then
                     if not Nkind_In
                              (Unit (Withed_Unit),
                                 N_Generic_Package_Declaration,
                                 N_Package_Body,
                                 N_Subprogram_Body)
                     then
                        Write_Unit_Name
                          (Unit_Name (Get_Cunit_Unit_Number (Withed_Unit)));
                        Write_Str (" not yet walked!");
 
                        if Get_Cunit_Unit_Number (Withed_Unit) = Unit_Num then
                           Write_Str (" (self-ref)");
                        end if;
 
                        Write_Eol;
 
                        pragma Assert (False);
                     end if;
                  end if;
               end Assert_Done;
 
               procedure Assert_Withed_Units_Done is
                 new Walk_Withs (Assert_Done);
 
            begin
               if Debug_Unit_Walk then
                  Write_Unit_Info (Unit_Num, Item, Withs => True);
               end if;
 
               --  Main unit should come last (except in the case where we
               --  skipped System_Aux_Id, in which case we missed the things it
               --  depends on).
 
               pragma Assert
                 (not Done (Main_Unit) or else Present (System_Aux_Id));
 
               --  We shouldn't do the same thing twice
 
               pragma Assert (not Done (Unit_Num));
 
               --  Everything we depend upon should already be done
 
               pragma Debug
                 (Assert_Withed_Units_Done (CU, Include_Limited => False));
            end;
 
         else
            --  Must be Standard, which has no entry in the units table
 
            pragma Assert (Item = Stand.Standard_Package_Node);
 
            if Debug_Unit_Walk then
               Write_Line ("Standard");
            end if;
         end if;
 
         Action (Item);
      end Do_Action;
 
      ----------------------------
      -- Do_Unit_And_Dependents --
      ----------------------------
 
      procedure Do_Unit_And_Dependents (CU : Node_Id; Item : Node_Id) is
         Unit_Num : constant Unit_Number_Type :=
                      Get_Cunit_Unit_Number (CU);
 
         procedure Do_Withed_Unit (Withed_Unit : Node_Id);
         --  Pass the buck to Do_Unit_And_Dependents
 
         --------------------
         -- Do_Withed_Unit --
         --------------------
 
         procedure Do_Withed_Unit (Withed_Unit : Node_Id) is
            Save_Do_Main : constant Boolean := Do_Main;
 
         begin
            --  Do not process the main unit if coming from a with_clause,
            --  as would happen with a parent body that has a child spec
            --  in its context.
 
            Do_Main := False;
            Do_Unit_And_Dependents (Withed_Unit, Unit (Withed_Unit));
            Do_Main := Save_Do_Main;
         end Do_Withed_Unit;
 
         procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit);
 
      --  Start of processing for Do_Unit_And_Dependents
 
      begin
         if not Seen (Unit_Num) then
 
            --  Process the with clauses
 
            Do_Withed_Units (CU, Include_Limited => False);
 
            --  Process the unit if it is a spec. If it is the main unit,
            --  process it only if we have done all other units.
 
            if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body)
              or else Acts_As_Spec (CU)
            then
               if CU = Cunit (Main_Unit) and then not Do_Main then
                  Seen (Unit_Num) := False;
 
               else
                  Seen (Unit_Num) := True;
                  Do_Action (CU, Item);
                  Done (Unit_Num) := True;
               end if;
            end if;
         end if;
 
         --  Process bodies. The spec, if present, has been processed already.
         --  A body appears if it is the main, or the body of a spec that is
         --  in the context of the main unit, and that is instantiated, or else
         --  contains a generic that is instantiated, or a subprogram that is
         --  or a subprogram that is inlined in the main unit.
 
         --  We exclude bodies that may appear in a circular dependency list,
         --  where spec A depends on spec B and body of B depends on spec A.
         --  This is not an elaboration issue, but body B must be excluded
         --  from the processing.
 
         declare
            Body_Unit :  Node_Id := Empty;
            Body_Num  : Unit_Number_Type;
 
            function Circular_Dependence (B : Node_Id) return Boolean;
            --  Check whether this body depends on a spec that is pending,
            --  that is to say has been seen but not processed yet.
 
            -------------------------
            -- Circular_Dependence --
            -------------------------
 
            function Circular_Dependence (B : Node_Id) return Boolean is
               Item : Node_Id;
               UN   : Unit_Number_Type;
 
            begin
               Item := First (Context_Items (B));
               while Present (Item) loop
                  if Nkind (Item) = N_With_Clause then
                     UN := Get_Cunit_Unit_Number (Library_Unit (Item));
 
                     if Seen (UN)
                       and then not Done (UN)
                     then
                        return True;
                     end if;
                  end if;
 
                  Next (Item);
               end loop;
 
               return False;
            end Circular_Dependence;
 
         begin
            if Nkind (Item) = N_Package_Declaration then
               Body_Unit := Library_Unit (CU);
 
            elsif Nkind_In (Item, N_Package_Body, N_Subprogram_Body) then
               Body_Unit := CU;
            end if;
 
            if Present (Body_Unit)
 
              --  Since specs and bodies are not done at the same time,
              --  guard against listing a body more than once. Bodies are
              --  only processed when the main unit is being processed,
              --  after all other units in the list. The DEC extension
              --  to System is excluded because of circularities.
 
              and then not Seen (Get_Cunit_Unit_Number (Body_Unit))
              and then
                (No (System_Aux_Id)
                   or else Unit_Num /= Get_Source_Unit (System_Aux_Id))
              and then not Circular_Dependence (Body_Unit)
              and then Do_Main
            then
               Body_Num := Get_Cunit_Unit_Number (Body_Unit);
               Seen (Body_Num) := True;
               Do_Action (Body_Unit, Unit (Body_Unit));
               Done (Body_Num) := True;
            end if;
         end;
      end Do_Unit_And_Dependents;
 
      --  Local Declarations
 
      Cur : Elmt_Id;
 
   --  Start of processing for Walk_Library_Items
 
   begin
      if Debug_Unit_Walk then
         Write_Line ("Walk_Library_Items:");
         Indent;
      end if;
 
      --  Do Standard first, then walk the Comp_Unit_List
 
      Do_Action (Empty, Standard_Package_Node);
 
      --  First place the context of all instance bodies on the corresponding
      --  spec, because it may be needed to analyze the code at the place of
      --  the instantiation.
 
      Cur := First_Elmt (Comp_Unit_List);
      while Present (Cur) loop
         declare
            CU : constant Node_Id := Node (Cur);
            N  : constant Node_Id := Unit (CU);
 
         begin
            if Nkind (N) = N_Package_Body
              and then Is_Generic_Instance (Defining_Entity (N))
            then
               Append_List
                 (Context_Items (CU), Context_Items (Library_Unit (CU)));
            end if;
 
            Next_Elmt (Cur);
         end;
      end loop;
 
      --  Now traverse compilation units in order
 
      Cur := First_Elmt (Comp_Unit_List);
      while Present (Cur) loop
         declare
            CU : constant Node_Id := Node (Cur);
            N  : constant Node_Id := Unit (CU);
 
         begin
            pragma Assert (Nkind (CU) = N_Compilation_Unit);
 
            case Nkind (N) is
 
               --  If it's a body, ignore it. Bodies appear in the list only
               --  because of inlining/instantiations, and they are processed
               --  immediately after the corresponding specs. The main unit is
               --  processed separately after all other units.
 
               when N_Package_Body | N_Subprogram_Body =>
                  null;
 
               --  It's a spec, so just do it
 
               when others =>
                  Do_Unit_And_Dependents (CU, N);
            end case;
         end;
 
         Next_Elmt (Cur);
      end loop;
 
      if not Done (Main_Unit) then
         Do_Main := True;
 
         declare
            Main_CU : constant Node_Id := Cunit (Main_Unit);
 
         begin
            --  If the main unit is an instantiation, the body appears before
            --  the instance spec, which is added later to the unit list. Do
            --  the spec if present, body will follow.
 
            if Nkind (Original_Node (Unit (Main_CU)))
                 in N_Generic_Instantiation
              and then Present (Library_Unit (Main_CU))
            then
               Do_Unit_And_Dependents
                 (Library_Unit (Main_CU), Unit (Library_Unit (Main_CU)));
            else
               Do_Unit_And_Dependents (Main_CU, Unit (Main_CU));
            end if;
         end;
      end if;
 
      if Debug_Unit_Walk then
         if Done /= (Done'Range => True) then
            Write_Eol;
            Write_Line ("Ignored units:");
 
            Indent;
 
            for Unit_Num in Done'Range loop
               if not Done (Unit_Num) then
                  Write_Unit_Info
                    (Unit_Num, Unit (Cunit (Unit_Num)), Withs => True);
               end if;
            end loop;
 
            Outdent;
         end if;
      end if;
 
      pragma Assert (Done (Main_Unit));
 
      if Debug_Unit_Walk then
         Outdent;
         Write_Line ("end Walk_Library_Items.");
      end if;
   end Walk_Library_Items;
 
   ----------------
   -- Walk_Withs --
   ----------------
 
   procedure Walk_Withs (CU : Node_Id; Include_Limited : Boolean) is
      pragma Assert (Nkind (CU) = N_Compilation_Unit);
      pragma Assert (Nkind (Unit (CU)) /= N_Subunit);
 
      procedure Walk_Immediate is new Walk_Withs_Immediate (Action);
 
   begin
      --  First walk the withs immediately on the library item
 
      Walk_Immediate (CU, Include_Limited);
 
      --  For a body, we must also check for any subunits which belong to it
      --  and which have context clauses of their own, since these with'ed
      --  units are part of its own dependencies.
 
      if Nkind (Unit (CU)) in N_Unit_Body then
         for S in Main_Unit .. Last_Unit loop
 
            --  We are only interested in subunits. For preproc. data and def.
            --  files, Cunit is Empty, so we need to test that first.
 
            if Cunit (S) /= Empty
              and then Nkind (Unit (Cunit (S))) = N_Subunit
            then
               declare
                  Pnode : Node_Id;
 
               begin
                  Pnode := Library_Unit (Cunit (S));
 
                  --  In -gnatc mode, the errors in the subunits will not have
                  --  been recorded, but the analysis of the subunit may have
                  --  failed, so just quit.
 
                  if No (Pnode) then
                     exit;
                  end if;
 
                  --  Find ultimate parent of the subunit
 
                  while Nkind (Unit (Pnode)) = N_Subunit loop
                     Pnode := Library_Unit (Pnode);
                  end loop;
 
                  --  See if it belongs to current unit, and if so, include its
                  --  with_clauses. Do not process main unit prematurely.
 
                  if Pnode = CU and then CU /= Cunit (Main_Unit) then
                     Walk_Immediate (Cunit (S), Include_Limited);
                  end if;
               end;
            end if;
         end loop;
      end if;
   end Walk_Withs;
 
   --------------------------
   -- Walk_Withs_Immediate --
   --------------------------
 
   procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean) is
      pragma Assert (Nkind (CU) = N_Compilation_Unit);
 
      Context_Item : Node_Id;
 
   begin
      Context_Item := First (Context_Items (CU));
      while Present (Context_Item) loop
         if Nkind (Context_Item) = N_With_Clause
           and then (Include_Limited
                     or else not Limited_Present (Context_Item))
         then
            Action (Library_Unit (Context_Item));
         end if;
 
         Context_Item := Next (Context_Item);
      end loop;
   end Walk_Withs_Immediate;
 
   ---------------------
   -- Write_Unit_Info --
   ---------------------
 
   procedure Write_Unit_Info
     (Unit_Num : Unit_Number_Type;
      Item     : Node_Id;
      Prefix   : String := "";
      Withs    : Boolean := False)
   is
   begin
      Write_Str (Prefix);
      Write_Unit_Name (Unit_Name (Unit_Num));
      Write_Str (", unit ");
      Write_Int (Int (Unit_Num));
      Write_Str (", ");
      Write_Int (Int (Item));
      Write_Str ("=");
      Write_Str (Node_Kind'Image (Nkind (Item)));
 
      if Item /= Original_Node (Item) then
         Write_Str (", orig = ");
         Write_Int (Int (Original_Node (Item)));
         Write_Str ("=");
         Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
      end if;
 
      Write_Eol;
 
      --  Skip the rest if we're not supposed to print the withs
 
      if not Withs then
         return;
      end if;
 
      declare
         Context_Item : Node_Id;
 
      begin
         Context_Item := First (Context_Items (Cunit (Unit_Num)));
         while Present (Context_Item)
           and then (Nkind (Context_Item) /= N_With_Clause
                      or else Limited_Present (Context_Item))
         loop
            Context_Item := Next (Context_Item);
         end loop;
 
         if Present (Context_Item) then
            Indent;
            Write_Line ("withs:");
            Indent;
 
            while Present (Context_Item) loop
               if Nkind (Context_Item) = N_With_Clause
                 and then not Limited_Present (Context_Item)
               then
                  pragma Assert (Present (Library_Unit (Context_Item)));
                  Write_Unit_Name
                    (Unit_Name
                       (Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
 
                  if Implicit_With (Context_Item) then
                     Write_Str (" -- implicit");
                  end if;
 
                  Write_Eol;
               end if;
 
               Context_Item := Next (Context_Item);
            end loop;
 
            Outdent;
            Write_Line ("end withs");
            Outdent;
         end if;
      end;
   end Write_Unit_Info;
 
end Sem;
Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [sem.adb] - Blame information for rev 281

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- S E M --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. --`
17			`-- --`
18			`-- You should have received a copy of the GNU General Public License along --`
19			`-- with this program; see file COPYING3. If not see --`
20			`-- <http://www.gnu.org/licenses/>. --`
21			`-- --`
22			`-- GNAT was originally developed by the GNAT team at New York University. --`
23			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
24			`-- --`
25			`------------------------------------------------------------------------------`
26
27			`with Atree; use Atree;`
28			`with Debug; use Debug;`
29			`with Debug_A; use Debug_A;`
30			`with Elists; use Elists;`
31			`with Errout; use Errout;`
32			`with Expander; use Expander;`
33			`with Fname; use Fname;`
34			`with HLO; use HLO;`
35			`with Lib; use Lib;`
36			`with Lib.Load; use Lib.Load;`
37			`with Nlists; use Nlists;`
38			`with Output; use Output;`
39			`with Sem_Attr; use Sem_Attr;`
40			`with Sem_Ch2; use Sem_Ch2;`