Re: Q: Endless loop by dispatching

[tkb@tkb.mpl.com (T. Kurt Bond)]

-- Michael Erdmann <michael.erdmann@snafu.de> asked in message 
-- news:<un82u-4kb.ln1@boavista.snafu.de> about redispatching on 'Class types,
-- which was causing his program to loop endlessly.
--
-- Here's a program that includes his example code and does what (I think) 
-- he wants.
--
with Ada.Text_IO; use Ada.Text_IO;
procedure Test is
   --  From: Michael Erdmann <michael.erdmann@snafu.de>
   --  Subject: Q: Endless loop by dispatching
   --  Newsgroups: comp.lang.ada
   --  Date: Fri, 11 Jul 2003 10:22:54 +0200
   --  Organization: [Posted via] Inter.net Germany GmbH

   --  Dear all,

   --  i got a problem with the following code fragment below. The Idea is
   --  that the procedure Serialize defines the strategy how to display
   --  object which
   --  are derived from A.Object. Searialize simply dispatches into the class
   --  by calling a procedure Write, which does the job for the class.
   package A is
      type Object is tagged record
	 P1 : Natural := 1;
	 P2 : Natural := 2;
      end record;
      type Class_Access is access Object'Class;	         --  added for example.

      procedure Write(This : in Object );
      procedure Serialize(This : in Object'Class );
   end A;

   package body A is
      procedure Serialize(This : in Object'Class ) is
      begin
	 Put_Line ("Serialize (Object'Class) called:");	  --  added for example
	 Write( A.Object (This) );	             --  changed for example!!!
	   -- Since "This" is at Object'Class, "Write (This)" would dispatch
           -- on the actual tag of "This", calling "B.Write" for objects of 
	   -- type "B.Object", which would call "A.Serialize" again, 
	   -- looping forever.  To always call A.Write, construct
	   -- a *view* of the object as being of type "A.object" by using the 
	   -- *view conversion* "A.Object(This)".
      end Serialize;

      procedure Write(This : in Object ) is
      begin
	 Put_Line ("Write (A.Object) called:");	          --  added for example
	 Put_Line( "P1 =" & Natural'Image( This.P1 ) );
	 Put_Line( "P2 =" & Natural'Image( This.P2 ) );
      end Write;
   end A;

   --  In the following fragment i am defining a package B with an
   --  derived objec B.Object as below. When an instance of B.Object
   --  shall be serialized, the element of the super class (A.Object)
   --  shall be serialzed as well. The code looks nice and compiles
   --  but does not work, since the Serialize dispatches again with
   --  Object.B even ther was a a case given  A.Object( This ).

   package B is
      type Object is new A.Object with record
	 Q : Natural := 2;
      end record;

      procedure Write(This : in Object );
   end B;
   -- ..........
   package body B is
      procedure Write(This : in Object ) is
      begin
	 Put_Line ("Write (B.Object) called:");
	 A.Serialize( A.Object( This ) );
	 Put_Line( "Q =" & Natural'Image(This.Q));
      end Write;
   end B;

   --  Does any body know, what this loop causes?! I am not sure
   --  if this is a bug or simply i missed the point.

   --  Michael

   Aobj : A.Object;
   Bobj : B.Object;
   Objs : array (1 .. 4) of A.Class_Access := 
     (new A.Object, new B.Object, new A.Object, new B.Object);
begin
   Put_Line ("Write A");
   A.Write (Aobj);
   New_Line;
   Put_Line ("Write B");
   B.Write (Bobj);
   New_Line;
   Put_Line ("Dispatching calls:");
   for I in Objs'Range loop
      Put_Line ("A.Write (Objs(" & Integer'Image (I) & "))");
      -- This will dispatch, so B.Write will actually be called 
      -- for Objs(2) and Objs(3)
      A.Write (Objs (I).all);
   end loop;
end Test;

-- The preceding program produces the following output when run:
--  Write A
--  Write (A.Object) called:
--  P1 = 1
--  P2 = 2
--
--  Write B
--  Write (B.Object) called:
--  Serialize (Object'Class) called:
--  Write (A.Object) called:
--  P1 = 1
--  P2 = 2
--  Q = 2
--
--  Dispatching calls:
--  A.Write (Objs( 1))
--  Write (A.Object) called:
--  P1 = 1
--  P2 = 2
--  A.Write (Objs( 2))
--  Write (B.Object) called:
--  Serialize (Object'Class) called:
--  Write (A.Object) called:
--  P1 = 1
--  P2 = 2
--  Q = 2
--  A.Write (Objs( 3))
--  Write (A.Object) called:
--  P1 = 1
--  P2 = 2
--  A.Write (Objs( 4))
--  Write (B.Object) called:
--  Serialize (Object'Class) called:
--  Write (A.Object) called:
--  P1 = 1
--  P2 = 2
--  Q = 2