diff mbox

[Ada] Element allocators in indefinite containers need accessibility checks

Message ID 20120723082034.GA13689@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet July 23, 2012, 8:20 a.m. UTC 
Various operations in the indefinite containers perform initialized allocators
for elements, and accessibility checks are required on those allocators which
can fail when the actual type for Element_Type is a class-wide type and the
operation is passed an element value of a type extension declared at a deeper
level than the container instantiation (violating the check in 4.8(10.1)).
Like other units in the GNAT library, the containers (and their instances)
are compiled with checks suppressed, so the needed accessibility checks are
not performed, which can result in accesses to dispatch tables that have gone
out of scope. A similar problem can occur for element types with access
discriminants. This is corrected by applying pragma Unsuppress in the various
container operations that have allocators initialized by Element_Type formals.
Note that AI12-0035 has been created to address the gap in the language rules,
since these checks should be required.

Tested on x86_64-pc-linux-gnu, committed on trunk

2012-07-23  Gary Dismukes  <dismukes@adacore.com>

	* a-cihama.adb, a-cihase.adb, a-cimutr.adb, a-ciorma.adb, a-ciormu.adb,
	a-ciorse.adb, a-coinho.adb, a-coinve.adb, a-cidlli.adb: Unsuppress
	Accessibility_Check for Element_Type allocators.
diff mbox

Patch

Index: a-cihama.adb
===================================================================
--- a-cihama.adb	(revision 189768)
+++ a-cihama.adb	(working copy)
@@ -694,6 +694,11 @@ 
 
          Position.Node.Key := new Key_Type'(Key);
 
+         declare
+            pragma Unsuppress (Accessibility_Check);
+            --  The element allocator may need an accessibility check in the
+            --  case the actual type is class-wide or has access discriminants
+            --  (see RM 4.8(10.1) and AI12-0035).
          begin
             Position.Node.Element := new Element_Type'(New_Item);
          exception
@@ -731,6 +736,11 @@ 
          K  : Key_Access := new Key_Type'(Key);
          E  : Element_Access;
 
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+
       begin
          E := new Element_Type'(New_Item);
          return new Node_Type'(K, E, Next);
@@ -1166,6 +1176,11 @@ 
 
       Node.Key := new Key_Type'(Key);
 
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
       begin
          Node.Element := new Element_Type'(New_Item);
       exception
@@ -1215,6 +1230,10 @@ 
       declare
          X : Element_Access := Position.Node.Element;
 
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
       begin
          Position.Node.Element := new Element_Type'(New_Item);
          Free_Element (X);
Index: a-coinve.adb
===================================================================
--- a-coinve.adb	(revision 189768)
+++ a-coinve.adb	(working copy)
@@ -1698,7 +1698,14 @@ 
             --  value, in case the allocation fails (either because there is no
             --  storage available, or because element initialization fails).
 
-            Container.Elements.EA (Idx) := new Element_Type'(New_Item);
+            declare
+               pragma Unsuppress (Accessibility_Check);
+               --  The element allocator may need an accessibility check in the
+               --  case actual type is class-wide or has access discriminants
+               --  (see RM 4.8(10.1) and AI12-0035).
+            begin
+               Container.Elements.EA (Idx) := new Element_Type'(New_Item);
+            end;
 
             --  The allocation of the element succeeded, so it is now safe to
             --  update the Last index, restoring container invariants.
@@ -1744,7 +1751,14 @@ 
                   --  because there is no storage available, or because element
                   --  initialization fails).
 
-                  E (Idx) := new Element_Type'(New_Item);
+                  declare
+                     pragma Unsuppress (Accessibility_Check);
+                     --  The element allocator may need an accessibility check
+                     --  in case the actual type is class-wide or has access
+                     --  discriminants (see RM 4.8(10.1) and AI12-0035).
+                  begin
+                     E (Idx) := new Element_Type'(New_Item);
+                  end;
 
                   --  The allocation of the element succeeded, so it is now
                   --  safe to update the Last index, restoring container
@@ -1780,6 +1794,11 @@ 
                --  K always has a value if the exception handler triggers.
 
                K := Before;
+               declare
+                  pragma Unsuppress (Accessibility_Check);
+                  --  The element allocator may need an accessibility check in
+                  --  the case the actual type is class-wide or has access
+                  --  discriminants (see RM 4.8(10.1) and AI12-0035).
                begin
                   while K < Index loop
                      E (K) := new Element_Type'(New_Item);
