[multiple changes]

2012-01-23  Robert Dewar  <dewar@adacore.com>

	* sem_prag.ads, sem_prag.adb: Minor reformatting.

2012-01-23  Robert Dewar  <dewar@adacore.com>

	* sem_ch13.adb (Analyze_Aspect_Specifications): Check for
	language defined aspect applied to renaming or formal type
	declaration (not permitted)

2012-01-23  Matthew Heaney  <heaney@adacore.com>

	* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb (Vet): Replaced
	comment with pragma Assert.

From-SVN: r183423

7 files changed, 155 insertions, 54 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 4830074..c18fced 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2012-01-23  Robert Dewar  <dewar@adacore.com>
+
+	* sem_prag.ads, sem_prag.adb: Minor reformatting.
+
+2012-01-23  Robert Dewar  <dewar@adacore.com>
+
+	* sem_ch13.adb (Analyze_Aspect_Specifications): Check for
+	language defined aspect applied to renaming or formal type
+	declaration (not permitted)
+
+2012-01-23  Matthew Heaney  <heaney@adacore.com>
+
+	* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb (Vet): Replaced
+	comment with pragma Assert.
+
 2012-01-23  Vincent Pucci  <pucci@adacore.com>
 
 	* sem_ch12.adb (Analyze_Generic_Subprogram_Declaration): Call
diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb
index 40f5d8f..28c9622 100644
--- a/gcc/ada/a-cbdlli.adb
+++ b/gcc/ada/a-cbdlli.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -81,6 +81,11 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       New_Node  : Count_Type);
 
    function Vet (Position : Cursor) return Boolean;
+   --  Checks invariants of the cursor and its designated container, as a
+   --  simple way of detecting dangling references (see operation Free for a
+   --  description of the detection mechanism), returning True if all checks
+   --  pass. Invocations of Vet are used here as the argument of pragma Assert,
+   --  so the checks are performed only when assertions are enabled.
 
    ---------
    -- "=" --
@@ -682,7 +687,7 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
       --  When an element is deleted from the list container, its node becomes
       --  inactive, and so we set its Prev component to a negative value, to
       --  indicate that it is now inactive. This provides a useful way to
-      --  detect a dangling cursor reference.
+      --  detect a dangling cursor reference (and which is used in Vet).
 
       N (X).Prev := -1;  -- Node is deallocated (not on active list)
 
@@ -2184,6 +2189,14 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
             return False;
          end if;
 
+         --  An invariant of an active node is that its Previous and Next
+         --  components are non-negative. Operation Free sets the Previous
+         --  component of the node to the value -1 before actually deallocating
+         --  the node, to mark the node as inactive. (By "dellocating" we mean
+         --  only that the node is linked onto a list of inactive nodes used
+         --  for storage.) This marker gives us a simple way to detect a
+         --  dangling reference to a node.
+
          if N (Position.Node).Prev < 0 then  -- see Free
             return False;
          end if;
@@ -2206,9 +2219,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
             return False;
          end if;
 
-         --  If we get here, we know that this disjunction is true:
-         --  N (Position.Node).Prev /= 0 or else Position.Node = L.First
-         --  Why not do this with an assertion???
+         pragma Assert (N (Position.Node).Prev /= 0
+                          or else Position.Node = L.First);
 
          if N (Position.Node).Next = 0
            and then Position.Node /= L.Last
@@ -2216,9 +2228,8 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
             return False;
          end if;
 
-         --  If we get here, we know that this disjunction is true:
-         --  N (Position.Node).Next /= 0 or else Position.Node = L.Last
-         --  Why not do this with an assertion???
+         pragma Assert (N (Position.Node).Next /= 0
+                          or else Position.Node = L.Last);
 
          if L.Length = 1 then
             return L.First = L.Last;
@@ -2264,21 +2275,17 @@ package body Ada.Containers.Bounded_Doubly_Linked_Lists is
             return False;
          end if;
 
-         --  Eliminate earlier disjunct
-
-         if Position.Node = L.First then
+         if Position.Node = L.First then  -- eliminates earlier disjunct
             return True;
          end if;
 
