[multiple changes]

2011-08-03  Thomas Quinot  <quinot@adacore.com>

	* scos.adb, get_scos.adb, put_scos.adb
	New code letter for decisions: G (entry guard)
	* par_sco.adb
	(Traverse_Subprogram_Body): Rename to...
	(Traverse_Subprogram_Or_Task_Body): New subrpogram.
	(Traverse_Protected_Body): New subprogram
	(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
	protected bodies and entry bodies.

2011-08-03  Yannick Moy  <moy@adacore.com>

	* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
	entities with get/set subprograms, which is set on procedure entities
	generated by the compiler for a postcondition.
	* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
	* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
	entity for a declaration
	(Get_Unique_Entity_For_Decl): new function returning an entity which
	represents a declaration, so that matching spec and body have the same
	entity.

2011-08-03  Robert Dewar  <dewar@adacore.com>

	* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
	a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting

2011-08-03  Yannick Moy  <moy@adacore.com>

	* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
	library-level because retriction No_Implicit_Dynamic_Code in the
	front-end prevents its definition as a local subprogram
	(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
	for reuse in other contexts
	(Traverse_Declarations_Or_Statements,
	Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
	Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
	procedures take a callback parameter to be called on all declarations
	* lib-xref.ads
	(Traverse_All_Compilation_Units): new generic function to traverse a
	compilation unit and call a callback parameter on all declarations

From-SVN: r177284

gcc/ada/ChangeLog

+2011-08-03  Thomas Quinot  <quinot@adacore.com>
+
+	* scos.adb, get_scos.adb, put_scos.adb
+	New code letter for decisions: G (entry guard)
+	* par_sco.adb
+	(Traverse_Subprogram_Body): Rename to...
+	(Traverse_Subprogram_Or_Task_Body): New subrpogram.
+	(Traverse_Protected_Body): New subprogram
+	(Traverse_Declarations_Or_Statements): Add traversal of task bodies,
+	protected bodies and entry bodies.
+
+2011-08-03  Yannick Moy  <moy@adacore.com>
+
+	* einfo.adb, einfo.ads (Is_Postcondition_Proc): new flag for procedure
+	entities with get/set subprograms, which is set on procedure entities
+	generated by the compiler for a postcondition.
+	* sem_ch6.adb (Process_PPCs): set new flag on postcondition procedures
+	* alfa.adb, alfa.ads (Get_Entity_For_Decl): new function returning the
+	entity for a declaration
+	(Get_Unique_Entity_For_Decl): new function returning an entity which
+	represents a declaration, so that matching spec and body have the same
+	entity.
+
+2011-08-03  Robert Dewar  <dewar@adacore.com>
+
+	* a-except-2005.adb, a-cfhama.adb, a-cfhase.adb, a-cfhase.ads,
+	a-cforma.adb, a-cforse.ads, a-cforse.adb: Minor reformatting
+
+2011-08-03  Yannick Moy  <moy@adacore.com>
+
+	* lib-xref-alfa.adb (Detect_And_Add_ALFA_Scope): make the subprogram
+	library-level because retriction No_Implicit_Dynamic_Code in the
+	front-end prevents its definition as a local subprogram
+	(Traverse_Compilation_Unit): extract new procedure from Add_ALFA_File,
+	for reuse in other contexts
+	(Traverse_Declarations_Or_Statements,
+	Traverse_Handled_Statement_Sequence, Traverse_Package_Body,
+	Traverse_Package_Declaration, Traverse_Subprogram_Body): make all these
+	procedures take a callback parameter to be called on all declarations
+	* lib-xref.ads
+	(Traverse_All_Compilation_Units): new generic function to traverse a
+	compilation unit and call a callback parameter on all declarations
+
 2011-08-03  Javier Miranda  <miranda@adacore.com>
 
 	* sem_prag.adb (Process_Interface_Name): Allow duplicated export names

gcc/ada/a-cfhase.ads

@@ -68,6 +68,7 @@ package Ada.Containers.Formal_Hashed_Sets is
    pragma Pure;
 
    type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private;
+   --  why is this commented out ???
    --  pragma Preelaborable_Initialization (Set);
 
    type Cursor is private;

gcc/ada/a-cforse.ads

@@ -67,6 +67,7 @@ package Ada.Containers.Formal_Ordered_Sets is
    function Equivalent_Elements (Left, Right : Element_Type) return Boolean;
 
    type Set (Capacity : Count_Type) is tagged private;
+   --  why is this commented out ???
    --  pragma Preelaborable_Initialization (Set);
 
    type Cursor is private;

gcc/ada/a-except-2005.adb

@@ -895,9 +895,11 @@ package body Ada.Exceptions is
             Prefix             : constant String := "adjust/finalize raised ";
             Orig_Msg           : constant String := Exception_Message (X);
             Orig_Prefix_Length : constant Natural :=
-              Integer'Min (Prefix'Length, Orig_Msg'Length);
+                                   Integer'Min
+                                     (Prefix'Length, Orig_Msg'Length);
             Orig_Prefix        : String renames Orig_Msg
-              (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1);
+                                   (Orig_Msg'First ..
+                                    Orig_Msg'First + Orig_Prefix_Length - 1);
 
          begin
             --  Message already has the proper prefix, just re-raise

gcc/ada/alfa.adb

@@ -23,8 +23,10 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Atree;    use Atree;
 with Output;   use Output;
 with Put_ALFA;
+with Sinfo;    use Sinfo;
 
 package body ALFA is
 
@@ -153,6 +155,74 @@ package body ALFA is
       ALFA_Xref_Table.Init;
    end Initialize_ALFA_Tables;
 
+   -------------------------
+   -- Get_Entity_For_Decl --
+   -------------------------
+
+   function Get_Entity_For_Decl (N : Node_Id) return Entity_Id is
+      E : Entity_Id := Empty;
+
+   begin
+      case Nkind (N) is
+         when N_Subprogram_Declaration |
+              N_Subprogram_Body        |
+              N_Package_Declaration    =>
+            E := Defining_Unit_Name (Specification (N));
+
+         when N_Package_Body =>
+            E := Defining_Unit_Name (N);
+
+         when N_Object_Declaration =>
+            E := Defining_Identifier (N);
+
+         when others =>
+            null;
+      end case;
+
+      if Nkind (E) = N_Defining_Program_Unit_Name then
+         E := Defining_Identifier (E);
+      end if;
+
+      return E;
+   end Get_Entity_For_Decl;
+
+   --------------------------------
+   -- Get_Unique_Entity_For_Decl --
+   --------------------------------
+
+   function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id is
+      E : Entity_Id := Empty;
+
+   begin
+      case Nkind (N) is
+         when N_Subprogram_Declaration |
+              N_Package_Declaration    =>
+            E := Defining_Unit_Name (Specification (N));
+
+         when N_Package_Body =>
+            E := Corresponding_Spec (N);
+
+         when N_Subprogram_Body =>
+            if Acts_As_Spec (N) then
+               E := Defining_Unit_Name (Specification (N));
+            else
+               E := Corresponding_Spec (N);
+            end if;
+
+         when N_Object_Declaration =>
+            E := Defining_Identifier (N);
+
+         when others =>
+            null;
+      end case;
+
+      if Nkind (E) = N_Defining_Program_Unit_Name then
+         E := Defining_Identifier (E);
+      end if;
+
+      return E;
+   end Get_Unique_Entity_For_Decl;
+
    -----------
    -- palfa --
    -----------

gcc/ada/alfa.ads

@@ -323,6 +323,13 @@ package ALFA is
    procedure Initialize_ALFA_Tables;
    --  Reset tables for a new compilation
 
+   function Get_Entity_For_Decl (N : Node_Id) return Entity_Id;
+   --  Return the entity for declaration N
+
+   function Get_Unique_Entity_For_Decl (N : Node_Id) return Entity_Id;
+   --  Return the entity which represents declaration N, so that matching
+   --  declaration and body have the same entity.
+
    procedure palfa;
    --  Debugging procedure to output contents of ALFA binary tables in the
    --  format in which they appear in an ALI file.

gcc/ada/einfo.adb

@@ -521,7 +521,7 @@ package body Einfo is
 
    --    Body_Is_In_ALFA                 Flag251
    --    Is_Processed_Transient          Flag252
-   --    (unused)                        Flag253
+   --    Is_Postcondition_Proc           Flag253
    --    (unused)                        Flag254
 
    -----------------------
@@ -1976,6 +1976,12 @@ package body Einfo is
       return Flag138 (Id);
    end Is_Packed_Array_Type;
 
+   function Is_Postcondition_Proc (Id : E) return B is
+   begin
+      pragma Assert (Ekind (Id) = E_Procedure);
+      return Flag253 (Id);
+   end Is_Postcondition_Proc;
+
    function Is_Potentially_Use_Visible (Id : E) return B is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -4494,6 +4500,12 @@ package body Einfo is
       Set_Flag138 (Id, V);
    end Set_Is_Packed_Array_Type;
 
+   procedure Set_Is_Postcondition_Proc (Id : E; V : B := True) is
+   begin
+      pragma Assert (Ekind (Id) = E_Procedure);
+      Set_Flag253 (Id, V);
+   end Set_Is_Postcondition_Proc;
+
    procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
    begin
       pragma Assert (Nkind (Id) in N_Entity);
@@ -7563,6 +7575,7 @@ package body Einfo is
       W ("Is_Package_Body_Entity",          Flag160 (Id));
       W ("Is_Packed",                       Flag51  (Id));
       W ("Is_Packed_Array_Type",            Flag138 (Id));
+      W ("Is_Postcondition_Proc",           Flag253 (Id));
       W ("Is_Potentially_Use_Visible",      Flag9   (Id));
       W ("Is_Preelaborated",                Flag59  (Id));
       W ("Is_Primitive",                    Flag218 (Id));

gcc/ada/einfo.ads

@@ -2563,6 +2563,10 @@ package Einfo is
 --       an entity, then the Original_Array_Type field of this entity points
 --       to the original array type for which this is the packed array type.
 
+--    Is_Postcondition_Proc (Flag253)
+--       Present in procedures. Set if entity is a procedure generated by the
+--       compiler for a postcondition.
+
 --    Is_Potentially_Use_Visible (Flag9)
 --       Present in all entities. Set if entity is potentially use visible,
 --       i.e. it is defined in a package that appears in a currently active
@@ -5521,6 +5525,7 @@ package Einfo is
    --    Is_Intrinsic_Subprogram             (Flag64)
    --    Is_Machine_Code_Subprogram          (Flag137)  (non-generic case only)
    --    Is_Null_Init_Proc                   (Flag178)
+   --    Is_Postcondition_Proc               (Flag253)  (non-generic case only)
    --    Is_Primitive                        (Flag218)
    --    Is_Primitive_Wrapper                (Flag195)  (non-generic case only)
    --    Is_Private_Descendant               (Flag53)
@@ -6213,6 +6218,7 @@ package Einfo is
    function Is_Package_Body_Entity              (Id : E) return B;
    function Is_Packed                           (Id : E) return B;
    function Is_Packed_Array_Type                (Id : E) return B;
+   function Is_Postcondition_Proc               (Id : E) return B;
    function Is_Potentially_Use_Visible          (Id : E) return B;
    function Is_Preelaborated                    (Id : E) return B;
    function Is_Primitive                        (Id : E) return B;
@@ -6807,6 +6813,7 @@ package Einfo is
    procedure Set_Is_Package_Body_Entity          (Id : E; V : B := True);
    procedure Set_Is_Packed                       (Id : E; V : B := True);
    procedure Set_Is_Packed_Array_Type            (Id : E; V : B := True);
+   procedure Set_Is_Postcondition_Proc           (Id : E; V : B := True);
    procedure Set_Is_Potentially_Use_Visible      (Id : E; V : B := True);
    procedure Set_Is_Preelaborated                (Id : E; V : B := True);
    procedure Set_Is_Primitive                    (Id : E; V : B := True);
@@ -7535,6 +7542,7 @@ package Einfo is
    pragma Inline (Is_Overloadable);
    pragma Inline (Is_Packed);
    pragma Inline (Is_Packed_Array_Type);
+   pragma Inline (Is_Postcondition_Proc);
    pragma Inline (Is_Potentially_Use_Visible);
    pragma Inline (Is_Preelaborated);
    pragma Inline (Is_Primitive);
@@ -7946,6 +7954,7 @@ package Einfo is
    pragma Inline (Set_Is_Package_Body_Entity);
    pragma Inline (Set_Is_Packed);
    pragma Inline (Set_Is_Packed_Array_Type);
+   pragma Inline (Set_Is_Postcondition_Proc);
    pragma Inline (Set_Is_Potentially_Use_Visible);
    pragma Inline (Set_Is_Preelaborated);
    pragma Inline (Set_Is_Primitive);

gcc/ada/get_scos.adb

@@ -307,7 +307,7 @@ begin
 
          --  Decision entry
 
-         when 'I' | 'E' | 'P' | 'W' | 'X' =>
+         when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
             Dtyp := C;
             Skip_Spaces;
 

gcc/ada/par_sco.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2009-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2009-2011, 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- --
@@ -126,7 +126,8 @@ package body Par_SCO is
    procedure Traverse_Handled_Statement_Sequence  (N : Node_Id);
    procedure Traverse_Package_Body                (N : Node_Id);
    procedure Traverse_Package_Declaration         (N : Node_Id);
-   procedure Traverse_Subprogram_Body             (N : Node_Id);
+   procedure Traverse_Protected_Body              (N : Node_Id);
+   procedure Traverse_Subprogram_Or_Task_Body     (N : Node_Id);
    procedure Traverse_Subprogram_Declaration      (N : Node_Id);
    --  Traverse the corresponding construct, generating SCO table entries
 
@@ -439,6 +440,9 @@ package body Par_SCO is
       -------------------
 
       procedure Output_Header (T : Character) is
+         Loc   : Source_Ptr := No_Location;
+         --  Node whose sloc is used for the decision
+
       begin
          case T is
             when 'I' | 'E' | 'W' =>
@@ -446,55 +450,47 @@ package body Par_SCO is
                --  For IF, EXIT, WHILE, the token SLOC can be found from
                --  the SLOC of the parent of the expression.
 
-               Set_Table_Entry
-                 (C1   => T,
-                  C2   => ' ',
-                  From => Sloc (Parent (N)),
-                  To   => No_Location,
-                  Last => False);
+               Loc := Sloc (Parent (N));
 
-            when 'P' =>
+            when 'G' | 'P' =>
 
+               --  For entry, the token sloc is from the N_Entry_Body.
                --  For PRAGMA, we must get the location from the pragma node.
                --  Argument N is the pragma argument, and we have to go up two
                --  levels (through the pragma argument association) to get to
                --  the pragma node itself.
 
-               declare
-                  Loc : constant Source_Ptr := Sloc (Parent (Parent (N)));
+               Loc := Sloc (Parent (Parent (N)));
 
-               begin
-                  Set_Table_Entry
-                    (C1   => 'P',
-                     C2   => 'd',
-                     From => Loc,
-                     To   => No_Location,
-                     Last => False);
+            when 'X' =>
 
-                  --  For pragmas we also must make an entry in the hash table
-                  --  for later access by Set_SCO_Pragma_Enabled. We set the
-                  --  pragma as disabled above, the call will change C2 to 'e'
-                  --  to enable the pragma header entry.
+               --  For an expression, no Sloc
 
-                  Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
-               end;
+               null;
 
-            when 'X' =>
+            --  No other possibilities
 
-               --  For an expression, no Sloc
+            when others =>
+               raise Program_Error;
+         end case;
 
          Set_Table_Entry
-                 (C1   => 'X',
+           (C1   => T,
             C2   => ' ',
-                  From => No_Location,
+            From => Loc,
             To   => No_Location,
             Last => False);
 
-            --  No other possibilities
+         if T = 'P' then
+            --  For pragmas we also must make an entry in the hash table
+            --  for later access by Set_SCO_Pragma_Enabled. We set the
+            --  pragma as disabled now, the call will change C2 to 'e'
+            --  to enable the pragma header entry.
+
+            SCO_Table.Table (SCO_Table.Last).C2 := 'd';
+            Condition_Pragma_Hash_Table.Set (Loc, SCO_Table.Last);
+         end if;
 
-            when others =>
-               raise Program_Error;
-         end case;
       end Output_Header;
 
       ------------------------------
@@ -773,30 +769,34 @@ package body Par_SCO is
 
       --  Traverse the unit
 
-      if Nkind (Lu) = N_Subprogram_Body then
-         Traverse_Subprogram_Body (Lu);
+      case Nkind (Lu) is
+         when N_Protected_Body =>
+            Traverse_Protected_Body (Lu);
 
-      elsif Nkind (Lu) = N_Subprogram_Declaration then
+         when N_Subprogram_Body | N_Task_Body =>
+            Traverse_Subprogram_Or_Task_Body (Lu);
+
+         when N_Subprogram_Declaration =>
             Traverse_Subprogram_Declaration (Lu);
 
-      elsif Nkind (Lu) = N_Package_Declaration then
+         when N_Package_Declaration =>
             Traverse_Package_Declaration (Lu);
 
-      elsif Nkind (Lu) = N_Package_Body then
+         when N_Package_Body =>
             Traverse_Package_Body (Lu);
 
-      elsif Nkind (Lu) = N_Generic_Package_Declaration then
+         when N_Generic_Package_Declaration =>
             Traverse_Generic_Package_Declaration (Lu);
 
-      elsif Nkind (Lu) in N_Generic_Instantiation then
+         when N_Generic_Instantiation =>
             Traverse_Generic_Instantiation (Lu);
 
+         when others =>
             --  All other cases of compilation units (e.g. renamings), generate
             --  no SCO information.
 
-      else
             null;
-      end if;
+      end case;
 
       --  Make entry for new unit in unit tables, we will fill in the file
       --  name and dependency numbers later.
@@ -1144,11 +1144,31 @@ package body Par_SCO is
                     (Parameter_Specifications (Specification (N)), 'X');
                   Set_Statement_Entry;
 
-               --  Subprogram_Body
+               --  Task or subprogram body
 
-               when N_Subprogram_Body =>
+               when N_Task_Body | N_Subprogram_Body =>
                   Set_Statement_Entry;
-                  Traverse_Subprogram_Body (N);
+                  Traverse_Subprogram_Or_Task_Body (N);
+
+               --  Entry body
+
+               when N_Entry_Body =>
+                  declare
+                     Cond : constant Node_Id :=
+                              Condition (Entry_Body_Formal_Part (N));
+                  begin
+                     Set_Statement_Entry;
+                     if Present (Cond) then
+                        Process_Decisions_Defer (Cond, 'G');
+                     end if;
+                     Traverse_Subprogram_Or_Task_Body (N);
+                  end;
+
+               --  Protected body
+
+               when N_Protected_Body =>
+                  Set_Statement_Entry;
+                  Traverse_Protected_Body (N);
 
                --  Exit statement, which is an exit statement in the SCO sense,
                --  so it is included in the current statement sequence, but
@@ -1485,15 +1505,24 @@ package body Par_SCO is
       Traverse_Declarations_Or_Statements (Private_Declarations (Spec));
    end Traverse_Package_Declaration;
 
-   ------------------------------
-   -- Traverse_Subprogram_Body --
-   ------------------------------
+   -----------------------------
+   -- Traverse_Protected_Body --
+   -----------------------------
+
+   procedure Traverse_Protected_Body (N : Node_Id) is
+   begin
+      Traverse_Declarations_Or_Statements (Declarations (N));
+   end Traverse_Protected_Body;
+
+   --------------------------------------
+   -- Traverse_Subprogram_Or_Task_Body --
+   --------------------------------------
 
-   procedure Traverse_Subprogram_Body (N : Node_Id) is
+   procedure Traverse_Subprogram_Or_Task_Body (N : Node_Id) is
    begin
       Traverse_Declarations_Or_Statements (Declarations (N));
       Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
-   end Traverse_Subprogram_Body;
+   end Traverse_Subprogram_Or_Task_Body;
 
    -------------------------------------
    -- Traverse_Subprogram_Declaration --

gcc/ada/put_scos.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2009, Free Software Foundation, Inc.           --
+--          Copyright (C) 2009-2011, 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- --
@@ -142,7 +142,7 @@ begin
 
                   --  Decision
 
-                  when 'I' | 'E' | 'P' | 'W' | 'X' =>
+                  when 'I' | 'E' | 'G' | 'P' | 'W' | 'X' =>
                      Start := Start + 1;
 
                      --  For disabled pragma, skip decision output

gcc/ada/scos.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 2009-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 2009-2011, 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- --
@@ -228,12 +228,13 @@ package SCOs is
 
    --      I  decision in IF statement or conditional expression
    --      E  decision in EXIT WHEN statement
+   --      G  decision in entry guard
    --      P  decision in pragma Assert/Check/Pre_Condition/Post_Condition
    --      W  decision in WHILE iteration scheme
    --      X  decision appearing in some other expression context
 
-   --    For I, E, P, W, sloc is the source location of the IF, EXIT, PRAGMA or
-   --    WHILE token.
+   --    For I, E, G, P, W, sloc is the source location of the IF, EXIT,
+   --    ENTRY, PRAGMA or WHILE token, respectively
 
    --    For X, sloc is omitted
 

gcc/ada/sem_ch6.adb

@@ -9550,6 +9550,9 @@ package body Sem_Ch6 is
                   Make_Handled_Sequence_Of_Statements (Loc,
                     Statements => Plist)));
 
+            Set_Ekind (Post_Proc, E_Procedure);
+            Set_Is_Postcondition_Proc (Post_Proc);
+
             --  If this is a procedure, set the Postcondition_Proc attribute on
             --  the proper defining entity for the subprogram.