Re: How to write TYPECASE in Ada 95?

["David C. Hoos, Sr." <david.c.hoos.sr@ada95.com>]

Norman Ramsey wrote in message <79fct8$9k3$1@murdoch.acc.Virginia.EDU>...
>
>I'm trying to figure out from the reference manual how to identify
>which type extension of a type I have.  For example, if I have
>
>   type Point is tagged
>         record
>           X, Y : Real := 0.0;
>         end record;
>
>   type Painted_Point is new Point with
>         record
>           Paint : Color := White;
>         end record;
>
>
>   type Tall_Point is new Point with
>         record
>           Height : Real := 0.0;
>         end record;
>
>I'd like to be able to discriminate at run time:
>
>   p : Point;
>
>     ...
>
>   if p in Painted_Point then
>      ... do something with Painted_Point'(p)
>   else if p in Tall_Point then
>      ... do something with Tall_Point'(p)
>
>Even better would be something like Modula-3 TYPECASE:
>
>  (* modula-3 *)
>  TYPECASE p OF
>  Painted_Point (painted) => ... do something with painted
>  Tall_Point    (tail)    => ... do something with tall
>    ...
>  END
>
>What's the idiomatic way to express this in Ada?
>
None of the responses to this posting (including mine) addressed the larger
question -- i.e., "What's the idiomatic way to express this in Ada?"  Ed
Falis' comment made me realize that, so here's an attempt  to answer it.

First, I would say that it would be presumptuous of me to say something was
_the_ idiomatic way to express something in Ada, because with so many of
Ada's capabilities there are multiple idioms possible, but not always any
one best way to do it.

So here is _an_idiomatic way to express this in Ada:
This is a complete working program, that I hope is helpful.

David C. Hoos, Sr.

--------- begin source code ------
package Points is

   subtype Real is Float;

   type Color is (Black, Red, Brown, Green, Yellow, Blue, Purple, White);

   type Point is tagged
      record
         X, Y : Real := 0.0;
      end record;

   -------------------------------------------------------------------------
----
   -- Show_Type (P: Point'Class);
   -- Purpose:
   --   This class-wide procedure illustrates a procedure which serves for
all
   --   types derived from its base type, regardless of future extensions
   --   unknown or even unanticipated at the time this procedure was
written.
   -------------------------------------------------------------------------
----
   procedure Show_Type (P : Point'Class);

   -------------------------------------------------------------------------
----
   -- Show_Properties (P: Point);
   -- Purpose:
   --   This procedure illustrates a procedure which serves for only the
   --   type of its parameter.  It may be called explicitly with an object
   --   of its type, or implicitly by means of a dispatching call with a
   --   class-wide object, in which case the procedure to be called is
   --   determined at run-time by the actual type of the parameter object.
   --   NOTE:  If other types are derived from Point, a Show_Properties
   --   procedure MUST be provided for that type.  This restriction is
   --   enforced at compile time.
   -------------------------------------------------------------------------
----
   procedure Show_Properties (P : Point);

   type Painted_Point is new Point with
      record
         Paint : Color := White;
      end record;

   -------------------------------------------------------------------------
----
   -- Show_Properties (P: Painted_Point);
   -- Purpose:
   --   See discussion for Show_Properties (P: Point);
   -------------------------------------------------------------------------
----
   procedure Show_Properties (P: Painted_Point);

   type Tall_Point is new Point with
      record
         Height : Real := 0.0;
      end record;

   -------------------------------------------------------------------------
----
   -- Show_Properties (P: Tall_Point);
   -- Purpose:
   --   See discussion for Show_Properties (P: Point);
   -------------------------------------------------------------------------
----
   procedure Show_Properties (P: Tall_Point);

end Points;

with Ada.Tags;
with Ada.Text_Io;
package body Points is

   procedure Show_Properties (P : Point) is
   begin
      Ada.Text_Io.Put_Line
        ("X =>" & Real'Image (P.X) &
         "Y =>" & Real'Image (P.Y));
   end Show_Properties;

   procedure Show_Properties (P: Painted_Point) is
   begin
      Show_Properties (Point (P));
      Ada.Text_Io.Put_Line
        ("Paint =>" & Color'Image (P.paint));
   end Show_Properties;

   procedure Show_Properties (P: Tall_Point) is
   begin
      Show_Properties (Point (P));
      Ada.Text_Io.Put_Line
        ("Height =>" & Real'Image (P.Height));
   end Show_Properties;

   procedure Show_Type (P : Point'Class) is
   begin
      Ada.Text_Io.Put_Line
        ("Type => " & Ada.Tags.External_Tag (P'Tag));
   end Show_Type;

end Points;

with Ada.Text_Io;
with Ada.Unchecked_Deallocation;
with Points;
procedure Test_Points is

   -- Since an object of Points.Point'Class must be constrained at the time
of
   -- declaration to some one of the types derived from Points.Point, and
   -- therefore cannot be re-used for other types derived from Points.Point,
   -- we use an access object, instead.  But first, we declare the type of
   -- that access object, as well as a deallocation procedure for it.
   type Point_Class_Access is access all Points.Point'Class;

   procedure Free is new Ada.Unchecked_Deallocation
     (Object => Points.Point'Class,
      Name   => Point_Class_Access);

   -- We do not need to initialize this access object here, but we do so
   -- just to illustrate that it can be done.
   P_Access : Point_Class_Access := new Points.Tall_Point'(3.0, 4.0, 5.0);

begin

   -- Note that this is _not_ a dispatching call, because the procedure's
   -- formal parameter is of a class-wide type.
   Points.Show_Type (P_Access.all);

   -- Note that this _is_ a dispatching call, because the object is of a
   -- class-wide type.
   Points.Show_Properties (P_Access.all);

   -- P_Access.Paint := Blue; Illegal P_Access accesses a Tall_Point object,
   -- so we must first deallocate the memory for the object, leaving it free
   -- to access another object of a type derived from Points.Point.
   Free (P_Access);

   P_Access := new Points.Painted_Point'(3.0, 4.0, Points.Blue);

   Points.Show_Type (P_Access.all);
   Points.Show_Properties (P_Access.all);

end Test_Points;

--------- end source code ------