Seems like a GNAT bug with Unbounded_Strings

Seems like a GNAT bug with Unbounded_Strings

[Tom Di Sessa]

[-- Attachment #1: Type: text/plain, Size: 2044 bytes --]

Attached are five files, one package spec(broken.ads),
                         one package body(broken.adb),
                        one generic package spec(generic_lists_pkg.ads),
                        one generic package body(generic_lists_pkg.ads),
                        and a subprogram body(test_us.adb).

I have been experimenting with Ada '95's dispatching across class-wide
types and I have run into this problem:

I have a tagged type that includes in its record a variable of type 
Unbounded_String.  Now, in a child type from that type I have a list of
this type access grandparent_type'Class(and parent of the type that
includes the Unbounded_String)

In order to add to the list I use new and then append it to the current
list.  Everything works fine in appending and getting data from the list
until I do this:

I create a variable.  Assign data to it.  Add it to a list. Then assign
data to that same variable.  Now when I check the list, the spot where I
added the variable(which should now be independent of the variable,
because I newwed the data space for it) has been changed.

Okey, there is the problem.  We are stilling running GNAT 3.01 on
Solaris 2.4.  I would kinda not like to hear, "Well, upgrade and try
again." because I am not in charge of those things here(I'm just a lowly
Software Engineer).  I would rather like to hear, "Well, we changed that
in that later versions so it should work"  or "I tried your code in 3.05
and it worked perfectly!".

Thank you for your time.

-tom :) 

p.s. - Sorry about the headers.
-- 


+------------------------------------------------------------------+
| Thomas G. Di Sessa           ||                                  |
|   WPL Laboratories, Inc.     || Email: tdisessa@wpllabs.com      |
|   Whitehall Offices, Suite 6 || Voice: 610.658.2362 ext. 227     |
|   410 Lancaster Avenue       ||   Fax: 610.658.2361              |
|   Haverford, PA  19041       ||                                  |
+------------------------------------------------------------------+

