Version 1.1 of acs/ac-00073.txt

Unformatted version of acs/ac-00073.txt version 1.1
Other versions for file acs/ac-00073.txt

!standard 3.2.1(03)          03-09-12 AC95-00073/01
!class confirmation 03-09-12
!status received no action 03-09-12
!status received 03-08-21
!subject Is this legal?
!summary
!appendix

From: Martin Krischik
Sent: Thursday, August 21, 2003  1:16 PM

there has been some dispute about the attached code of mine and I would
appreciate some comment from your side.

I have attached the relevant part and the full source us available at
ada.krischik.com.

[Editor's note: see the next message for the code.]

****************************************************************

From: Adam Beneschan
Sent: Thursday, August 21, 2003  1:42 PM

The comp.lang.ada post that Martin referred to is based on source from
the following web sites.

adacl.sourceforge.net/html/______Include__bc-support-tagged_dynamic__ads.htm
adacl.sourceforge.net/html/______Include__bc-support-tagged_dynamic__adb.htm

I've included the source itself at the end of this mail message, with
a comment -- AMBIGUOUS on the line which I believe contains an
ambiguous function call.

Regarding Robert Eachus' comment on c.l.a:

> Please forward the actual example to ada-comment@ada-auth.org.  I've
> looked at it, and I think that "we all know" what is meant, but that
> isn't what the standard says...

Actually, I'm not completely clear on what is meant.  When a tagged
type T has a primitive operator Op, and we call Op with operands of
type T'Class, this isn't really an operator on type T'Class, but a way
to tell the compiler to dispatch to the correct version of Op.  So
does it actually make sense to try to override this by declaring an
explicit subprogram Op with parameters of type T'Class?  I'm not sure
it does, because there's no "real" subprogram there to override.  But
in essence, that's what this code seems to be trying to do:

    generic
       type Item (<>) is abstract tagged private;
       with function "=" (L, R : Item'Class) return Boolean is <>;
       type Item_Ptr is access all Item'Class;
       [etc.]
    package Pkg is ...

If I'm not mistaken, the declaration of Item causes "=" to be
implicitly declared, and the meaning of "=" on objects of type Item is
whatever the primitive operation is for the actual type (4.5.2(15)).
So if, in the generic, "=" is used on objects of type Item'Class, it
would automatically dispatch, even without the "with function"
declaration.  So is the intent to allow the instantiation to specify a
NON-dispatching function that overrides the dispatching one (setting
aside the objection that there's nothing to override) and thus
prevents dispatching from taking place?  If not, then what is the
generic formal function intended to accomplish?

In fact, I'm not even convinced that *any* generic with the above
generic formal part can be legally instantiated, unless an explicit
association is provided for "=".  If an instantiation attempts to use
the default for "=", 12.6(6) says that the expected profile for the
actual parameter is the same as that of the formal, 8.6(26) says this
means the profile has to be type conformant with the formal, and
6.3.1(15) says that the parameter types thus have to be the same.
This means that, if the actual for Item is Item_Actual, instantiating
with a default is legal only if there is a function declared with the
name "=" whose parameters are Item_Actual'Class (Item_Actual isn't
good enough).

But it's my contention that there is normally no such function (unless
one is explicitly declared, which would then be unusable because any
call on it would be ambiguous).  If you declare a tagged type
Item_Actual, this causes this to be implicitly declared:

    function "=" (Left, Right : Item_Actual) return boolean is...

but *not* this:

    function "=" (Left, Right : Item_Actual'Class) return boolean is...

I don't see anywhere in the RM where it says that functions with
class-wide type parameters are ever implicitly declared.  (They don't
need to be, because of 8.6(23) and 3.9.2.)  So putting it all
together, it seems to me that if you try to instantiate Pkg without an
explicit association for "=", the compiler should complain that it
can't find a matching subprogram for "=".

===============================================================================

--  Copyright 1994 Grady Booch
--  Copyright 2003 Martin Krischik
--  Copyright 1994-1997 David Weller
--  Copyright 1998-2002 Simon Wright <simon@pushface.org>

--  This package is free software; you can redistribute it and/or
--  modify it under terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2, or
--  (at your option) any later version. This package is distributed in
--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--  PARTICULAR PURPOSE. See the GNU General Public License for more
--  details. You should have received a copy of the GNU General Public
--  License distributed with this package; see file COPYING.  If not,
--  write to the Free Software Foundation, 59 Temple Place - Suite
--  330, Boston, MA 02111-1307, USA.

--  As a special exception, if other files instantiate generics from
--  this unit, or you link this unit with other files to produce an
--  executable, this unit does not by itself cause the resulting
--  executable to be covered by the GNU General Public License.  This
--  exception does not however invalidate any other reasons why the
--  executable file might be covered by the GNU Public License.
pragma License (Modified_GPL);

--  $RCSfile: ac-00073.txt,v $
--  $Revision: 1.1 $
--  $Date: 2003/09/19 01:42:25 $
--  $Author: Randy $

with Ada.Finalization;
with Ada.Streams;
with System.Storage_Pools;
with BC.Support.Smart_Pointers;
pragma Elaborate (BC.Support.Smart_Pointers);

generic
   type Item (<>) is abstract tagged private;
   with function "=" (L, R : Item'Class) return Boolean is <>;
   type Item_Ptr is access all Item'Class;
   Storage : in out System.Storage_Pools.Root_Storage_Pool'Class;
   Initial_Size : Positive := 10;
package BC.Support.Tagged_Dynamic is

   pragma Elaborate_Body;

   type Dyn_Node is private;
   --  An optimally-packed dynamic container whose items are stored on
   --  the heap

   function "=" (Left, Right : Dyn_Node) return Boolean;

   procedure Clear (Obj : in out Dyn_Node);
   --  Empty the container of all Items

   procedure Insert (Obj : in out Dyn_Node; Elem : Item'Class);
   --  Add an item to the front of the container

   procedure Insert (Obj : in out Dyn_Node; Elem : Item'Class; Before : Positive);
   --  Add an item to the container, before the given index

   procedure Append (Obj : in out Dyn_Node; Elem : Item'Class);
   --  Add an item to the end of the container

   procedure Append (Obj : in out Dyn_Node; Elem : Item'Class; After : Positive);
   --  Add an item to the end of the container, after the given index

   procedure Remove (Obj : in out Dyn_Node; From : Positive);
   --  Remove the item at a given index

   procedure Replace (Obj : in out Dyn_Node; Index : Positive; Elem : Item'Class);
   --  Replace the Item at Index with the new Elem

   function Length (Obj : Dyn_Node) return Natural;
   --  Returns the number of items in the container

   function First (Obj : Dyn_Node) return Item'Class;
   --  Returns the Item at the front of the container

   function Last (Obj : Dyn_Node) return Item'Class;
   --  Returns the item at the end of the container

   function Item_At (Obj : Dyn_Node; Index : Positive) return Item'Class;
   function Item_At (Obj : Dyn_Node; Index : Positive) return Item_Ptr;
   --  Returns the item at the given index

   function Location (Obj : Dyn_Node; Elem : Item'Class; Start : Positive := 1)
                     return Natural;
   --  Returns the first index in which the given item is
   --  found. Returns 0 if unsuccessful.

   procedure Preallocate (Obj : in out Dyn_Node;
                          New_Length : Natural := Initial_Size);
   --  Preallocate New_Length number of unused items for the container

   procedure Set_Chunk_Size (Obj : in out Dyn_Node; Size : Natural);
   --  Set the Chunk_Size for the container

   function Chunk_Size (Obj : in Dyn_Node) return Natural;
   --  Returns the current Chunk_Size

private

   package Smart
   is new BC.Support.Smart_Pointers (
      T => Item'Class,
      P => Item_Ptr);
   type Dyn_Arr is array (Positive range <>) of Smart.Pointer;

   type Dyn_Arr_Ref is access all Dyn_Arr;
   for Dyn_Arr_Ref'Storage_Pool use Storage;

   type Dyn_Node is new Ada.Finalization.Controlled with record
      Ref        : Dyn_Arr_Ref;
      Size       : Natural := 0;
      Chunk_Size : Natural := Initial_Size;
   end record;

   procedure Initialize (D : in out Dyn_Node);
   procedure Adjust (D : in out Dyn_Node);
   procedure Finalize (D : in out Dyn_Node);

   procedure Write_Dyn_Node
     (Stream : access Ada.Streams.Root_Stream_Type'Class;
      Obj : Dyn_Node);

   procedure Read_Dyn_Node
     (Stream : access Ada.Streams.Root_Stream_Type'Class;
      Obj : out Dyn_Node);

   for Dyn_Node'Write use Write_Dyn_Node;
   for Dyn_Node'Read use Read_Dyn_Node;

end BC.Support.Tagged_Dynamic;

===============================================================================

--  Copyright 1994 Grady Booch
--  Copyright 2003 Martin Krischik
--  Copyright 1994-1997 David Weller
--  Copyright 1998-2002 Simon Wright <simon@pushface.org>

--  This package is free software; you can redistribute it and/or
--  modify it under terms of the GNU General Public License as
--  published by the Free Software Foundation; either version 2, or
--  (at your option) any later version. This package is distributed in
--  the hope that it will be useful, but WITHOUT ANY WARRANTY; without
--  even the implied warranty of MERCHANTABILITY or FITNESS FOR A
--  PARTICULAR PURPOSE. See the GNU General Public License for more
--  details. You should have received a copy of the GNU General Public
--  License distributed with this package; see file COPYING.  If not,
--  write to the Free Software Foundation, 59 Temple Place - Suite
--  330, Boston, MA 02111-1307, USA.

--  As a special exception, if other files instantiate generics from
--  this unit, or you link this unit with other files to produce an
--  executable, this unit does not by itself cause the resulting
--  executable to be covered by the GNU General Public License.  This
--  exception does not however invalidate any other reasons why the
--  executable file might be covered by the GNU Public License.
pragma License (Modified_GPL);

--  $RCSfile: ac-00073.txt,v $
--  $Revision: 1.1 $
--  $Date: 2003/09/19 01:42:25 $
--  $Author: Randy $

with Ada.Unchecked_Deallocation;
with BC.Support.Exceptions;

package body BC.Support.Tagged_Dynamic is

   package BSE renames BC.Support.Exceptions;
   procedure Assert
   is new BSE.Assert ("BC.Support.Tagged_Dynamic");

   --  We can't take 'Access of non-aliased components. But if we
   --  alias discriminated objects they become constrained - even if
   --  the discriminant has a default.

   procedure Delete_Arr is
      new Ada.Unchecked_Deallocation (Dyn_Arr, Dyn_Arr_Ref);

   procedure Extend (Obj : in out Dyn_Node);

   function "=" (Left, Right : Dyn_Node) return Boolean is
   begin
      if Left.Size /= Right.Size then
         return False;
      else
         --  We have to compare element-by-element; LRM 4.5.2(24)
         for I in 1 .. Left.Size loop
            if Smart.Value (Left.Ref (I)) /= Smart.Value (Right.Ref (I)) then
               return False;
            end if;
         end loop;
         return True;
      end if;
   end "=";

   procedure Clear (Obj : in out Dyn_Node) is
   begin
      Delete_Arr (Obj.Ref);
      Preallocate (Obj);
      Obj.Size := 0;
   end Clear;

   procedure Extend (Obj : in out Dyn_Node) is
      Temp : Dyn_Arr_Ref;
   begin
      Temp := new Dyn_Arr (1 .. Obj.Ref'Last + Obj.Chunk_Size);
      Temp (1 .. Obj.Size) := Obj.Ref (1 .. Obj.Size);
      Delete_Arr (Obj.Ref);
      Obj.Ref := Temp;
   end Extend;

   procedure Insert (Obj : in out Dyn_Node; Elem : Item'Class) is
   begin
      if Obj.Size = Obj.Ref'Last then
         Extend (Obj);
      end if;
      Obj.Ref (2 .. Obj.Size + 1) := Obj.Ref (1 .. Obj.Size);
      Obj.Ref (1) := Smart.Create (Value => new Item'Class'(Elem));
      Obj.Size := Obj.Size + 1;
   end Insert;

   procedure Insert (Obj : in out Dyn_Node; Elem : Item'Class; Before : Positive) is
   begin
      Assert (Before <= Obj.Size,
              BC.Range_Error'Identity,
              "Insert",
              BSE.Invalid_Index);
      if Obj.Size = 0 or else Before = 1 then
         Insert (Obj, Elem);
      else
         if Obj.Size = Obj.Ref'Last then
            Extend (Obj);
         end if;
         Obj.Ref (Before + 1 .. Obj.Size + 1) := Obj.Ref (Before .. Obj.Size);
         Obj.Ref (Before) := Smart.Create (Value => new Item'Class'(Elem));
         Obj.Size := Obj.Size + 1;
      end if;
   end Insert;

   procedure Append (Obj : in out Dyn_Node; Elem : Item'Class) is
   begin
      if Obj.Size >= Obj.Ref'Last then
         Extend (Obj);
      end if;
      Obj.Size := Obj.Size + 1;
      Obj.Ref (Obj.Size) := Smart.Create (Value => new Item'Class'(Elem));
   end Append;

   procedure Append (Obj : in out Dyn_Node; Elem : Item'Class; After : Positive) is
   begin
      Assert (After <= Obj.Size,
              BC.Range_Error'Identity,
              "Append",
              BSE.Invalid_Index);
      if Obj.Size = Obj.Ref'Last then
         Extend (Obj);
      end if;
      if After = Obj.Size then
         Obj.Size := Obj.Size + 1;
         Obj.Ref (Obj.Size) := Smart.Create (Value => new Item'Class'(Elem));
      else
         Obj.Ref (After + 2 .. Obj.Size + 1) :=
           Obj.Ref (After + 1 .. Obj.Size);
         Obj.Size := Obj.Size + 1;
         Obj.Ref (After + 1) := Smart.Create (Value => new Item'Class'(Elem));
      end if;
   end Append;

   procedure Remove (Obj : in out Dyn_Node; From : Positive) is
   begin
      Assert (From <= Obj.Size,
              BC.Range_Error'Identity,
              "Remove",
              BSE.Invalid_Index);
      Assert (Obj.Size > 0,
              BC.Underflow'Identity,
              "Remove",
              BSE.Empty);
      if Obj.Size = 1 then
         Clear (Obj);
      else
         Obj.Ref (From .. Obj.Size - 1) := Obj.Ref (From + 1 .. Obj.Size);
         Obj.Size := Obj.Size - 1;
      end if;
   end Remove;

   procedure Replace (Obj : in out Dyn_Node; Index : Positive; Elem : Item'Class) is
   begin
      Assert (Index <= Obj.Size,
              BC.Range_Error'Identity,
              "Replace",
              BSE.Invalid_Index);
      Obj.Ref (Index) := Smart.Create (Value => new Item'Class'(Elem));
   end Replace;

   function Length (Obj : Dyn_Node) return Natural is
   begin
      return Obj.Size;
   end Length;

   function First (Obj : Dyn_Node) return Item'Class is
   begin
      Assert (Obj.Size > 0,
              BC.Underflow'Identity,
              "First",
              BSE.Empty);
      return Smart.Value (Obj.Ref (1)).all;
   end First;

   function Last (Obj : Dyn_Node) return Item'Class is
   begin
      Assert (Obj.Size > 0,
              BC.Underflow'Identity,
              "Last",
              BSE.Empty);
      return Smart.Value (Obj.Ref (Obj.Size)).all;
   end Last;

   function Item_At (Obj : Dyn_Node; Index : Positive) return Item'Class is
   begin
      Assert (Index <= Obj.Size,
              BC.Range_Error'Identity,
              "Item_At",
              BSE.Invalid_Index);
      return Smart.Value (Obj.Ref (Index)).all;
   end Item_At;

   function Item_At (Obj : Dyn_Node; Index : Positive) return Item_Ptr is
   begin
      Assert (Index <= Obj.Size,
              BC.Range_Error'Identity,
              "Item_At",
              BSE.Invalid_Index);
      return Smart.Value (Obj.Ref (Index));
   end Item_At;

   function Location (Obj : Dyn_Node; Elem : Item'Class; Start : Positive := 1)
                     return Natural is
   begin
      --  XXX the C++ (which indexes from 0) nevertheless checks
      --  "start <= count". We have to special-case the empty Node; the
      --  C++ indexes from 0, so it can legally start with index 0
      --  when the Node is empty.
      if Obj.Size = 0 then
         return 0;
      end if;
      Assert (Start <= Obj.Size,
              BC.Range_Error'Identity,
              "Location",
              BSE.Invalid_Index);
      for I in Start .. Obj.Size loop
         if Smart.Value (Obj.Ref (I)).all = Elem then   -- AMBIGUOUS
                -- Smart.Value returns a result of type Item_Ptr  --ajb
            return I;
         end if;
      end loop;
      return 0;  -- Not located
   end Location;

   procedure Preallocate (Obj : in out Dyn_Node;
                          New_Length : Natural := Initial_Size) is
      Temp : Dyn_Arr_Ref;
      Last : Natural;
   begin
      --  XXX I don't think this algorithm is very clever! we really
      --  shouldn't have to allocate a temporary and then delete it ..
      if Obj.Ref /= null then
         Temp := new Dyn_Arr (1 .. Obj.Ref'Last);
         Temp (1 .. Obj.Ref'Last) := Obj.Ref.all;
         Last := Obj.Ref'Last;
         Delete_Arr (Obj.Ref);
      else
         Last := 0;
      end if;
      Obj.Ref := new Dyn_Arr (1 .. Last + New_Length);
      if Last /= 0 then -- something was in the array already
         Obj.Ref (1 .. Obj.Size) := Temp (1 .. Obj.Size);
         Delete_Arr (Temp);
      end if;
   end Preallocate;

   procedure Set_Chunk_Size (Obj : in out Dyn_Node; Size : Natural) is
   begin
      Obj.Chunk_Size := Size;
   end Set_Chunk_Size;

   function Chunk_Size (Obj : in Dyn_Node) return Natural is
   begin
      return Obj.Chunk_Size;
   end Chunk_Size;

   procedure Initialize (D : in out Dyn_Node) is
   begin
      D.Ref := new Dyn_Arr (1 .. Initial_Size);
      D.Size := 0;
      D.Chunk_Size := Initial_Size;
   end Initialize;

   procedure Adjust (D : in out Dyn_Node) is
      Tmp : Dyn_Arr_Ref := new Dyn_Arr (1 .. D.Ref'Last);
   begin
      Tmp (1 .. D.Size) := D.Ref (1 .. D.Size);
      D.Ref := Tmp;
   end Adjust;

   procedure Finalize (D : in out Dyn_Node) is
   begin
      if D.Ref /= null then
         Delete_Arr (D.Ref);
         D.Ref := null;
      end if;
   end Finalize;

   procedure Write_Dyn_Node
     (Stream : access Ada.Streams.Root_Stream_Type'Class;
      Obj : Dyn_Node) is
   begin
      Integer'Write (Stream, Obj.Size);
      for I in 1 .. Obj.Size loop
         Item'Class'Output (Stream, Smart.Value (Obj.Ref (I)).all);
      end loop;
   end Write_Dyn_Node;

   procedure Read_Dyn_Node
     (Stream : access Ada.Streams.Root_Stream_Type'Class;
      Obj : out Dyn_Node) is
      Count : Integer;
   begin
      Clear (Obj);
      Integer'Read (Stream, Count);
      for I in 1 .. Count loop
         declare
            Elem : constant Item'Class := Item'Class'Input (Stream);
         begin
            Append (Obj, Elem);
         end;
      end loop;
   end Read_Dyn_Node;

end BC.Support.Tagged_Dynamic;

****************************************************************

From: Tucker Taft
Sent: Thursday, August 21, 2003  2:48 PM

> Actually, I'm not completely clear on what is meant.  When a tagged
> type T has a primitive operator Op, and we call Op with operands of
> type T'Class, this isn't really an operator on type T'Class, but a way
> to tell the compiler to dispatch to the correct version of Op.

Correct.

> ... So
> does it actually make sense to try to override this by declaring an
> explicit subprogram Op with parameters of type T'Class?  I'm not sure
> it does, because there's no "real" subprogram there to override.

That's true.

> ...  But
> in essence, that's what this code seems to be trying to do:
>
>     generic
>        type Item (<>) is abstract tagged private;
>        with function "=" (L, R : Item'Class) return Boolean is <>;
>        type Item_Ptr is access all Item'Class;
>        [etc.]
>     package Pkg is ...
>
> If I'm not mistaken, the declaration of Item causes "=" to be
> implicitly declared, and the meaning of "=" on objects of type Item is
> whatever the primitive operation is for the actual type (4.5.2(15)).
> So if, in the generic, "=" is used on objects of type Item'Class, it
> would automatically dispatch, even without the "with function"
> declaration.

True.  Before dispatching, it would make sure the 'tags match,
and if not, return False.

> ... So is the intent to allow the instantiation to specify a
> NON-dispatching function that overrides the dispatching one (setting
> aside the objection that there's nothing to override) and thus
> prevents dispatching from taking place?

I suppose, though as you point out, that doesn't really
work very well, because you end up with ambiguity rather
than overriding.

> ...  If not, then what is the
> generic formal function intended to accomplish?

You'll have to contact the author presumably.

>
> In fact, I'm not even convinced that *any* generic with the above
> generic formal part can be legally instantiated, unless an explicit
> association is provided for "=".

Agreed.

> ... If an instantiation attempts to use
> the default for "=", 12.6(6) says that the expected profile for the
> actual parameter is the same as that of the formal, 8.6(26) says this
> means the profile has to be type conformant with the formal, and
> 6.3.1(15) says that the parameter types thus have to be the same.
> This means that, if the actual for Item is Item_Actual, instantiating
> with a default is legal only if there is a function declared with the
> name "=" whose parameters are Item_Actual'Class (Item_Actual isn't
> good enough).
>
> But it's my contention that there is normally no such function (unless
> one is explicitly declared, which would then be unusable because any
> call on it would be ambiguous).  If you declare a tagged type
> Item_Actual, this causes this to be implicitly declared:
>
>     function "=" (Left, Right : Item_Actual) return boolean is...
>
> but *not* this:
>
>     function "=" (Left, Right : Item_Actual'Class) return boolean is...
>
> I don't see anywhere in the RM where it says that functions with
> class-wide type parameters are ever implicitly declared.  (They don't
> need to be, because of 8.6(23) and 3.9.2.)  So putting it all
> together, it seems to me that if you try to instantiate Pkg without an
> explicit association for "=", the compiler should complain that it
> can't find a matching subprogram for "=".

I agree.

I am not sure what is the point of this message, but I agree
with your analysis.  Are you asking for a language change,
or simply noting that this generic package seems to be flawed?

****************************************************************

From: Tucker Taft
Sent: Thursday, August 21, 2003  4:01 PM

Actually, I interpreted Robert's c.l.a post as a suggestion that
perhaps something did need to be discussed here---that maybe he saw a
flaw that something the author wanted to do couldn't be done legally
in Ada.  That's what I was attempting to respond to.  It's likely that
I read something into his comment that wasn't there.  In any case, I'm
not asking for a language change (I don't see a need), and the main
reason I posted the original example to c.l.a was to double-check
whether my analysis was correct or whether I had missed something in
the RM.  Also, I wanted to forward the actual code where I took the
excerpt from, as Robert requested.

****************************************************************

Questions? Ask the ACAA Technical Agent