-         --  If we get to this point, we know that this predicate is true:
-         --  N (Position.Node).Prev /= 0
+         pragma Assert (N (Position.Node).Prev /= 0);
 
          if Position.Node = L.Last then  -- eliminates earlier disjunct
             return True;
          end if;
 
-         --  If we get to this point, we know that this predicate is true:
-         --  N (Position.Node).Next /= 0
+         pragma Assert (N (Position.Node).Next /= 0);
 
          if N (N (Position.Node).Next).Prev /= Position.Node then
             return False;
diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb
index 55defae..1346e86 100644
--- a/gcc/ada/a-cdlili.adb
+++ b/gcc/ada/a-cdlili.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -65,6 +65,11 @@ package body Ada.Containers.Doubly_Linked_Lists is
       New_Node  : Node_Access);
 
    function Vet (Position : Cursor) return Boolean;
+   --  Checks invariants of the cursor and its designated container, as a
+   --  simple way of detecting dangling references (see operation Free for a
+   --  description of the detection mechanism), returning True if all checks
+   --  pass. Invocations of Vet are used here as the argument of pragma Assert,
+   --  so the checks are performed only when assertions are enabled.
 
    ---------
    -- "=" --
@@ -528,8 +533,23 @@ package body Ada.Containers.Doubly_Linked_Lists is
       procedure Deallocate is
          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
    begin
+      --  While a node is in use, as an active link in a list, its Previous and
+      --  Next components must be null, or designate a different node; this is
+      --  a node invariant. Before actually deallocating the node, we set both
+      --  access value components of the node to point to the node itself, thus
+      --  falsifying the node invariant. Subprogram Vet inspects the value of
+      --  the node components when interrogating the node, in order to detect
+      --  whether the cursor's node access value is dangling.
+
+      --  Note that we have no guarantee that the storage for the node isn't
+      --  modified when it is deallocated, but there are other tests that Vet
+      --  does if node invariants appear to be satisifed. However, in practice
+      --  this simple test works well enough, detecting dangling references
+      --  immediately, without needing further interrogation.
+
       X.Prev := X;
       X.Next := X;
+
       Deallocate (X);
    end Free;
 
@@ -1966,6 +1986,13 @@ package body Ada.Containers.Doubly_Linked_Lists is
          return False;
       end if;
 
+      --  An invariant of a node is that its Previous and Next components can
+      --  be null, or designate a different node. Operation Free sets the
+      --  access value components of the node to designate the node itself
+      --  before actually deallocating the node, thus deliberately violating
+      --  the node invariant. This gives us a simple way to detect a dangling
+      --  reference to a node.
+
       if Position.Node.Next = Position.Node then
          return False;
       end if;
@@ -1974,6 +2001,12 @@ package body Ada.Containers.Doubly_Linked_Lists is
          return False;
       end if;
 
+      --  In practice the tests above will detect most instances of a dangling
+      --  reference. If we get here, it means that the invariants of the
+      --  designated node are satisfied (they at least appear to be satisfied),
+      --  so we perform some more tests, to determine whether invariants of the
+      --  designated list are satisfied too.
+
       declare
          L : List renames Position.Container.all;
       begin
@@ -2003,8 +2036,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
             return False;
          end if;
 
-         --  If we get here, we know that this disjunction is true:
-         --  Position.Node.Prev /= null or else Position.Node = L.First
+         pragma Assert (Position.Node.Prev /= null
+                          or else Position.Node = L.First);
 
          if Position.Node.Next = null
            and then Position.Node /= L.Last
@@ -2012,8 +2045,8 @@ package body Ada.Containers.Doubly_Linked_Lists is
             return False;
          end if;
 
-         --  If we get here, we know that this disjunction is true:
-         --  Position.Node.Next /= null or else Position.Node = L.Last
+         pragma Assert (Position.Node.Next /= null
+                          or else Position.Node = L.Last);
 
          if L.Length = 1 then
             return L.First = L.Last;
@@ -2059,23 +2092,17 @@ package body Ada.Containers.Doubly_Linked_Lists is
             return False;
          end if;
 
-         --  Eliminate earlier disjunct
-
-         if Position.Node = L.First then
+         if Position.Node = L.First then  -- eliminates earlier disjunct
             return True;
          end if;
 
