Version 1.1 of acs/ac-00062.txt

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

!standard 7.1(01)          03-07-30 AC95-00062/01
!class amendment 03-07-30
!status received no action 03-07-30
!status received 02-10-27
!subject Private with in a generic package
!summary
!appendix

!topic "with private" in a generic package
!reference RM95-10.01.02, AI-00262
!from Stephen Leake 02-10-26

!discussion

I've run across a need for "with private" in a generic, and I think it
adds a new twist.

"with private" is a proposed addition to Ada; see
http://www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00262.TXT?rev=1.13
Basically, it allows "with"ing a private child package, if it is only
mentioned in the private part of a package spec.

The code below demonstrates a case I came across recently; I need to
mention a private child package in a generic formal association.
Compiling this with GNAT 3.15a1 gives the error:

commands-ints_set_parsed_value.ads:2:06: current unit must also be
private descendant of "Commands"

The problem is with this generic instantiation:

with Interfaces;
with Commands.Ints; -- a private child
with Commands.Gen_Set_Parsed_Value;
procedure Commands.Ints_Set_Parsed_Value is new Commands.Gen_Set_Parsed_Value
  (Actual_Type      => Interfaces.Integer_16,
   Parsed_Type      => Commands.Ints.Parsed_Type,
   Value            => Commands.Ints.Value,
   Actual_Type_Name => "Int");


Here Commands.Ints is a private child package. It is, in fact, only
mentioned in the body of the generic. The analogous procedure
Commands.Reals_Set_Parsed_Value in the code below was written by hand,
to show that the intended result of the generic instantiation is
legal. So if we have "with private" we could do:

with Interfaces;
with private Commands.Ints;
with Commands.Gen_Set_Parsed_Value;
procedure Commands.Ints_Set_Parsed_Value is new Commands.Gen_Set_Parsed_Value
  (Actual_Type      => Interfaces.Integer_16,
   Parsed_Type      => Commands.Ints.Parsed_Type,
   Value            => Commands.Ints.Value,
   Actual_Type_Name => "Int");

However, I think we also need to add the keyword "private" on the
generic formals that are allowed to come from a private package:

generic
   type Actual_Type is private;
   private type Parsed_Type is new Commands.Parsed_Value_Type with private;
   with private function Value (Item : in Parsed_Type) return Actual_Type;
   Actual_Type_Name : in String;