@@ -1885,7 +1904,14 @@ 
                --  because there is no storage available, or because element
                --  initialization fails).
 
-               Dst.EA (Idx) := new Element_Type'(New_Item);
+               declare
+                  pragma Unsuppress (Accessibility_Check);
+                  --  The element allocator may need an accessibility check in
+                  --  the case the actual type is class-wide or has access
+                  --  discriminants (see RM 4.8(10.1) and AI12-0035).
+               begin
+                  Dst.EA (Idx) := new Element_Type'(New_Item);
+               end;
 
                --  The allocation of the element succeeded, so it is now safe
                --  to update the Last index, restoring container invariants.
@@ -1925,7 +1951,14 @@ 
                --  already been updated), so if this allocation fails we simply
                --  let it propagate.
 
-               Dst.EA (Idx) := new Element_Type'(New_Item);
+               declare
+                  pragma Unsuppress (Accessibility_Check);
+                  --  The element allocator may need an accessibility check in
+                  --  the case the actual type is class-wide or has access
+                  --  discriminants (see RM 4.8(10.1) and AI12-0035).
+               begin
+                  Dst.EA (Idx) := new Element_Type'(New_Item);
+               end;
             end loop;
          end if;
       end;
@@ -3174,6 +3207,11 @@ 
 
       declare
          X : Element_Access := Container.Elements.EA (Index);
+
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  where the actual type is class-wide or has access discriminants
+         --  (see RM 4.8(10.1) and AI12-0035).
       begin
          Container.Elements.EA (Index) := new Element_Type'(New_Item);
          Free (X);
@@ -3205,6 +3243,11 @@ 
 
       declare
          X : Element_Access := Container.Elements.EA (Position.Index);
+
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  where the actual type is class-wide or has access discriminants
+         --  (see RM 4.8(10.1) and AI12-0035).
       begin
          Container.Elements.EA (Position.Index) := new Element_Type'(New_Item);
          Free (X);
@@ -3949,6 +3992,11 @@ 
 
       Last := Index_Type'First;
 
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  where the actual type is class-wide or has access discriminants
+         --  (see RM 4.8(10.1) and AI12-0035).
       begin
          loop
             Elements.EA (Last) := new Element_Type'(New_Item);
Index: a-ciorse.adb
===================================================================
--- a-ciorse.adb	(revision 189768)
+++ a-ciorse.adb	(working copy)
@@ -1173,9 +1173,16 @@ 
               "attempt to tamper with elements (set is locked)";
          end if;
 
-         X := Position.Node.Element;
-         Position.Node.Element := new Element_Type'(New_Item);
-         Free_Element (X);
+         declare
+            pragma Unsuppress (Accessibility_Check);
+            --  The element allocator may need an accessibility check in the
+            --  case the actual type is class-wide or has access discriminants
+            --  (see RM 4.8(10.1) and AI12-0035).
+         begin
+            X := Position.Node.Element;
+            Position.Node.Element := new Element_Type'(New_Item);
+            Free_Element (X);
+         end;
       end if;
    end Include;
 
@@ -1238,6 +1245,11 @@ 
       --------------
 
       function New_Node return Node_Access is
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+
          Element : Element_Access := new Element_Type'(New_Item);
 
       begin
@@ -1818,9 +1830,16 @@ 
            "attempt to tamper with elements (set is locked)";
       end if;
 
-      X := Node.Element;
-      Node.Element := new Element_Type'(New_Item);
-      Free_Element (X);
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+      begin
+         X := Node.Element;
+         Node.Element := new Element_Type'(New_Item);
+         Free_Element (X);
+      end;
    end Replace;
 
    ---------------------
@@ -1854,6 +1873,10 @@ 
       --------------
 
       function New_Node return Node_Access is
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
       begin
          Node.Element := new Element_Type'(Item);  -- OK if fails
          Node.Color := Red;
@@ -1883,8 +1906,15 @@ 
               "attempt to tamper with elements (set is locked)";
          end if;
 
-         Node.Element := new Element_Type'(Item);
-         Free_Element (X);
+         declare
+            pragma Unsuppress (Accessibility_Check);
+            --  The element allocator may need an accessibility check in the
+            --  case the actual type is class-wide or has access discriminants
+            --  (see RM 4.8(10.1) and AI12-0035).
+         begin
+            Node.Element := new Element_Type'(Item);
+            Free_Element (X);
+         end;
 
          return;
       end if;
