[Ada] Tagged record type and Class-wide operation dispatching

This example shows how to use tagged record type and class-wide operation dispatching to achieve run-time polymorphism.

Class Hierarchy

One root class Shape, and three subclasses Point, Circle and Rectangle. Each class has coordinator (x and y) and area function. Besides, Circle has additional radius and Rectangle has extended width and length.

Source Code

Shape

• shapes.ads

package shapes is
    type Shape is tagged private;

    function Area (S : in Shape) return Float;

private
    type Shape is tagged record
            X : Float ;
            Y : Float ;
    end record;
end shapes;

• shapes.adb

package body shapes is

    function Area (S : in Shape) return Float is
    begin
        return 0.0;
    end Area;
end shapes;

Point

• points.ads

with shapes; use shapes;

package points is
    type Point is new Shape with private;

    function Area (P : in Point) return Float;
end points;

• points.adb

package body points is

    function Area (P : in Point) return Float is
    begin
        return 0.0;
    end Area;
end points;

Circle

• circles.ads

with shapes; use shapes;

package circles is
    type Circle is new Shape with private;

    function Area (C : in Circle) return Float;
private
    type Circle is new Shape with record 
            Radius : Float ;
    end record;
end circles;

• circles.adb

package body circles is

    function Area (C : in Circle) return Float is
        pi : CONSTANT Float := 3.1415926;
    begin
        return 2.0 * pi * (C.Radius * C.Radius);
    end Area;

end circles;

Rectangle

• rectangles.ads

with shapes; use shapes;

package rectangles is
    type Rectangle is new Shape with private;

    function Area (R : in Rectangle) return Float;
private
    type Rectangle is new Shape with record 
            Length : Float ;
            Width : Float ;
    end record;
end rectangles;

• rectangles.adb

package body rectangles is

    function Area (R : in Rectangle) return Float is
    begin
        return R.Length * R.Width;
    end Area;

end rectangles;

Test

• test.adb

With shapes; use shapes;
With points; use points;
With circles; use circles;
With rectangles; use rectangles;

procedure test is
    p : Point;
    c : Circle;
    r : Rectangle;

    area_of_shape : Float := 0.0;

    function getArea (S: Shape'Class) return Float is
        temp : Float;
    begin
        temp := Area(S);
        return temp;
    end problem;

begin
    area_of_shape := getArea(p);
    area_of_shape := getArea(c);
    area_of_shape := getArea(r);
end test;

​