procedure Commands.Gen_Set_Parsed_Value
     (Item         : in out Actual_Type;
      Parsed_Value : in     Commands.Parsed_Value_Type'Class);

That way, the compiler can check while compiling the generic that
these formals are not referenced in the public part of the generic
spec. Thus the generic contract is preserved.

To accomplish the same effect in Ada 95, there are two options; I can
make all the private stuff public and keep the generic, or I can use a
preprocessor instead of a generic.

!example

procedure Commands.Gen_Set_Parsed_Value
  (Item         : in out Actual_Type;
   Parsed_Value : in     Commands.Parsed_Value_Type'Class)
is
begin
   if Parsed_Value in Parsed_Type then
      Item := Value (Parsed_Type (Parsed_Value));
   else
      raise Constraint_Error;
   end if;

end Commands.Gen_Set_Parsed_Value;

generic
   type Actual_Type is private;
   type Parsed_Type is new Commands.Parsed_Value_Type with private;
   with function Value (Item : in Parsed_Type) return Actual_Type;
   Actual_Type_Name : in String;
procedure Commands.Gen_Set_Parsed_Value
     (Item         : in out Actual_Type;
      Parsed_Value : in     Commands.Parsed_Value_Type'Class);

package body Commands.Ints is

   function Parse (Item : in String) return Parsed_Type
   is begin
      return (Value => Interfaces.Integer_16'Value (Item));
   end Parse;

   function Value (Item : in Parsed_Type) return Interfaces.Integer_16 is
   begin
      return Item.Value;
   end Value;

end Commands.Ints;

with Interfaces;
private package Commands.Ints is

   type Parsed_Type is new Commands.Parsed_Value_Type with private;

   function Value (Item : in Parsed_Type) return Interfaces.Integer_16;

   function Parse (Item : in String) return Parsed_Type;

   Grammar : constant Production_Type;
   --  This constant must be public to be used in Commands.Parser

private
   type Parsed_Type is new Commands.Parsed_Value_Type with record
      Value : Interfaces.Integer_16;
   end record;

   --  Stuff to actually parse a Real value.

   Grammar : constant Production_Type := (A => 1);

end Commands.Ints;

with Interfaces;
with Commands.Ints;
with Commands.Gen_Set_Parsed_Value;
procedure Commands.Ints_Set_Parsed_Value is new Commands.Gen_Set_Parsed_Value
  (Actual_Type      => Interfaces.Integer_16,
   Parsed_Type      => Commands.Ints.Parsed_Type,
   Value            => Commands.Ints.Value,
   Actual_Type_Name => "Int");

package body Commands.Reals is

   function Parse (Item : in String) return Parsed_Type
   is begin
      return (Value => Float'Value (Item));
   end Parse;

   function Value (Item : in Parsed_Type) return Float is
   begin
      return Item.Value;
   end Value;

end Commands.Reals;

private package Commands.Reals is

   type Parsed_Type is new Commands.Parsed_Value_Type with private;

   function Value (Item : in Parsed_Type) return Float;

   function Parse (Item : in String) return Parsed_Type;

   Grammar : constant Production_Type;
   --  This constant must be public to be used in Commands.Parser

private
   type Parsed_Type is new Commands.Parsed_Value_Type with record
      Value : Float;
   end record;
   --  Stuff to actually parse a Real value.

   Grammar : constant Production_Type := (A => 1);

end Commands.Reals;

with Commands.Reals;
procedure Commands.Reals_Set_Parsed_Value
  (Item         : in out Float;
   Parsed_Value : in     Commands.Parsed_Value_Type'Class)
is
begin
   if Parsed_Value in Commands.Reals.Parsed_Type then
      Item := Commands.Reals.Value (Commands.Reals.Parsed_Type (Parsed_Value));
   else
      raise Constraint_Error;
   end if;

end Commands.Reals_Set_Parsed_Value;

procedure Commands.Reals_Set_Parsed_Value
  (Item         : in out Float;
   Parsed_Value : in     Commands.Parsed_Value_Type'Class);
with Commands.Reals;
with Commands.Ints;
package body Commands is

   function "+" (Left, Right : in Production_Type) return Production_Type is
   begin
      return (A => Left.A + Right.A);
   end "+";

   --  Gather all grammar fragments together. Normally used to build
   --  a real parser.

   Grammar : constant Production_Type :=
     Commands.Reals.Grammar +
     Commands.Ints.Grammar;

   function Parse (Item : in String) return Parsed_Value_Type'Class
   is begin
      --  for this demo, we always return a real.
      return Parsed_Value_Type'Class (Commands.Reals.Parse (Item));
   end Parse;

end Commands;
package Commands is

   type Parsed_Value_Type is abstract tagged null record;
   --  Holds values from parsed commands; used by Symbols.Set.

   function Parse (Item : in String) return Parsed_Value_Type'Class;

private
   --  Stuff for actually parsing a command file or string; should
   --  _not_ be visible to clients of Command.

   type Production_Type is tagged record
      A : Integer;
   end record;

   function "+" (Left, Right : in Production_Type) return Production_Type;

end Commands;
with Commands.Ints_Set_Parsed_Value;
with Commands.Reals_Set_Parsed_Value;
with Interfaces;
procedure Demo
is
   Real : Float;
   Int  : Interfaces.Integer_16;
begin
   Commands.Reals_Set_Parsed_Value (Real, Commands.Parse ("1.0"));
   Commands.Ints_Set_Parsed_Value (Int, Commands.Parse ("1"));
end Demo;

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

From: Randy Brukardt
Sent: Friday, November 22, 2002 (in private mail)

There is something very suspicious about the generic in this example. In a
'proper' O-O design, you never explicitly test for a particular type in your
code. That should always be handled with overriding and dispatching.

While it's probably the case that you need to break the rules once in a while,
it's hard to justify adding a complex language feature just for that purpose.

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

Questions? Ask the ACAA Technical Agent