@@ -1901,8 +1931,15 @@ 
                  "attempt to tamper with elements (set is locked)";
             end if;
 
-            Node.Element := new Element_Type'(Item);
-            Free_Element (X);
+            declare
+               pragma Unsuppress (Accessibility_Check);
+               --  The element allocator may need an accessibility check in the
+               --  case actual type is class-wide or has access discriminants
+               --  (see RM 4.8(10.1) and AI12-0035).
+            begin
+               Node.Element := new Element_Type'(Item);
+               Free_Element (X);
+            end;
 
             return;
          end if;
Index: a-cidlli.adb
===================================================================
--- a-cidlli.adb	(revision 189768)
+++ a-cidlli.adb	(working copy)
@@ -888,6 +888,13 @@ 
       end if;
 
       declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+         --  allocator in the loop below, because the one in this block would
+         --  have failed already.
+
          Element : Element_Access := new Element_Type'(New_Item);
       begin
          New_Node := new Node_Type'(Element, null, null);
@@ -1461,8 +1468,12 @@ 
       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 
       declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+
          X : Element_Access := Position.Node.Element;
-
       begin
          Position.Node.Element := new Element_Type'(New_Item);
          Free (X);
Index: a-cimutr.adb
===================================================================
--- a-cimutr.adb	(revision 189768)
+++ a-cimutr.adb	(working copy)
@@ -291,7 +291,17 @@ 
            with "attempt to tamper with cursors (tree is busy)";
       end if;
 
-      Element := new Element_Type'(New_Item);
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+         --  allocator in the loop below, because the one in this block would
+         --  have failed already.
+      begin
+         Element := new Element_Type'(New_Item);
+      end;
+
       First := new Tree_Node_Type'(Parent  => Parent.Node,
                                    Element => Element,
                                    others  => <>);
@@ -1240,7 +1250,17 @@ 
 
       Position.Container := Parent.Container;
 
-      Element := new Element_Type'(New_Item);
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+         --  allocator in the loop below, because the one in this block would
+         --  have failed already.
+      begin
+         Element := new Element_Type'(New_Item);
+      end;
+
       Position.Node := new Tree_Node_Type'(Parent  => Parent.Node,
                                            Element => Element,
                                            others  => <>);
@@ -1805,7 +1825,17 @@ 
            with "attempt to tamper with cursors (tree is busy)";
       end if;
 
-      Element := new Element_Type'(New_Item);
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the
+         --  allocator in the loop below, because the one in this block would
+         --  have failed already.
+      begin
+         Element := new Element_Type'(New_Item);
+      end;
+
       First := new Tree_Node_Type'(Parent  => Parent.Node,
                                    Element => Element,
                                    others  => <>);
@@ -2163,7 +2193,14 @@ 
            with "attempt to tamper with elements (tree is locked)";
       end if;
 
-      E := new Element_Type'(New_Item);
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+      begin
+         E := new Element_Type'(New_Item);
+      end;
 
       X := Position.Node.Element;
       Position.Node.Element := E;
Index: a-ciormu.adb
===================================================================
--- a-ciormu.adb	(revision 189768)
+++ a-ciormu.adb	(working copy)
@@ -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- --
@@ -1167,6 +1167,11 @@ 
       --------------
 
       function New_Node return Node_Access is
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+
          Element : Element_Access := new Element_Type'(New_Item);
 
       begin
@@ -1768,6 +1773,11 @@ 
 
          declare
             X : Element_Access := Node.Element;
+
+            pragma Unsuppress (Accessibility_Check);
+            --  The element allocator may need an accessibility check in the
+            --  case the actual type is class-wide or has access discriminants
+            --  (see RM 4.8(10.1) and AI12-0035).
          begin
             Node.Element := new Element_Type'(Item);
             Free_Element (X);
@@ -1793,6 +1803,10 @@ 
          --------------
 
          function New_Node return Node_Access is
+            pragma Unsuppress (Accessibility_Check);
+            --  The element allocator may need an accessibility check in the
+            --  case the actual type is class-wide or has access discriminants
+            --  (see RM 4.8(10.1) and AI12-0035).
          begin
             Node.Element := new Element_Type'(Item);  -- OK if fails
             Node.Color := Red_Black_Trees.Red;
Index: a-cihase.adb
===================================================================
--- a-cihase.adb	(revision 189768)
+++ a-cihase.adb	(working copy)
@@ -185,6 +185,11 @@ 
 
    procedure Assign (Node : Node_Access; Item : Element_Type) is
       X : Element_Access := Node.Element;
