1-- CA11A01.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 type extended in a public child inherits primitive 28-- operations from its ancestor. 29-- 30-- TEST DESCRIPTION: 31-- Declare a root tagged type in a package specification. Declare two 32-- primitive subprograms for the type (foundation code). 33-- 34-- Add a public child to the above package. Extend the root type with 35-- a record extension in the specification. Declare a new primitive 36-- subprogram to write to the child extension. 37-- 38-- Add a public grandchild to the above package. Extend the extension of 39-- the parent type with a record extension in the private part of the 40-- specification. Declare a new primitive subprogram for this grandchild 41-- extension. 42-- 43-- In the main program, "with" the grandchild. Access the primitive 44-- operations from grandparent and parent package. 45-- 46-- TEST FILES: 47-- This test depends on the following foundation code: 48-- 49-- FA11A00.A 50-- 51-- 52-- CHANGE HISTORY: 53-- 06 Dec 94 SAIC ACVC 2.0 54-- 55--! 56 57package FA11A00.CA11A01_0 is -- Color_Widget_Pkg 58-- This public child declares an extension from its parent. It 59-- represents processing of widgets in a window system. 60 61 type Widget_Color_Enum is (Black, Green, White); 62 63 type Color_Widget is new Widget with -- Record extension of 64 record -- parent tagged type. 65 Color : Widget_Color_Enum; 66 end record; 67 68 -- Inherits procedure Set_Width from Widget. 69 -- Inherits procedure Set_Height from Widget. 70 71 -- To be inherited by its derivatives. 72 procedure Set_Color (The_Widget : in out Color_Widget; 73 C : in Widget_Color_Enum); 74 75 procedure Set_Color_Widget (The_Widget : in out Color_Widget; 76 The_Width : in Widget_Length; 77 The_Height : in Widget_Length; 78 The_Color : in Widget_Color_Enum); 79 80end FA11A00.CA11A01_0; -- Color_Widget_Pkg 81 82--=======================================================================-- 83 84package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg 85 86 procedure Set_Color (The_Widget : in out Color_Widget; 87 C : in Widget_Color_Enum) is 88 begin 89 The_Widget.Color := C; 90 end Set_Color; 91 --------------------------------------------------------------- 92 procedure Set_Color_Widget (The_Widget : in out Color_Widget; 93 The_Width : in Widget_Length; 94 The_Height : in Widget_Length; 95 The_Color : in Widget_Color_Enum) is 96 begin 97 Set_Width (The_Widget, The_Width); -- Inherited from parent. 98 Set_Height (The_Widget, The_Height); -- Inherited from parent. 99 Set_Color (The_Widget, The_Color); 100 end Set_Color_Widget; 101 102end FA11A00.CA11A01_0; -- Color_Widget_Pkg 103 104--=======================================================================-- 105 106package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg 107-- This public grandchild extends the extension from its parent. It 108-- represents processing of widgets in a window system. 109 110 -- Declaration used by private extension component. 111 subtype Widget_Label_Str is string (1 .. 10); 112 113 type Label_Widget is new Color_Widget with private; 114 -- Record extension of parent tagged type. 115 116 -- Inherits (inherited) procedure Set_Width from Color_Widget. 117 -- Inherits (inherited) procedure Set_Height from Color_Widget. 118 -- Inherits procedure Set_Color from Color_Widget. 119 -- Inherits procedure Set_Color_Widget from Color_Widget. 120 121 procedure Set_Label_Widget (The_Widget : in out Label_Widget; 122 The_Width : in Widget_Length; 123 The_Height : in Widget_Length; 124 The_Color : in Widget_Color_Enum; 125 The_Label : in Widget_Label_Str); 126 127 -- The following function is needed to verify the value of the 128 -- extension's private component. 129 130 function Verify_Label (The_Widget : in Label_Widget; 131 The_Label : in Widget_Label_Str) return Boolean; 132 133private 134 type Label_Widget is new Color_Widget with 135 record 136 Label : Widget_Label_Str; 137 end record; 138 139end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg 140 141--=======================================================================-- 142 143package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg 144 145 procedure Set_Label (The_Widget : in out Label_Widget; 146 L : in Widget_Label_Str) is 147 begin 148 The_Widget.Label := L; 149 end Set_Label; 150 -------------------------------------------------------------- 151 procedure Set_Label_Widget (The_Widget : in out Label_Widget; 152 The_Width : in Widget_Length; 153 The_Height : in Widget_Length; 154 The_Color : in Widget_Color_Enum; 155 The_Label : in Widget_Label_Str) is 156 begin 157 Set_Width (The_Widget, The_Width); -- Twice inherited. 158 Set_Height (The_Widget, The_Height); -- Twice inherited. 159 Set_Color (The_Widget, The_Color); -- Inherited from parent. 160 Set_Label (The_Widget, The_Label); 161 end Set_Label_Widget; 162 -------------------------------------------------------------- 163 function Verify_Label (The_Widget : in Label_Widget; 164 The_Label : in Widget_Label_Str) return Boolean is 165 begin 166 return (The_Widget.Label = The_Label); 167 end Verify_Label; 168 169end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg 170 171--=======================================================================-- 172 173with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg, 174 -- implicitly with Widget_Pkg, 175 -- implicitly with Color_Widget_Pkg 176with Report; 177 178procedure CA11A01 is 179 180 package Widget_Pkg renames FA11A00; 181 package Color_Widget_Pkg renames FA11A00.CA11A01_0; 182 package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1; 183 184 use Widget_Pkg; -- All user-defined operators directly visible. 185 186 Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail"; 187 188 Default_Widget : Widget; 189 Black_Widget : Color_Widget_Pkg.Color_Widget; 190 Mail_Widget : Label_Widget_Pkg.Label_Widget; 191 192begin 193 194 Report.Test ("CA11A01", "Check that type extended in a public " & 195 "child inherits primitive operations from its " & 196 "ancestor"); 197 198 Set_Width (Default_Widget, 9); -- Call from parent. 199 Set_Height (Default_Widget, 10); -- Call from parent. 200 201 If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or 202 Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then 203 Report.Failed ("Incorrect result for Default_Widget"); 204 end if; 205 206 Color_Widget_Pkg.Set_Color_Widget 207 (Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared. 208 209 If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or 210 Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or 211 Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then 212 Report.Failed ("Incorrect result for Black_Widget"); 213 end if; 214 215 Label_Widget_Pkg.Set_Label_Widget 216 (Mail_Widget, 15, 21, Color_Widget_Pkg.White, 217 "Quick_Mail"); -- Explicitly declared. 218 219 If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or 220 Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or 221 Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or 222 not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then 223 Report.Failed ("Incorrect result for Mail_Widget"); 224 end if; 225 226 Report.Result; 227 228end CA11A01; 229