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; 158