old-autovect-branch/gcc/testsuite/ada/acats/tests/c3/c393b12.a

   1 -- C393B12.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- TEST OBJECTIVE:
  27 --      Check that an extended type can be derived in the specification of a
  28 --      generic package when the parent is an abstract type in a library
  29 --      package.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      Extend an abstract type in the visible part of a generic package.
  33 --      Make all of the procedures which override abstract procedures
  34 --      available as part of the generic interface.  Instantiate the generic.
  35 --
  36 -- TEST FILES:
  37 --      This test depends on the following foundation code:
  38 --
  39 --         F393B00.A  Package Alert_Foundation
  40 --
  41 --
  42 -- CHANGE HISTORY:
  43 --      06 Dec 94   SAIC    ACVC 2.0
  44 --      14 Oct 95   SAIC    Update and repair for ACVC 2.0.1
  45 --      27 Feb 97   PWB.CTA Add pragma Elaborate for C393B12_0.
  46 --!
  47
  48 ----------------------------------------------------------------- C393B12_0
  49
  50 with F393B00;
  51   -- Alert_Foundation
  52 generic
  53   type Generic_Status_Enum is (<>);
  54
  55 package C393B12_0 is
  56      -- Alert_Functions
  57
  58   type Generic_Alert_Type is new F393B00.Alert with record
  59     Status : Generic_Status_Enum := Generic_Status_Enum'First;
  60   end record;
  61                                      -- extension of an abstract type
  62
  63   procedure Handle (GA : in out Generic_Alert_Type);
  64                                      -- override of abstract procedure
  65
  66   function Query_Status (GA : Generic_Alert_Type)
  67     return Generic_Status_Enum;      -- new primitive operation for
  68                                      -- Generic_Alert_Type
  69 end C393B12_0;
  70  -- Alert_Functions
  71
  72 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
  73
  74 package body C393B12_0 is
  75           -- Alert_Functions
  76
  77   procedure Handle (GA : in out Generic_Alert_Type) is
  78     begin
  79       GA.Status := Generic_Status_Enum'Last;
  80     end Handle;
  81
  82   function Query_Status (GA : Generic_Alert_Type)
  83     return Generic_Status_Enum is
  84     begin
  85       return GA.Status;
  86     end Query_Status;
  87
  88 end C393B12_0;
  89
  90 ----------------------------------------------------------------- C393B12_1
  91
  92 package C393B12_1 is
  93   type Status is (Low, Medium, High);
  94 end C393B12_1;
  95
  96 ------------------------------------------------------- C393B12_1.C393B12_2
  97
  98 with C393B12_0;
  99 pragma Elaborate (C393B12_0);
 100 package C393B12_1.C393B12_2 is new C393B12_0
 101                         -- Alert_Functions
 102                  (Generic_Status_Enum => Status);
 103
 104 ------------------------------------------------------------------- C393B12
 105
 106 with C393B12_1.C393B12_2;
 107 with Report;
 108 procedure C393B12 is
 109
 110   use type C393B12_1.Status;
 111
 112   package Alt_Alert renames C393B12_1.C393B12_2;
 113
 114   GA : Alt_Alert.Generic_Alert_Type;
 115
 116 begin
 117   Report.Test ("C393B12",  "Check that an extended type can be derived " &
 118                            "from an abstract type");
 119
 120   if Alt_Alert.Query_Status (GA) /= C393B12_1.Low then
 121     Report.Failed ("Wrong initialization");
 122   end if;
 123
 124   Alt_Alert.Handle (GA);
 125   if Alt_Alert.Query_Status (GA) /= C393B12_1.High then
 126     Report.Failed ("Wrong results from Handle");
 127   end if;
 128
 129   Report.Result;
 130
 131 end C393B12;