Generic association example (was Re: Mutual Recursion Challenge)

[eachus@spectre.mitre.org (Robert I. Eachus)]

In article <1994Oct24.203214.4967@swlvx2.msd.ray.com> jgv@swl.msd.ray.com (John Volan) writes:

 > Could you clarify this a bit, and elaborate on how using mixins would
 > work here?  I think I understand what you're driving at, but perhaps
 > other folks won't.  What, precisely, do you mean by the "baggage" that
 > would be there anyway?  Also, how well does the mixin technique really
 > scale up, when you imagine many classes, many associations, and each
 > class participating in many associations?

   >It may seem that creating a dozen abstract types which are only there
   >as placeholders is a problem, but in fact the only problem I have
   >found with it is coming up with names.  (The best strategy I have
   >found is to use the base class name joined with the generic package
   >name as the name of the package instance:

   >    package Persons_Office_Assignment is new Office_Assignment(Person);

   >    and elsewhere:

   >    package Office_Staff_Assignment is new Staff_Assignment(Office);
 > I take it that Persons_Office_Assignment would declare a derived type
 > inheriting from Person, with an extension supporting the association
 > with Office.  Likewise, Office_Staff_Assignment would declare a
 > derived type inheriting from Office, with an extension supporting the
 > association with Person.

Yes and yes.

 > One problem I see with this particular formulation is that a
 > Person-who-can-occupy-an-Office can point to any Office, not
 > necessarily only an Office-that-can-be-occupied; likewise, an
 > Office-that-can-be-occupied can point to any Person, not
 > necessarily only a Person-who-can-occupy-an-Office.

That is what abstract types are for.  In particular, the feature added
last August that abstract types need not have any abstract operations
makes it easy.  All the types that you can point to but shouldn't are
abstract, and since the type determination in a dispacthing operation
comes from the object, the issue doesn't arise.

 > Is there a way of putting this together that guarantees the
 > invariant that if a Person occupies an Office, then that Office is
 > occupied by that Person?

Yes.  It is best understood with the "double generic" version, but
doesn't depend on it.  However, make sure you reserve one-to-one
mappings for where they are appropriate.  Supporting many-to-many
mappings requires a lot more complexity in the Association
abstraction, so there should probably be several--one-to-one and onto,
one-to-many, and many-to-many.  They only need to be written once, so
let's try the simplest case:

(I spent a lot of time barking up the wrong tree on this.  Querying
the attributes is not a problem, but defining an operation to set them
resulted in all sorts of visible kludges or silly looking code.  There
are two facets to the solution.  The first is that in the one-to-one
case there are two necessary set operations: un-set and set, not set
for office and set for person.  The second is that, while the query
functions want to be class-wide in one parameter, these should be
symmetric, and thus class-wide in both.)

    generic
      type Father is abstract tagged private;
       -- probably all the abstract types should be limited too.
      type Target_Ancestor is abstract tagged private;
      -- ancester of the destination type, for example, Controlled.
    package Association is

      type Extended is abstract new Father with private;

      function Get(E: in Extended) return Target_Ancestor'CLASS;
      -- If you follow the above directions about abstraction, this
      -- must always return the "right" type.  But if you have several
      -- non-abstract types which are specializations of say Person,
      -- you want the attribute declared this way anyway.  Raises
      -- Constraint_Error if the attribute is not set. 

      function Is_Set(E: in Extended) return Boolean;
      -- Inquiry function to avoid Constraint_Error.

      generic
        type Mother is abstract tagged private;
      package Inner_Association is
         
        type Inner_Extended is new Mother with private;

        function Get(E: in Inner_Extended) return Extended'CLASS;
        -- Again we want the 'CLASS even in cases where it may not be
        -- necessary to complete the code...

        function Is_Set(E: in Extended) return Boolean;
        -- Inquiry function to avoid Constraint_Error as above.

        procedure Safe_Set (E:   in out Extended'CLASS;
                            IE:  in out Inner_Extended'CLASS);

        procedure Force_Set(E:   in out Extended'CLASS;
                            IE:  in out Inner_Extended'CLASS);

        -- There are two choices here, set in any case, but preserve
        -- the invariants, or raise an exception and change nothing if
        -- one or the other is already set.  Since it is simple to
        -- provide both, I do so.  (Safe_Set does the checks and may
        -- raise an exception, Force_Set unsets the partner of any
        -- object that is being reassigned.)

        procedure UnSet(E: in out Extended'CLASS);
        procedure UnSet(IE: in out Extended'CLASS);
        -- UnSet the attribute.  If already set, unset the partner as well.

      private

        type Outer_Ref is access all Extended;

        type Inner_Extended is new Mother with record
          Attribute: Outer_Ref;
        end record;

      end Inner_Association;

      pragma INLINE(Get, Is_Set, Safe_Set, Force_Set);

    private

      type Inner_Ref is access all Target_Ancestor;

      type Extended is new Father with record
        Attribute: Inner_Ref;
      end record;

      pragma INLINE(Get, Is_Set);

    end Association;

    -- generic
    -- type Father is abstract tagged private;
    -- type Target_Ancestor is abstract tagged private;
    package body Association is

    -- type Extended is new Father with record
    --       Attribute: Inner_Ref; end record;

      function Get(E: in Extended) return Target_Ancestor'CLASS is
      begin return E.Attribute.all; end Get;

      function Is_Set(E: in Extended) return Boolean is
      begin return E.Attribute = null; end Is_Set;

      -- generic
      -- type Mother is abstract tagged private;
      package Inner_Association is
         
        -- type Inner_Extended is new Mother with record
        -- Attribute: Outer_Ref; end record;

        function Get(E: in Inner_Extended) return Extended'CLASS is
        begin return E.Attribute.all; end Get;

        function Is_Set(E: in Extended) return Boolean is
        begin return E.Attribute = null; end Is_Set;

        procedure Safe_Set (E:   in out Extended'CLASS;
                            IE:  in out Inner_Extended'CLASS) is
        begin
          if Is_Set(E) or Is_Set(IE)
          then raise Constraint_Error;
          else
          end if;
        end Safe_Set;

        procedure Force_Set(E:   in out Extended'CLASS;
                            IE:  in out Inner_Extended'CLASS) is
        begin
          if Is_Set(E) then UnSet(E); end if;
          if Is_Set(IE) then UnSet(IE); end if;
          E.Attribute := IE'Access;
          IE.Attribute := E'Access;
        end Force_Set;

        procedure UnSet(E: in out Extended'CLASS) is
        begin
          if E.Attribute /= null
          then
             E.Attribute.Attribute := null;
             E.Attribute := null;
          end if;
        end UnSet;

        procedure UnSet(IE: in out Extended'CLASS) is
        begin
          if IE.Attribute /= null
          then
             IE.Attribute.Attribute := null;
             IE.Attribute := null;
          end if;
        end UnSet;

      end Inner_Association;

    end Association;

    (If anyone can compile this successfully, please let me know.
There is a bug in GNAT 1.83 that is supposed to be fixed in 1.84 that
the spec runs into.)

      Okay, now using this package goes like this...

      with Ada.Finalization; with Assignments;
      package People is

	type Base_Person is abstract 
             new Ada.Finalization.Controlled with private;

        package Office_Assignments is 
                   new Assignments(Base_Person,Ada.Finalization.Controlled);
      
        type Person is new Office_Assignments.Extended with null;

        function Office(P: in Person) return Controlled'CLASS renames Get;
        function Has_Office(P: in Person) return Boolean renames Is_Set;

      private
        ...
      end People;
                 
      with Ada.Finalization; with People;
      package Offices is
	type Office_Base is abstract new Ada.Finalization.Controlled
                 with private;
        package People_Assignments is new
          People.Office_Assignments.Inner_Association(Office_Base);
        
        type Office is new People_Assignments.Inner_Extended with null;
        function Occupant(O: in Office) return
              People.Office_Assignments.Extended'CLASS renames Get;
        function Is_Occupied(O: in Office) return Boolean renames Is_Set;
        procedure Reassign(P: in out People.Office_Assignments.Extended'CLASS;
                           O: in out People_Assignments.Inner_Extended'CLASS);
        ...

      private
        ...
      end Offices;

  > If I'm totally mixed-up about mixins :-), please help me out.  Thanks.

    I hope this helps.  The trick is to get as much of the "plumbing"
code into generics which are written once, and then use appropriate
renamings to make it understandable.  (In fact, in the code above I
probably would use subtype definitions to make those ugly 'CLASS
parameters go away.  The other possible approach is to replace the
renamings with operations on the parent types which do the ugly calls
in the body.  It's a matter of style and in this case, I'm trying to
show the workings...)
--

					Robert I. Eachus

with Standard_Disclaimer;
use  Standard_Disclaimer;
function Message (Text: in Clever_Ideas) return Better_Ideas is...