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

   1 -- C393007.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 --      where the abstract type is defined in a package, and the type derived
  29 --      from it is defined in a distinct library package.
  30 --
  31 -- TEST DESCRIPTION:
  32 --      Declare an private (abstract) type; declare two primitive operations
  33 --      of the type that are explicitly abstract.
  34 --      Derive an extended type from the (private) abstract type, overriding
  35 --      both of the primitive operations.
  36 --      This test also checks to see that name overloading between abstract
  37 --      and non-abstract functions is resolved correctly.
  38 --
  39 --
  40 -- CHANGE HISTORY:
  41 --      06 Dec 94   SAIC    ACVC 2.0
  42 --
  43 --!
  44
  45    package C393007_0 is
  46         -- Alert_System
  47
  48      type DT_Type is new Integer;
  49
  50      type Alert_Type is abstract tagged record
  51         Time_Of_Arrival : DT_Type;
  52      end record;
  53
  54      type Log_File_Type is range 0 .. 100;
  55
  56      Procedure Handle (A : in out Alert_type) is abstract;
  57
  58      procedure Log    (A : Alert_Type;
  59                        L : in out Log_File_Type) is abstract;
  60
  61      procedure Set_Time (A : in out Alert_Type);
  62
  63      function Correct_Time_Stamp (A : Alert_Type) return Boolean;
  64
  65      Day_Time : DT_Type := 100;
  66
  67    end C393007_0;
  68     -- Alert_System;
  69
  70  --=======================================================================--
  71
  72    package body C393007_0 is
  73              -- Alert_System
  74
  75      function Time_Stamp return DT_Type is
  76        begin
  77          Day_Time := Day_Time + 1;
  78          return Day_Time;
  79        end Time_Stamp;
  80
  81      procedure Set_Time (A : in out Alert_Type) is
  82        begin
  83          A.Time_Of_Arrival := Time_Stamp;
  84        end Set_time;
  85
  86      function Correct_Time_Stamp ( A : Alert_Type) return Boolean is
  87        begin
  88          return (A.Time_Of_Arrival = Day_Time);
  89        end Correct_Time_Stamp;
  90
  91    end C393007_0;
  92     -- Alert_System;
  93
  94  --=======================================================================--
  95
  96  with Report;
  97  with C393007_0;
  98    -- Alert_system;
  99
 100  package C393007_1 is
 101
 102    type Normal_Alert_Type is
 103      new C393007_0.Alert_Type
 104      with null record;
 105
 106    Log_File: C393007_0.Log_File_Type := C393007_0.Log_File_Type'First;
 107
 108    procedure Handle (A : in out Normal_Alert_Type);  -- Override is required
 109
 110    procedure Log    (A : Normal_Alert_Type;          -- Override is required
 111                      L : in out C393007_0.Log_File_Type);
 112  end C393007_1;
 113
 114  package body C393007_1 is
 115    use type C393007_0.Log_File_Type;
 116
 117    procedure Handle (A : in out Normal_Alert_Type) is
 118      begin
 119        Set_Time (A);
 120        Log (A, Log_File);
 121      end Handle;
 122
 123    procedure Log    (A : Normal_Alert_Type;
 124                      L : in out C393007_0.Log_File_Type) is
 125       begin
 126         L := C393007_0."+"(L, 1);
 127       end Log;
 128
 129  end C393007_1;
 130
 131  with Report;
 132  with C393007_0;
 133  with C393007_1;
 134    -- Alert_system;
 135
 136  procedure C393007 is
 137    use C393007_0;
 138    use C393007_1;
 139
 140    Alert_One : C393007_1.Normal_Alert_Type;
 141
 142  begin
 143    Report.Test ("C393007", "Check that an extended type can be derived " &
 144                            "from an abstract type");
 145
 146    Handle (Alert_One);
 147    if not Correct_Time_Stamp (Alert_One) then
 148      Report.Failed ("Wrong results from procedure Handle");
 149    end if;
 150
 151    if Log_File /=1 then
 152      Report.Failed ("Wrong results");
 153    end if;
 154
 155    Report.Result;
 156
 157  end C393007;