+
+      pragma Unsuppress (Accessibility_Check);
+      --  The element allocator may need an accessibility check in the case the
+      --  actual type is class-wide or has access discriminants (RM 4.8(10.1)
+      --  and AI12-0035).
    begin
       Node.Element := new Element_Type'(Item);
       Free_Element (X);
@@ -807,7 +812,14 @@ 
 
          X := Position.Node.Element;
 
-         Position.Node.Element := new Element_Type'(New_Item);
+         declare
+            pragma Unsuppress (Accessibility_Check);
+            --  The element allocator may need an accessibility check in the
+            --  case the actual type is class-wide or has access discriminants
+            --  (see RM 4.8(10.1) and AI12-0035).
+         begin
+            Position.Node.Element := new Element_Type'(New_Item);
+         end;
 
          Free_Element (X);
       end if;
@@ -863,6 +875,11 @@ 
       --------------
 
       function New_Node (Next : Node_Access) return Node_Access is
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+
          Element : Element_Access := new Element_Type'(New_Item);
       begin
          return new Node_Type'(Element, Next);
@@ -1317,7 +1334,14 @@ 
 
       X := Node.Element;
 
-      Node.Element := new Element_Type'(New_Item);
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
+      begin
+         Node.Element := new Element_Type'(New_Item);
+      end;
 
       Free_Element (X);
    end Replace;
Index: a-ciorma.adb
===================================================================
--- a-ciorma.adb	(revision 189768)
+++ a-ciorma.adb	(working copy)
@@ -812,6 +812,11 @@ 
 
          Position.Node.Key := new Key_Type'(Key);
 
+         declare
+            pragma Unsuppress (Accessibility_Check);
+            --  The element allocator may need an accessibility check in the
+            --  case the actual type is class-wide or has access discriminants
+            --  (see RM 4.8(10.1) and AI12-0035).
          begin
             Position.Node.Element := new Element_Type'(New_Item);
          exception
@@ -852,6 +857,10 @@ 
       function New_Node return Node_Access is
          Node : Node_Access := new Node_Type;
 
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
       begin
          Node.Key := new Key_Type'(Key);
          Node.Element := new Element_Type'(New_Item);
@@ -1492,6 +1501,11 @@ 
 
       Node.Key := new Key_Type'(Key);
 
+      declare
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
       begin
          Node.Element := new Element_Type'(New_Item);
       exception
@@ -1542,6 +1556,10 @@ 
       declare
          X : Element_Access := Position.Node.Element;
 
+         pragma Unsuppress (Accessibility_Check);
+         --  The element allocator may need an accessibility check in the case
+         --  the actual type is class-wide or has access discriminants (see
+         --  RM 4.8(10.1) and AI12-0035).
       begin
          Position.Node.Element := new Element_Type'(New_Item);
          Free_Element (X);
Index: a-coinho.adb
===================================================================
--- a-coinho.adb	(revision 189768)
+++ a-coinho.adb	(working copy)
@@ -2,11 +2,11 @@ 
 --                                                                          --
 --                         GNAT LIBRARY COMPONENTS                          --
 --                                                                          --
---       A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S        --
+--     A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S    --
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---             Copyright (C) 2011, Free Software Foundation, Inc.           --
+--             Copyright (C) 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- --
@@ -220,8 +220,17 @@ 
          raise Program_Error with "attempt to tamper with elements";
       end if;
 
-      Free (Container.Element);
-      Container.Element := new Element_Type'(New_Item);
+      declare
+         X : Element_Access := Container.Element;
+
+         pragma Unsuppress (Accessibility_Check);
+         --  Element allocator may need an accessibility check in case actual
+         --  type is class-wide or has access discriminants (RM 4.8(10.1) and
+         --  AI12-0035).
+      begin
+         Container.Element := new Element_Type'(New_Item);
+         Free (X);
+      end;
    end Replace_Element;
 
    ---------------
@@ -229,6 +238,10 @@ 
    ---------------
 
    function To_Holder (New_Item : Element_Type) return Holder is
+      pragma Unsuppress (Accessibility_Check);
+      --  The element allocator may need an accessibility check in the case the
+      --  actual type is class-wide or has access discriminants (RM 4.8(10.1)
+      --  and AI12-0035).
    begin
       return (AF.Controlled with new Element_Type'(New_Item), 0);
    end To_Holder;