llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/c3/c393011.a

-- C393011.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.
--*
--
-- TEST OBJECTIVE:
--      Check that an abstract extended type can be derived from an abstract
--      type, and that a a non-abstract type may then be derived from the
--      second abstract type.
--
-- TEST DESCRIPTION:
--      Define an abstract type with three primitive operations, two of them
--      abstract.  Derive an extended type from it, inheriting the non-
--      abstract operation, overriding one of the abstract operations with
--      a non-abstract operation, and overriding the other abstract operation
--      with an abstract operation.  The extended type is therefore abstract;
--      derive an extended type from it.  Override the abstract operation with
--      a non-abstract operation; inherit one operation from the original
--      abstract type, and inherit one operation from the intermediate 
--      abstract type.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!
 
 Package C393011_0 is
     -- Definitions
 
   type Status_Enum is (None, Unhandled, Pending, Handled);
   type Serial_Type is new Integer range 0 .. Integer'Last;
   subtype Priority_Type is Integer range 0..10;
 
   type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen);
 
   Next : Serial_Type := 1;
   Display_Device : Display_Enum := Bit_Bucket;
 
 end C393011_0;
 -- Definitions;
 
 --=======================================================================--
 
 with C393011_0;
   -- Definitions
 
 Package C393011_1 is
      -- Alert
 
   package Definitions renames C393011_0;
 
   type Alert_Type is abstract tagged record         
     Status     : Definitions.Status_Enum := Definitions.None;  
     Serial_Num : Definitions.Serial_Type := 0;
     Priority   : Definitions.Priority_Type;
   end record;
                             -- Alert_Type is an abstract type with
                             -- two operations to be overridden
 
   procedure Set_Status ( A : in out Alert_Type;          -- not abstract
                         To : Definitions.Status_Enum);
 
   procedure Set_Serial ( A : in out Alert_Type) is abstract;
   procedure Display    ( A : Alert_Type)        is abstract;
  
 end C393011_1;
  -- Alert
 
 --=======================================================================--
 
 with C393011_0;
 package body C393011_1 is
           -- Alert
   procedure Set_Status ( A : in out Alert_Type;
                         To : Definitions.Status_Enum) is
     begin
       A.Status := To;
     end Set_Status;
 
 end C393011_1;
  -- Alert;
 
 --=======================================================================--
 
 with C393011_0,
   -- Definitions, 
      C393011_1,
   -- Alert, 
      Calendar;
 
 Package C393011_3 is
      -- New_Alert
 
   type New_Alert_Type is abstract new C393011_1.Alert_Type with record
     Display_Dev : C393011_0.Display_Enum := C393011_0.TTY;
   end record;
 
   -- procedure Set_Status is inherited
 
   procedure Set_Serial ( A : in out New_Alert_Type);   -- override/see body
 
   procedure Display    ( A : New_Alert_Type) is abstract;
                          -- override is abstract 
                          -- still can't declare objects of New_Alert_Type
 
 end C393011_3;
  -- New_Alert
 
 --=======================================================================--
 
 with C393011_0;
 Package Body C393011_3 is 
           -- New_Alert
 
   package Definitions renames C393011_0;
 
   procedure Set_Serial (A : in out New_Alert_Type) is
     use type Definitions.Serial_Type;
     begin
       A.Serial_Num := Definitions.Next;
       Definitions.Next := Definitions."+"( Definitions.Next, 1);
     end Set_Serial;
 
 End C393011_3;
  -- New_Alert;
 
 --=======================================================================--
 
 with C393011_0,
   -- Definitions 
      C393011_3;
   -- New_Alert  -- package Alert is not visible
 package C393011_4 is
 
   package New_Alert renames C393011_3;
   package Definitions renames C393011_0;
 
   type Final_Alert_Type is new New_Alert.New_Alert_Type with null record;
   -- inherits Set_Status including body
   -- inherits Set_Serial including body
   -- must override Display since inherited Display is abstract
   procedure Display(FA : in     Final_Alert_Type);
   procedure Handle (FA : in out Final_Alert_Type);
 
 end C393011_4;
 
 package body C393011_4 is
 
   procedure Display    (FA : in Final_Alert_Type) is 
     begin
       Definitions.Display_Device := FA.Display_Dev;
     end Display;
 
   procedure Handle (FA : in out Final_Alert_Type) is
     begin
       Set_Status (FA, Definitions.Handled);
       Set_Serial (FA);
       Display (FA);
     end Handle;
 end C393011_4;
 
 with C393011_0,
   -- Definitions 
      C393011_3;
   -- New_Alert  -- package Alert is not visible
 with C393011_4;
 with Report;
 procedure C393011 is
   use C393011_4;
   use Definitions;
 
   FA : Final_Alert_Type;
 
 begin
 
   Report.Test ("C393011", "Check that an extended type can be derived " &
                           "from an abstract type");
 
   if (Definitions.Display_Device /= Definitions.Bit_Bucket)
       or (Definitions.Next /= 1)
       or (FA.Status /= Definitions.None)
       or (FA.Serial_Num /= 0)
       or (FA.Display_Dev /= TTY) then
     Report.Failed ("Incorrect initial conditions");
   end if;
 
   Handle (FA);
   if (Definitions.Display_Device /= Definitions.TTY)
       or (Definitions.Next /= 2)
       or (FA.Status /= Definitions.Handled)
       or (FA.Serial_Num /= 1)
       or (FA.Display_Dev /= TTY) then
     Report.Failed ("Incorrect results from Handle");
   end if;
 
   Report.Result;
 
 end C393011;