-         --  If we get here, we know (disjunctive syllogism) that this
-         --  predicate is true: Position.Node.Prev /= null
-
-         --  Eliminate earlier disjunct
+         pragma Assert (Position.Node.Prev /= null);
 
-         if Position.Node = L.Last then
+         if Position.Node = L.Last then  -- eliminates earlier disjunct
             return True;
          end if;
 
-         --  If we get here, we know (disjunctive syllogism) that this
-         --  predicate is true: Position.Node.Next /= null
+         pragma Assert (Position.Node.Next /= null);
 
          if Position.Node.Next.Prev /= Position.Node then
             return False;
diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb
index 183f6a8..9d4eea1 100644
--- a/gcc/ada/a-cidlli.adb
+++ b/gcc/ada/a-cidlli.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 2004-2011, Free Software Foundation, Inc.         --
+--          Copyright (C) 2004-2012, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -68,6 +68,11 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
       New_Node  : Node_Access);
 
    function Vet (Position : Cursor) return Boolean;
+   --  Checks invariants of the cursor and its designated container, as a
+   --  simple way of detecting dangling references (see operation Free for a
+   --  description of the detection mechanism), returning True if all checks
+   --  pass. Invocations of Vet are used here as the argument of pragma Assert,
+   --  so the checks are performed only when assertions are enabled.
 
    ---------
    -- "=" --
@@ -570,6 +575,23 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 
    begin
+      --  While a node is in use, as an active link in a list, its Previous and
+      --  Next components must be null, or designate a different node; this is
+      --  a node invariant. For this indefinite list, there is an additional
+      --  invariant: that the element access value be non-null. Before actually
+      --  deallocating the node, we set the node access value components of the
+      --  node to point to the node itself, and set the element access value to
+      --  null (by deallocating the node's element), thus falsifying the node
+      --  invariant. Subprogram Vet inspects the value of the node components
+      --  when interrogating the node, in order to detect whether the cursor's
+      --  node access value is dangling.
+
+      --  Note that we have no guarantee that the storage for the node isn't
+      --  modified when it is deallocated, but there are other tests that Vet
+      --  does if node invariants appear to be satisifed. However, in practice
+      --  this simple test works well enough, detecting dangling references
+      --  immediately, without needing further interrogation.
+
       X.Next := X;
       X.Prev := X;
 
@@ -2048,6 +2070,14 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
          return False;
       end if;
 
+      --  An invariant of a node is that its Previous and Next components can
+      --  be null, or designate a different node. Also, its element access
+      --  value must be non-null. Operation Free sets the node access value
+      --  components of the node to designate the node itself, and the element
+      --  access value to null, before actually deallocating the node, thus
+      --  deliberately violating the node invariant. This gives us a simple way
+      --  to detect a dangling reference to a node.
+
       if Position.Node.Next = Position.Node then
          return False;
       end if;
@@ -2060,6 +2090,12 @@ package body Ada.Containers.Indefinite_Doubly_Linked_Lists is
          return False;
       end if;
 
+      --  In practice the tests above will detect most instances of a dangling
+      --  reference. If we get here, it means that the invariants of the
+      --  designated node are satisfied (they at least appear to be satisfied),
+      --  so we perform some more tests, to determine whether invariants of the
+      --  designated list are satisfied too.
+
       declare
          L : List renames Position.Container.all;
       begin
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 7e46a78..978c6ba 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -890,6 +890,28 @@ package body Sem_Ch13 is
                end loop;
             end if;
 
+            --  Check some general restrictions on language defined aspects
+
+            if not Impl_Defined_Aspects (A_Id) then
+               Error_Msg_Name_1 := Nam;
+
+               --  Not allowed for renaming declarations
+
+               if Nkind (N) in N_Renaming_Declaration then
+                  Error_Msg_N
+                    ("aspect % not allowed for renaming declaration",
+                     Aspect);
+               end if;
+
+               --  Not allowed for formal type declarations
+
+               if Nkind (N) = N_Formal_Type_Declaration then
+                  Error_Msg_N
+                    ("aspect % not allowed for formal type declaration",
+                     Aspect);
+               end if;
+            end if;
+
             --  Copy expression for later processing by the procedures
             --  Check_Aspect_At_[Freeze_Point | End_Of_Declarations]
 
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 73d57a4..26289cb 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -15247,27 +15247,24 @@ package body Sem_Prag is
    -- Make_Aspect_For_PPC_In_Gen_Sub_Decl --
    -----------------------------------------
 
-   --  Convert any PPC and pragmas that appear within a generic subprogram
-   --  declaration into aspect.
-
    procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id) is
