c393007.a

来自「用于进行gcc测试」· A 代码 · 共 158 行

-- C393007.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 extended type can be derived from an abstract type,
--      where the abstract type is defined in a package, and the type derived
--      from it is defined in a distinct library package.
--
-- TEST DESCRIPTION:
--      Declare an private (abstract) type; declare two primitive operations 
--      of the type that are explicitly abstract.
--      Derive an extended type from the (private) abstract type, overriding 
--      both of the primitive operations.
--      This test also checks to see that name overloading between abstract
--      and non-abstract functions is resolved correctly.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
--!

   package C393007_0 is
        -- Alert_System
 
     type DT_Type is new Integer;
 
     type Alert_Type is abstract tagged record
        Time_Of_Arrival : DT_Type;
     end record;
 
     type Log_File_Type is range 0 .. 100;
 
     Procedure Handle (A : in out Alert_type) is abstract;
       
     procedure Log    (A : Alert_Type;                   
                       L : in out Log_File_Type) is abstract;  
   
     procedure Set_Time (A : in out Alert_Type);
 
     function Correct_Time_Stamp (A : Alert_Type) return Boolean;
       
     Day_Time : DT_Type := 100;
 
   end C393007_0;
    -- Alert_System;
 
 --=======================================================================--
 
   package body C393007_0 is
             -- Alert_System
 
     function Time_Stamp return DT_Type is
       begin
         Day_Time := Day_Time + 1;
         return Day_Time;
       end Time_Stamp;
 
     procedure Set_Time (A : in out Alert_Type) is
       begin
         A.Time_Of_Arrival := Time_Stamp;
       end Set_time;
       
     function Correct_Time_Stamp ( A : Alert_Type) return Boolean is
       begin
         return (A.Time_Of_Arrival = Day_Time);
       end Correct_Time_Stamp;
 
   end C393007_0;
    -- Alert_System;
 
 --=======================================================================--
 
 with Report;
 with C393007_0;
   -- Alert_system;
 
 package C393007_1 is
 
   type Normal_Alert_Type is   
     new C393007_0.Alert_Type
     with null record;
 
   Log_File: C393007_0.Log_File_Type := C393007_0.Log_File_Type'First;
 
   procedure Handle (A : in out Normal_Alert_Type);  -- Override is required
 
   procedure Log    (A : Normal_Alert_Type;          -- Override is required
                     L : in out C393007_0.Log_File_Type);
 end C393007_1;
 
 package body C393007_1 is
   use type C393007_0.Log_File_Type;
 
   procedure Handle (A : in out Normal_Alert_Type) is   
     begin
       Set_Time (A);
       Log (A, Log_File);
     end Handle;
 
   procedure Log    (A : Normal_Alert_Type;      
                     L : in out C393007_0.Log_File_Type) is
      begin
        L := C393007_0."+"(L, 1);
      end Log;
   
 end C393007_1;
 
 with Report;
 with C393007_0;
 with C393007_1;
   -- Alert_system;
 
 procedure C393007 is
   use C393007_0;
   use C393007_1;
 
   Alert_One : C393007_1.Normal_Alert_Type;
 
 begin
   Report.Test ("C393007", "Check that an extended type can be derived " &
                           "from an abstract type");
 
   Handle (Alert_One);
   if not Correct_Time_Stamp (Alert_One) then
     Report.Failed ("Wrong results from procedure Handle");
   end if;
 
   if Log_File /=1 then 
     Report.Failed ("Wrong results");
   end if;
 
   Report.Result;
 
 end C393007;