"with private" and generics

"with private" and generics

[Stephen Leake]

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 (while using
OpenToken; cool stuff :); I need to mention a private child package in
a generic formal association. You can gnatchop and compile it; 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 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.

Any comments? I'll send this in to the ARG soon. Also to ACT, to ask
that they implement "with private" soon :).

I have two work-arounds at the moment; I can make all the private
stuff public, and keep the generic, or I can use gnatprep instead of a
generic. I think I prefer the gnatprep approach.


--------- code follows --------------

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;


-- 
-- Stephe