path: root/gcc/testsuite/ada/acats/tests/cc/cc51007.a

-- CC51007.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that a generic formal derived tagged type is a private extension.
--      Specifically, check that, for a generic formal derived type whose
--      ancestor type has abstract primitive subprograms, neither the formal
--      derived type nor its descendants need be abstract. Check that objects
--      and components of the formal derived type and its nonabstract
--      descendants may be declared and allocated, as may nonabstract
--      functions returning these types, and that aggregates of nonabstract
--      descendants of the formal derived type are legal. Check that calls to
--      the abstract primitive subprograms of the ancestor dispatch to the 
--      bodies corresponding to the tag of the actual parameters.
--
-- TEST DESCRIPTION:
--      Although the ancestor type is abstract and has abstract primitive
--      subprograms, these subprograms, when inherited by a formal nonabstract
--      derived type, are not abstract, since the formal derived type is a
--      nonabstract private extension.  
--
--      Thus, derivatives of the formal derived type need not be abstract,
--      and both the formal derived type and its derivatives are considered
--      nonabstract types.
--
--      This test verifies that the restrictions placed on abstract types do
--      not apply to the formal derived type or its derivatives. Specifically,
--      objects of, components of, allocators of, and nonabstract functions
--      returning the formal derived type or its derivatives are legal. In
--      addition, the test verifies that a call within the instance to a
--      primitive subprogram of the (abstract) ancestor type dispatches to
--      the body corresponding to the tag of the actual parameter.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      23 Dec 94   SAIC    Deleted illegal extension aggregate.  Corrected
--                          dispatching call. Editorial changes to commentary.
--      05 Nov 95   SAIC    ACVC 2.0.1 fixes: Moved instantiation of CC51007_3
--                          to library level.
--      11 Aug 96   SAIC    ACVC 2.1: Added pragma Elaborate to context
--                          clauses of CC51007_1 and CC51007_4.
--
--!

package CC51007_0 is

   Max_Length : constant := 10;
   type Text is new String(1 .. Max_Length);

   type Alert is abstract tagged record              -- Root type of class
      Message : Text := (others => '*');             -- (abstract).
   end record;

   procedure Handle (A: in out Alert) is abstract;   -- Abstract dispatching
                                                     -- operation.

end CC51007_0;

-- No body for CC51007_0;


     --===================================================================--


with CC51007_0;

with Ada.Calendar;
pragma Elaborate (Ada.Calendar);

package CC51007_1 is

   type Low_Alert is new CC51007_0.Alert with record
      Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1);
   end record;

   procedure Handle (A: in out Low_Alert);           -- Overrides parent's
                                                     -- implementation.
   Low : Low_Alert;

end CC51007_1;


     --===================================================================--


package body CC51007_1 is

   procedure Handle (A: in out Low_Alert) is         -- Artificial for
   begin                                             -- testing.
      A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1);
      A.Message := "Low Alert!";
   end Handle;

end CC51007_1;


     --===================================================================--


with CC51007_1;
package CC51007_2 is

   type Person is (OOD, CO, CinC);

   type Medium_Alert is new CC51007_1.Low_Alert with record
      Action_Officer : Person := OOD;
   end record;

   procedure Handle (A: in out Medium_Alert);        -- Overrides parent's
                                                     -- implementation.
   Med : Medium_Alert;

end CC51007_2;


     --===================================================================--


with Ada.Calendar;
package body CC51007_2 is

   procedure Handle (A: in out Medium_Alert) is      -- Artificial for
   begin                                             -- testing.
      A.Action_Officer := CO;
      A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1);
      A.Message := "Med Alert!";
   end Handle;

end CC51007_2;


     --===================================================================--


with CC51007_0;
generic
   type Alert_Type is new CC51007_0.Alert with private;
   Initial_State : in Alert_Type;
package CC51007_3 is

   function Clear_Message (A: Alert_Type)                -- Function returning
     return Alert_Type;                                  -- formal type.


   Max_Note : Natural := 10;
   type Note is new String (1 .. Max_Note);

   type Extended_Alert is new Alert_Type with record
      Addendum : Note := (others => '*');
   end record;

   -- In instance, inherits version of Handle from
   -- actual corresponding to formal type.

   function Annotate_Alert (A: in Alert_Type'Class)      -- Function returning
     return Extended_Alert;                              -- derived type.


   Init_Ext_Alert : constant Extended_Alert     :=       -- Object declaration.
     (Initial_State with Addendum => "----------");      -- Aggregate.


   type Alert_Type_Ptr is access constant Alert_Type;
   type Ext_Alert_Ptr  is access          Extended_Alert;

   Init_Alert_Ptr     : Alert_Type_Ptr := 
     new Alert_Type'(Initial_State);                        -- Allocator.

   Init_Ext_Alert_Ptr : Ext_Alert_Ptr  :=
     new Extended_Alert'(Init_Ext_Alert);                -- Allocator.


   type Alert_Pair is record
      A  : Alert_Type;                                   -- Component.
      EA : Extended_Alert;                               -- Component.
   end record;

end CC51007_3;


     --===================================================================--


package body CC51007_3 is

   function Clear_Message (A: Alert_Type) return Alert_Type is
      Temp : Alert_Type := A;                       -- Object declaration.
   begin
      Temp.Message := (others => '-');
      return Temp;
   end Clear_Message;

   function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is
      Temp : Alert_Type'Class := A;
   begin
      Handle (Temp);                                -- Dispatching call to
                                                    -- operation of ancestor.
      return (Alert_Type(Temp) with Addendum => "No comment");
   end Annotate_Alert;

end CC51007_3;


     --===================================================================--


with CC51007_1;

with CC51007_3;
pragma Elaborate (CC51007_3);

package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low);


     --===================================================================--


with CC51007_1;
with CC51007_2;
with CC51007_3;
with CC51007_4;

with Ada.Calendar;
with Report;
procedure CC51007 is

   package Alert_Support renames CC51007_4;

   Ext : Alert_Support.Extended_Alert;

   TC_Result       : Alert_Support.Extended_Alert;

   TC_Low_Expected : constant Alert_Support.Extended_Alert :=
                       (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1),
                        Message         => "Low Alert!",
                        Addendum        => "No comment");

   TC_Med_Expected : constant Alert_Support.Extended_Alert :=
                       (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1),
                        Message         => "Med Alert!",
                        Addendum        => "No comment");

   TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected;


   use type Alert_Support.Extended_Alert;

begin
   Report.Test ("CC51007", "Check that, for a generic formal derived type "  &
                "whose ancestor type has abstract primitive subprograms, "   &
                "neither the formal derived type nor its descendants need "  &
                "be abstract, and that objects of, components of, "          &
                "allocators of, aggregates of, and nonabstract functions "   &
                "returning these types are legal. Check that calls to the "  &
                "abstract primitive subprograms of the ancestor dispatch "   &
                "to the bodies corresponding to the tag of the actual "      &
                "parameters");


   TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low);  -- Dispatching
                                                               -- call.
   if TC_Result /= TC_Low_Expected then
      Report.Failed ("Wrong results from dispatching call (Low_Alert)");
   end if;


   TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med);  -- Dispatching
                                                               -- call.
   if TC_Result /= TC_Med_Expected then
      Report.Failed ("Wrong results from dispatching call (Medium_Alert)");
   end if;


   TC_Result := Alert_Support.Annotate_Alert (Ext);   -- Results in dispatching
                                                      -- call.
   if TC_Result /= TC_Ext_Expected then
      Report.Failed ("Wrong results from dispatching call (Extended_Alert)");
   end if;


   Report.Result;
end CC51007;