gcc/testsuite/ada/acats/tests/c3/c393009.a

   1 -- C393009.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 from an abstract type.
  28 --
  29 -- TEST DESCRIPTION:
  30 --      Declare an abstract type in the specification of a generic package.
  31 --      Instantiate the package and derive an extended type from the abstract
  32 --      (instantiated) type; override all abstract operations; use all
  33 --      inherited operations;
  34 --
  35 --
  36 -- CHANGE HISTORY:
  37 --      06 Dec 94   SAIC    ACVC 2.0
  38 --      14 Oct 95   SAIC    Fixed for ACVC 2.0.1
  39 --
  40 --!
  41
  42 with Report;
  43 procedure C393009 is
  44
  45   package Display_Devices is
  46
  47     type Display_Device_Enum is (None, TTY, Console, Big_Screen);
  48     Display : Display_Device_Enum := None;
  49
  50   end Display_Devices;
  51
  52 --=======================================================================--
  53
  54   generic
  55
  56     type Generic_Status is (<>);
  57
  58     type Serial_Type is (<>);
  59
  60   package Alert_System is
  61
  62     type Alert_Type (Serial : Serial_Type) is abstract tagged record
  63       Status : Generic_Status;
  64     end record;
  65
  66     Next_Serial_Number : Serial_Type := Serial_Type'First;
  67
  68     procedure Handle (A : in out Alert_Type) is abstract;
  69       -- abstract operation - must be overridden after instantiation
  70
  71     procedure Display ( A : Alert_Type;
  72                        On : Display_Devices.Display_Device_Enum);
  73               -- primitive operation of Alert_Type
  74               -- not required to be overridden
  75
  76     function Get_Serial_Number (A : Alert_Type) return Serial_Type;
  77               -- primitive operation of Alert_Type
  78               -- not required to be overridden
  79
  80   end Alert_System;
  81
  82 --=======================================================================--
  83
  84   package body Alert_System is
  85
  86     procedure Display ( A : in Alert_Type;
  87                        On : Display_Devices.Display_Device_Enum) is
  88       begin
  89         Display_Devices.Display := On;
  90       end Display;
  91
  92     function Get_Serial_Number (A : Alert_Type)
  93       return Serial_Type is
  94       begin
  95         return A.Serial;
  96       end Get_Serial_Number;
  97
  98   end Alert_System;
  99
 100 --=======================================================================--
 101
 102   package NCC_1701 is
 103
 104     type Status_Kind is (Green, Yellow, Red);
 105     type Serial_Number_Type is new Integer range 1..Integer'Last;
 106
 107     subtype Msg_Str is String (1..16);
 108     Alert_Msg : Msg_Str := "C393009  passed.";
 109                         --  123456789A123456
 110
 111     package Alert_Pkg is new Alert_System (Status_Kind, Serial_Number_Type);
 112
 113     type New_Alert_Type(Serial : Serial_Number_Type) is
 114       new Alert_Pkg.Alert_Type(Serial) with record
 115       Message : Msg_Str;
 116       end record;
 117
 118     -- procedure Display is inherited by New_Alert_Type
 119
 120     -- function Get_Serial_Number is inherited by New_Alert_Type
 121     procedure Handle (NA : in out New_Alert_Type);  -- must be overridden
 122     procedure Init   (NA : in out New_Alert_Type);  -- new primitive
 123
 124     NA : New_Alert_Type(Alert_Pkg.Next_Serial_Number);
 125          -- New_Alert_Type is not abstract, so an object of that
 126          -- type may be declared
 127
 128   end NCC_1701;
 129
 130   package body NCC_1701 is
 131
 132     procedure Handle (NA : in out New_Alert_Type) is
 133     begin
 134       NA.Message := Alert_Msg;
 135       Display (NA, On => Display_Devices.TTY);
 136       end Handle;
 137
 138     procedure Init (NA : in out New_Alert_Type) is  -- new primitive operation
 139     begin                                           -- for New_Alert_Type
 140       NA := (Serial=> NA.Serial, Status => Green, Message => (others => ' '));
 141     end Init;
 142
 143    end NCC_1701;
 144
 145    use NCC_1701;
 146    use type Display_Devices.Display_Device_Enum;
 147
 148 begin
 149
 150   Report.Test ("C393009", "Check that an extended type can be derived " &
 151                           "from an abstract type");
 152
 153   Init (NA);
 154   if (Get_Serial_Number (NA) /= 1)
 155     or (NA.Status /= Green)
 156     or (Display_Devices.Display /= Display_Devices.None) then
 157       Report.Failed ("Wrong Initialization");
 158   end if;
 159
 160   Handle (NA);
 161   if (Get_Serial_Number (NA) /= 1)
 162     or (NA.Status /= Green)
 163     or (NA.Message /= Alert_Msg)
 164     or (Display_Devices.Display /= Display_Devices.TTY) then
 165       Report.Failed ("Wrong results from Handle");
 166   end if;
 167
 168   Report.Result;
 169
 170 end C393009;