[-- Attachment #2: test_us.adb --]
[-- Type: text/plain, Size: 391 bytes --]

with broken;
with Ada.Text_IO;

procedure test_us is
   Holder : broken.Broken_Type;
   A      : broken.Broken_Type;
begin
   broken.Replace (A, "Correct");

   broken.Add (Holder, A);
   Ada.Text_IO.Put_Line ("The Value in Holder is: " & broken.Value (Holder));

   broken.Replace (A, "Incorrect");
   Ada.Text_IO.Put_Line ("The Value in Holder is: " & broken.Value (Holder));
end test_us;

[-- Attachment #3: generic_lists_pkg.ads --]
[-- Type: text/plain, Size: 1207 bytes --]

-- ===========================================================================
-- Copyright 1996 by WPL Laboratories, Inc.  All Rights Reserved
--
--                        WPL Laboratories, Inc.
--                        Whitehall Offices, Suite 6
--                        410 Lancaster Avenue
--                        Haverford, PA 19041
--
--
-- For Support call 610-658-2362
--
-- $Revision: 1.1 $ $Date: 1995/01/15 19:48:46 $
--
-- ===========================================================================
 
generic

  type Element_Type is abstract tagged private;

package Generic_Lists_Pkg is

  type List_Type;
  type List_Ptr_Type is access all List_Type;
  type Element_Ptr_Type is access all Element_Type'Class;
  type List_Type is
    record
       This : Element_Ptr_Type;
       Next : List_Ptr_Type;
    end record;

  End_of_List : exception;

  procedure Add_to_End (List    : in out List_Ptr_Type;
                        Element : in     Element_Type'Class);


  procedure Next (List    : in out List_Ptr_Type;
                  Element :    out Element_Ptr_Type);
    -- removes access to previous list elements
    -- raises End_of_list if there are no more

end Generic_Lists_Pkg;

[-- Attachment #4: generic_lists_pkg.adb --]
[-- Type: text/plain, Size: 1609 bytes --]

-- ===========================================================================
-- Copyright 1996 by WPL Laboratories, Inc.  All Rights Reserved
--
--                        WPL Laboratories, Inc.
--                        Whitehall Offices, Suite 6
--                        410 Lancaster Avenue
--                        Haverford, PA 19041
--
--
-- For Support call 610-658-2362
--
-- $Revision: 1.1 $ $Date: 1995/01/15 19:48:46 $
--
-- ===========================================================================

with Ada.Text_IO;
 
package body Generic_Lists_Pkg is

  procedure Add_to_End (List    : in out List_Ptr_Type;
                        Element : in     Element_Type'Class) is

    List_Ptr_Tmp : List_Ptr_Type;

  begin
    if List = null then
      Ada.Text_IO.Put_Line (Element'External_Tag);
      List := new List_Type'(This => new Element_Type'Class'(Element),
                             Next => null);
    else
      List_Ptr_Tmp := List;
      while List_Ptr_Tmp.Next /= null loop
        List_Ptr_Tmp := List_Ptr_Tmp.Next;
      end loop;
      List_Ptr_Tmp.Next := new List_Type'(This => new Element_Type'Class'(Element),
                                          Next => null);
    end if;
  end add_to_End;


  procedure Next (List    : in out List_Ptr_Type;
                  Element :    out Element_Ptr_Type) is
    -- removes access to previous list elements
    -- raises End_of_List if there are no more
  begin
    if List = null then
      raise End_of_List;
    else
      Element := List.This;
      List    := List.Next;
    end if; 
  end next;

end Generic_Lists_Pkg;

[-- Attachment #5: broken.ads --]
[-- Type: text/plain, Size: 4321 bytes --]

-- ===========================================================================
-- Copyright 1996 by WPL Laboratories, Inc.  All Rights Reserved
--
--                        WPL Laboratories, Inc.
--                        Whitehall Offices, Suite 6
--                        410 Lancaster Avenue
--                        Haverford, PA 19041
--
--
-- For Support call 610-658-2362
--
-- $Revision: 1.1 $ $Date: 1995/01/15 19:48:46 $
--  
-- ===========================================================================

with Ada.Strings.Unbounded;
use Ada.Strings.Unbounded;
with Ada.Text_IO;
with Generic_Lists_Pkg;

package broken is

   -- =======================================================================
   -- PURPOSE:
   --
   --    To demonstrater a problem with Unbounded_Strings
   -- 
   -- OUTSTANDING ISSUES:
   -- =======================================================================  

   -- ====================
   -- Base
   -- ====================

   type Base_Type is abstract tagged private;

   -- ====================
   -- Text_Holder
   -- ====================

   type Text_Holder_Type is abstract new Base_Type with private;

   procedure Add (Holder  : in out Text_Holder_Type;
                  Text    : in     String);
   -- ====================================================================
   -- PURPOSE:
   --    Appends Text to already existing data in Holder.
   -- ====================================================================

   procedure Replace (Holder  : in out Text_Holder_Type;
                      Text    : in     String);
   -- ====================================================================
   -- PURPOSE:
   --    Zeros out Data of Holder and adds new Text to Holder.
   -- ====================================================================

   function Value (Holder : in Text_Holder_Type) return String;
   -- ====================================================================
   -- PURPOSE:
   --    Return Holder's text.
   -- ====================================================================


   -- ====================
   -- Object_Holder
   -- ====================

   type Object_Holder_Type is abstract new Text_Holder_Type with private;
      
   function Value (Holder : in Object_Holder_Type) return String;
   -- ====================================================================
   -- PURPOSE:
   --    Return Holder's text.
   -- ====================================================================

   
   -- ====================
   -- Broken
   -- ====================

   type Broken_Type is new Object_Holder_Type with private;

   procedure Add (Holder  : in out Object_Holder_Type'Class;
                  Item    : in     Broken_Type);
   -- ====================================================================
   -- PURPOSE:
   --    Add a Broken_Type(Item) to any Object_Holder_Type(Holder) 
   -- ====================================================================

   procedure Replace (Holder  : in out Object_Holder_Type'Class;
                      Item    : in     Broken_Type);
   -- ====================================================================
   -- PURPOSE:
   --    Zeros out Data of Holder and adds a new Item to Holder.
   -- ====================================================================

   -- ========================================================================
   -- Private Section!!!
   -- ========================================================================


   private
   
   type Base_Type is abstract tagged null record;
   
   type Text_Holder_Type is abstract new Base_Type with
      record
         Data: Unbounded_String := To_Unbounded_String ("");
      end record;

   package List_Handler is new Generic_Lists_Pkg (Element_Type => Base_Type);
   
   type Object_Holder_Type is abstract new Text_Holder_Type with 
      record
         Object_List_Ptr: List_Handler.List_Ptr_Type := null;
      end record;
      
   function Data_Value (Holder : in Object_Holder_Type) return String;
   -- ====================================================================
   -- PURPOSE:
   --    Return Holder's Objects.
   -- ====================================================================
   
   type Broken_Type is new Object_Holder_Type with null record;
end broken;

[-- Attachment #6: broken.adb --]
[-- Type: text/plain, Size: 5379 bytes --]

-- ===========================================================================
-- Copyright 1996 by WPL Laboratories, Inc.  All Rights Reserved
--
--                        WPL Laboratories, Inc.
--                        Whitehall Offices, Suite 6
--                        410 Lancaster Avenue
--                        Haverford, PA 19041
--
--
-- For Support call 610-658-2362
--
-- $Revision: 1.1 $ $Date: 1995/01/15 19:48:46 $
--
-- ===========================================================================
 
use Ada.Strings.Unbounded;
with Ada.Strings.Fixed;
use Ada.Strings.Fixed;

package body broken is
 
   -- =======================================================================
   -- PURPOSE:
   --
   -- OUTSTANDING ISSUES:
   -- =======================================================================

   -- =========================
   -- Text_Holder_Type
   -- =========================
 
   -- ====================================================================
   -- Add
   -- 
   -- PURPOSE:
   --    Add Text into the Holder
   -- ====================================================================

   procedure Add (Holder  : in out Text_Holder_Type;
                  Text    : in    String) is
   begin
      Append (Holder.Data, Text);
   end Add;

   -- ====================================================================
   -- Replace
   -- 
   -- PURPOSE:
   --    Zeros out Data of Holder and adds a new Item to Holder.
   -- ====================================================================

   procedure Replace (Holder  : in out Text_Holder_Type;
                      Text    : in     String) is
   begin
      Holder.Data := To_Unbounded_String (Text);
   end Replace;

   -- ====================================================================
   -- Value
   -- 
   -- PURPOSE:
   --    Returns the Holder with its included data.
   -- ====================================================================

   function Value (Holder : in Text_Holder_Type) return String is
   begin
      return (To_String (Holder.Data));
   end Value;

   -- ========================
   -- Object_Holder
   -- ========================

   -- ====================================================================
   -- Data_Value
   -- 
   -- PURPOSE:
   --    Returns the Holder with its included data.
   -- ====================================================================

   function Data_Value (Holder : in Object_Holder_Type) return String is
      Str_Len      : Natural := Length (Holder.Data);
      Val          : Unbounded_String;
      Amt_Left     : String := To_String (Holder.Data);
      Old_Index    : Positive := 1;
      New_Index    : Positive := 1;
      List_Ptr     : List_Handler.List_Ptr_Type    := Holder.Object_List_Ptr;
      Object_Ptr   : List_Handler.Element_Ptr_Type := null;
   begin
      if Count (Holder.Data, ">OBJECT<") = 0 then
         return To_String (Holder.Data);
      else
         for i in 1..Count (Holder.Data, ">OBJECT<")
          loop
            List_Handler.Next (List_Ptr, Object_Ptr);
            Old_Index := New_Index;
            New_Index := Index (Amt_Left (Old_Index .. Amt_Left'Last), ">OBJECT<");
            if Old_Index /= New_Index then
               Append (Val, Amt_Left(Old_Index .. New_Index - 1));
            end if;
            Append (Val, Value (Text_Holder_Type'Class (Object_Ptr.All)));
            New_Index := New_Index + 8;
          end loop;
         
         Append (Val, Amt_Left (New_Index .. Amt_Left'Last));
      end if;
       
      return To_String (Val);
   end Data_Value;
   
   -- ====================================================================
   -- Value
   -- 
   -- PURPOSE:
   --    Returns the Holder with its included data.
   -- ====================================================================

   function Value (Holder : in Object_Holder_Type) return String is
   begin
      return (Data_Value (Holder)); 
   end Value;


   -- ====================
   -- Broken_Type
   -- ====================

   -- ====================================================================
   -- Add
   -- 
   -- PURPOSE:
   --    Add an Item to the Holder
   -- ====================================================================

   procedure Add (Holder  : in out Object_Holder_Type'Class;
                  Item    : in     Broken_Type) is
   begin
      List_Handler.Add_To_End (List    => Holder.Object_List_Ptr,
                               Element => Item);
               
      -- -----------------------------------------------
      -- Now add Object placement modifier here!
      -- -----------------------------------------------
   
      Append (Holder.Data, ">OBJECT<");
         
   end Add;

   -- ====================================================================
   -- Replace
   -- 
   -- PURPOSE:
   --    Zeros out Data of Holder and adds a new Item to Holder.
   -- ====================================================================

   procedure Replace (Holder  : in out Object_Holder_Type'Class;
                      Item    : in     Broken_Type) is
   begin
      Holder.Object_List_Ptr := null;
      List_Handler.Add_To_End (List    => Holder.Object_List_Ptr,
                               Element => Item);
               
      Holder.Data := To_Unbounded_String (">OBJECT<");
   end Replace;

end broken;

Re: Seems like a GNAT bug with Unbounded_Strings

[j. doe]

well, except for a couple of minor compilation problems with the source you
sent (perhaps caught by gnat 3.05 that were not caught by gnat 3.01), your
code appeared to work fine for me:

16 johndoe/_Ada/_test> test_us
BROKEN.BASE_TYPE
The Value in Holder is: Correct
The Value in Holder is: Correct
517 johndoe/_Ada/_test> 

that appears to be what you expect, n'est pas?

--johndoe

Re: Seems like a GNAT bug with Unbounded_Strings

[Robert Dewar]

"Tom Di Sessa: Seems like a GNAT bug with Unbounded_Strings"

maybe it is, maybe it is not a GNAT bug, I certainly did not look at it.
If you want me, and the other people in the GNAT team to look and see if
this is a bug, please follow the directions in gnatinfo.txt and submit
the report in proper format to report@gnat.com.

Only a couple of people at ACT read CLA, and those that do, including
me, do not attempt to extract bug reports from CLA postings!