Gem #44: Accessibility Checks (Part III)

by Bob Duff —AdaCore

Let's get started…

In Gems #1 and #2, we showed how the accessibility rules help prevent dangling pointers, by ensuring that pointers cannot point from longer-lived scopes to shorter-lived ones. But what if you want to do that?

In some cases, it is necessary to store a reference to a local object in a global data structure. You can do that by using 'Unchecked_Access instead of 'Access. The "Unchecked" in the name reminds you that you are bypassing the normal accessibility rules. To prevent dangling pointers, you need to remove the pointer from the global data structure before leaving the scope of the object.

As for any unsafe feature, it is a good idea to encapsulate 'Unchecked_Access, rather than scattering it all around the program. You can do this using limited controlled types. The idea is that Initialize plants a pointer to the object in some global data structure, and Finalize removes the pointer just before it becomes a dangling pointer.

Here is an example. Let's assume there are no tasks, and no heap-allocated objects -- otherwise, we would need a more complicated data structure, such as a doubly-linked list, with locking. We keep a stack of objects, implemented as a linked list via Stack_Top and chained through the Prev component. All occurrences of 'Unchecked_Access are encapsulated in the Objects package, and clients of Objects (such as Main, below at end) can freely declare Objects, without worrying about dangling pointers. Stack_Top can never dangle, because Finalize cleans up, even in the case of exceptions and aborts.

Note that 'Unchecked_Access is applied to a formal parameter of type Object, which is legal because formals of tagged types are defined to be aliased. Note also that Print_All_Objects has no visibility on the objects it is printing.

This program prints:

Inside Nested:
  That_Object
  This_Object
After Nested returns:
  This_Object

Observe that That_Object is not printed by the second call to Print_All_Objects, because it no longer exists at that time.

private with Ada.Finalization;
package Objects is

   type Object (Name : access constant String) is limited private;
   --  The Name is just to illustrate what's going on by printing it out.

   procedure For_All_Objects (Action : not null access procedure (X : Object));
   --  Iterate through all existing Objects in reverse order of creation,
   --  calling Action for each one.

   procedure Print_All_Objects;
   --  Print out the Names of all Objects in reverse order of creation.

   --  ... other operations

private

   use Ada;

   type Object (Name : access constant String) is new Finalization.Limited_Controlled with
      record
         --  ... other components
         Prev : access Object := null; -- previous Object on the stack
      end record;

   procedure Initialize (X : in out Object);
   procedure Finalize (X : in out Object);

end Objects;

with Ada.Text_IO;
package body Objects is

   Stack_Top : access Object := null;

   procedure Initialize (X : in out Object) is
   begin
      --  Push X onto the stack:
      X.Prev := Stack_Top;
      Stack_Top := X'Unchecked_Access;
   end Initialize;

   procedure Finalize (X : in out Object) is
   begin
      pragma Assert (Stack_Top = X'Unchecked_Access);
      --  Pop X from the stack:
      Stack_Top := X.Prev;
      X.Prev := null;  --  not really necessary, but safe
   end Finalize;

   procedure For_All_Objects (Action : not null access procedure (X : Object)) is
      --  Loop through the stack from top to bottom.
      Item : access Object := Stack_Top;
   begin
      while Item /= null loop
         Action (Item.all);
         Item := Item.Prev;
      end loop;
   end For_All_Objects;

   procedure Print_All_Objects is
      --  Iterate through the stack using For_All_Objects, passing
      --  Print_One_Object to print each one.
      procedure Print_One_Object(X : Object) is
      begin
         Text_IO.Put_Line ("  " & X.Name.all);
      end Print_One_Object;
   begin
      For_All_Objects (Print_One_Object'Access);
   end Print_All_Objects;

end Objects;

with Ada.Text_IO; use Ada;
with Objects; use Objects;
procedure Main is

   This_Object : Object (Name => new String'("This_Object"));

   procedure Nested is
      That_Object : Object (Name => new String'("That_Object"));
   begin
      Text_IO.Put_Line ("Inside Nested:");
      Print_All_Objects;
   end Nested;

begin
   Nested;
   Text_IO.Put_Line ("After Nested returns:");
   Print_All_Objects;
end Main;