another way to shoot yourself in the foot?

[fedya_fedyakoff@inbox.ru]

Consider a very simple code. Suppose we have

1) a Named interface as this

--- named.ads ---

package Named is
   type Object is limited interface;

   function  name(this: Object) return String is abstract;
end Named;

2) Simple implementation

--- Some.ads ---

with Named;
with Ada.Finalization; use Ada.Finalization;
with Ada.Strings.Bounded;

package Some is

   Size : constant := 80;

   package bs is new Ada.Strings.Bounded.Generic_Bounded_Length(Size);
   use bs;

   type Object is new Limited_Controlled and Named.Object with
private;


   function Create( name: String ) return Object;

   overriding procedure Initialize(this: in out Object);
   overriding procedure Finalize(this: in out Object);

   overriding function  name(this: Object) return String;


private
   type Object is new Limited_Controlled and Named.Object with
      record
         the_name: Bounded_String;
      end record;
end Some;

--- Some.adb ---

with ada.Text_IO;

package body Some is
   package tio renames ada.Text_IO;

   function Create( name: String ) return Object is
   begin
      return O : Object do
         O.the_name := To_Bounded_String(name);
      end return;
   end Create;


   procedure Initialize(this: in out Object) is
   begin
      tio.Put_Line("Initialization Car " & this.name);
   end Initialize;

   procedure Finalize(this: in out Object) is
   begin
      tio.Put_Line("Finalization Car " & this.name);
   end Finalize;


   function name(this: Object) return String is
   begin
      return To_String(this.the_name);
   end name;

end Some;

3) Simple factory function as follows:

--- Factory ads ---
with Named;
with Some;

package Factory is
   function Create(class: String; name: String) return
Named.Object'Class;
end Factory;

--- Factory.adb ---

with Ada.Strings.Fixed; use Ada.Strings.Fixed;
with Some;

package body Factory is
   --- this one is ugly, but in sake of simplicity ...
   function Create(class: String; name: String) return
Named.Object'Class is
   begin
      if Index(class, "Some") /= 0 then
         return Some.Create(name);
      end if;
      raise Program_Error with "Unknown class " & class;
   end;
end Factory;
---------------

4) And finally main procedure

--- boom.adb ---

with ada.Text_IO;
with Named; use Named;
with Factory;
with Some;

procedure boom is
   package tio renames ada.Text_IO;
   aNamed: Some.Object := Some.Create("One");
begin
     declare
        aNamed1: Named.Object'Class := Factory.Create("Some", "Two");
     begin
        tio.put_line( "car: " & aNamed1.name ); ---booooooommm!!!
     end;

   tio.put_line( "car: " & aNamed.name );
   tio.Flush;
end boom;
-----------


All of that being compiled without even one warning, crashed at
runtime with PROGRAM_ERROR EXCEPTION_ACCESS_VIOLATION  on Windows
( compiled using gnat gpl 2008 )

Modified program  ( Named.Object, being changed to be not limited, and
Some.Object to be Controlled ) runs perfectly.

I have an idea why the program behavs like that, but i think there
must be some warning at least.

What do you think?