Re: Q: Endless loop by dispatching

[Michael Erdmann <michael.erdmann@snafu.de>]

T. Kurt Bond wrote:

Thanks. In fact i have now selected this aproach. Each package
derives from the base type (A.Object) is forced to implement
a procedure Serialize by definint it in A as abstract.

The bad thing about it, is that i wanted to add some code
which is common to all implementation of A.Object in the
Central Serialize procedure (e.g. writing the attrbiute
name if ront of every field of B.Object) Now i have to duplicate
this code in all implementations of A.Object.

Some time i am realy wondering if there is something like

     Serialize( Super(This) ...)

is missing, which is realy the tag of the superclass of
B.Object.

Thanks
    Michael



> -- 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