1-- CA11B02.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-- OBJECTIVE: 27-- Check that a type derived in a client of a public child inherits 28-- primitive operations from parent. 29-- 30-- TEST DESCRIPTION: 31-- Declare a root record type with discriminant in a package 32-- specification. Declare a primitive subprogram for the type 33-- (foundation code). 34-- 35-- Add a public child to the above package. Derive a new type 36-- with constraint to the discriminant record type from the parent 37-- package. Declare a new primitive subprogram to write to the child 38-- derived type. 39-- 40-- In the main program, "with" the child. Derive a new type using the 41-- record type from the child package. Access the inherited operations 42-- from both parent and child packages. 43-- 44-- TEST FILES: 45-- This test depends on the following foundation code: 46-- 47-- FA11B00.A 48-- 49-- 50-- CHANGE HISTORY: 51-- 06 Dec 94 SAIC ACVC 2.0 52-- 53--! 54 55-- Child package of FA11B00. 56package FA11B00.CA11B02_0 is -- Application_Two_Widget 57-- This public child declares a derived type from its parent. It 58-- represents processing of widgets in a window system. 59 60 -- Dimension of app2_widget is limited to 5000 pixels. 61 62 type App2_Widget is new App1_Widget (Maximum_Size => 5000); 63 -- Derived record of parent type. 64 65 -- Inherits procedure App1_Widget_Specific_Oper from parent. 66 67 68 -- Primitive operation of type App2_Widget. 69 70 procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; 71 S : in Widget_Size); 72 73 -- Primitive operation of type App2_Widget. 74 75 procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; 76 Loc : in Widget_Location); 77 78end FA11B00.CA11B02_0; -- Application_Two_Widget 79 80 81--=======================================================================-- 82 83 84package body FA11B00.CA11B02_0 is -- Application_Two_Widget 85 86 procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; 87 S : in Widget_Size) is 88 begin 89 The_Widget.Size := S; 90 end App2_Widget_Specific_Op1; 91 92 --==============================================-- 93 94 procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; 95 Loc : in Widget_Location) is 96 begin 97 The_Widget.Location := Loc; 98 end App2_Widget_Specific_Op2; 99 100end FA11B00.CA11B02_0; -- Application_Two_Widget 101 102 103--=======================================================================-- 104 105with FA11B00.CA11B02_0; -- Application_Two_Widget 106 -- implicitly with Application_One_Widget. 107with Report; 108 109procedure CA11B02 is 110 111 package Application_One_Widget renames FA11B00; 112 113 package Application_Two_Widget renames FA11B00.CA11B02_0; 114 115 use Application_One_Widget ; 116 use Application_Two_Widget ; 117 118 type Emulator_Widget is new App2_Widget; -- Derived record of 119 -- parent type. 120 121 White_Widget, Amber_Widget : Emulator_Widget; 122 123 124begin 125 126 Report.Test ("CA11B02", "Check that a type derived in client of a " & 127 "public child inherits primitive operations from parent"); 128 129 App1_Widget_Specific_Oper (C => White, L => "Line Editor ", 130 The_Widget => White_Widget, I => 10); 131 -- Inherited from Application_One_Widget. 132 If White_Widget.Color /= White or 133 White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or 134 White_Widget.Label /= "Line Editor " 135 then 136 Report.Failed ("Incorrect result for White_Widget"); 137 end if; 138 139 -- perform an App2_Widget specific operation. 140 141 App2_Widget_Specific_Op1 (White_Widget, S => (100, 200)); 142 143 If White_Widget.Size.X_Length /= 100 or 144 White_Widget.Size.Y_Length /= 200 145 then 146 Report.Failed ("Incorrect size for White_Widget"); 147 end if; 148 149 App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor "); 150 -- Inherited from Application_One_Widget. 151 152 -- perform an App2_Widget specific operations. 153 154 App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget); 155 App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760)); 156 157 If Amber_Widget.Color /= Amber or 158 Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or 159 Amber_Widget.Label /= "Screen Editor " or 160 Amber_Widget.Size /= (1024,100) or 161 Amber_Widget.Location.X_Location /= 1024 or 162 Amber_Widget.Location.Y_Location /= 760 163 then 164 Report.Failed ("Incorrect result for Amber_Widget"); 165 end if; 166 167 Report.Result; 168 169end CA11B02; 170