-      Aspects          : constant List_Id := New_List;
-      Loc              : constant Source_Ptr := Sloc (Decl);
-      Or_Decl          : constant Node_Id := Original_Node (Decl);
-      Aspect           : Node_Id;
+      Aspects : constant List_Id := New_List;
+      Loc     : constant Source_Ptr := Sloc (Decl);
+      Or_Decl : constant Node_Id := Original_Node (Decl);
+      Aspect  : Node_Id;
+
       Original_Aspects : List_Id;
       --  To capture global references, a copy of the created aspects must be
       --  inserted in the original tree.
 
-      Prag             : Node_Id;
-      Prag_Arg_Ass     : Node_Id;
-      Prag_Id          : Pragma_Id;
+      Prag         : Node_Id;
+      Prag_Arg_Ass : Node_Id;
+      Prag_Id      : Pragma_Id;
 
    begin
-      Prag := Next (Decl);
-
       --  Check for any PPC pragmas that appear within Decl
 
+      Prag := Next (Decl);
       while Nkind (Prag) = N_Pragma loop
          Prag_Id := Get_Pragma_Id (Chars (Pragma_Identifier (Prag)));
 
@@ -15298,18 +15295,20 @@ package body Sem_Prag is
       --  Set all new aspects into the generic declaration node
 
       if Is_Non_Empty_List (Aspects) then
-         --  Create the list of aspects which will be inserted in the original
-         --  tree.
+
+         --  Create the list of aspects to be inserted in the original tree
 
          Original_Aspects := Copy_Separate_List (Aspects);
 
          --  Check if Decl already has aspects
+
          --  Attach the new lists of aspects to both the generic copy and the
          --  original tree.
 
          if Has_Aspects (Decl) then
             Append_List (Aspects, Aspect_Specifications (Decl));
             Append_List (Original_Aspects, Aspect_Specifications (Or_Decl));
+
          else
             Set_Parent (Aspects, Decl);
             Set_Aspect_Specifications (Decl, Aspects);
@@ -15335,9 +15334,7 @@ package body Sem_Prag is
          --  In ASIS mode, for a pragma generated from a source aspect, also
          --  analyze the original aspect expression.
 
-         if ASIS_Mode
-           and then Present (Corresponding_Aspect (N))
-         then
+         if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
             Preanalyze_Spec_Expression
               (Original_Node (Get_Pragma_Arg (Arg_Req)), Standard_Boolean);
          end if;
@@ -15350,9 +15347,7 @@ package body Sem_Prag is
          --  In ASIS mode, for a pragma generated from a source aspect, also
          --  analyze the original aspect expression.
 
-         if ASIS_Mode
-           and then Present (Corresponding_Aspect (N))
-         then
+         if ASIS_Mode and then Present (Corresponding_Aspect (N)) then
             Preanalyze_Spec_Expression
               (Original_Node (Get_Pragma_Arg (Arg_Ens)), Standard_Boolean);
          end if;
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index 503b658..ede9d28 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -113,9 +113,8 @@ package Sem_Prag is
    procedure Make_Aspect_For_PPC_In_Gen_Sub_Decl (Decl : Node_Id);
    --  This routine makes aspects from precondition or postcondition pragmas
    --  that appear within a generic subprogram declaration. Decl is the generic
-   --  subprogram declaration node.
-   --  Note that the aspects are attached to the generic copy and also to the
-   --  orginal tree.
+   --  subprogram declaration node. Note that the aspects are attached to the
+   --  generic copy and also to the orginal tree.
 
    procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
    --  Called at the start of processing compilation unit N to deal with any