| -- CA11A01.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. |
| --* |
| -- |
| -- OBJECTIVE: |
| -- Check that type extended in a public child inherits primitive |
| -- operations from its ancestor. |
| -- |
| -- TEST DESCRIPTION: |
| -- Declare a root tagged type in a package specification. Declare two |
| -- primitive subprograms for the type (foundation code). |
| -- |
| -- Add a public child to the above package. Extend the root type with |
| -- a record extension in the specification. Declare a new primitive |
| -- subprogram to write to the child extension. |
| -- |
| -- Add a public grandchild to the above package. Extend the extension of |
| -- the parent type with a record extension in the private part of the |
| -- specification. Declare a new primitive subprogram for this grandchild |
| -- extension. |
| -- |
| -- In the main program, "with" the grandchild. Access the primitive |
| -- operations from grandparent and parent package. |
| -- |
| -- TEST FILES: |
| -- This test depends on the following foundation code: |
| -- |
| -- FA11A00.A |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- |
| --! |
| |
| package FA11A00.CA11A01_0 is -- Color_Widget_Pkg |
| -- This public child declares an extension from its parent. It |
| -- represents processing of widgets in a window system. |
| |
| type Widget_Color_Enum is (Black, Green, White); |
| |
| type Color_Widget is new Widget with -- Record extension of |
| record -- parent tagged type. |
| Color : Widget_Color_Enum; |
| end record; |
| |
| -- Inherits procedure Set_Width from Widget. |
| -- Inherits procedure Set_Height from Widget. |
| |
| -- To be inherited by its derivatives. |
| procedure Set_Color (The_Widget : in out Color_Widget; |
| C : in Widget_Color_Enum); |
| |
| procedure Set_Color_Widget (The_Widget : in out Color_Widget; |
| The_Width : in Widget_Length; |
| The_Height : in Widget_Length; |
| The_Color : in Widget_Color_Enum); |
| |
| end FA11A00.CA11A01_0; -- Color_Widget_Pkg |
| |
| --=======================================================================-- |
| |
| package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg |
| |
| procedure Set_Color (The_Widget : in out Color_Widget; |
| C : in Widget_Color_Enum) is |
| begin |
| The_Widget.Color := C; |
| end Set_Color; |
| --------------------------------------------------------------- |
| procedure Set_Color_Widget (The_Widget : in out Color_Widget; |
| The_Width : in Widget_Length; |
| The_Height : in Widget_Length; |
| The_Color : in Widget_Color_Enum) is |
| begin |
| Set_Width (The_Widget, The_Width); -- Inherited from parent. |
| Set_Height (The_Widget, The_Height); -- Inherited from parent. |
| Set_Color (The_Widget, The_Color); |
| end Set_Color_Widget; |
| |
| end FA11A00.CA11A01_0; -- Color_Widget_Pkg |
| |
| --=======================================================================-- |
| |
| package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg |
| -- This public grandchild extends the extension from its parent. It |
| -- represents processing of widgets in a window system. |
| |
| -- Declaration used by private extension component. |
| subtype Widget_Label_Str is string (1 .. 10); |
| |
| type Label_Widget is new Color_Widget with private; |
| -- Record extension of parent tagged type. |
| |
| -- Inherits (inherited) procedure Set_Width from Color_Widget. |
| -- Inherits (inherited) procedure Set_Height from Color_Widget. |
| -- Inherits procedure Set_Color from Color_Widget. |
| -- Inherits procedure Set_Color_Widget from Color_Widget. |
| |
| procedure Set_Label_Widget (The_Widget : in out Label_Widget; |
| The_Width : in Widget_Length; |
| The_Height : in Widget_Length; |
| The_Color : in Widget_Color_Enum; |
| The_Label : in Widget_Label_Str); |
| |
| -- The following function is needed to verify the value of the |
| -- extension's private component. |
| |
| function Verify_Label (The_Widget : in Label_Widget; |
| The_Label : in Widget_Label_Str) return Boolean; |
| |
| private |
| type Label_Widget is new Color_Widget with |
| record |
| Label : Widget_Label_Str; |
| end record; |
| |
| end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg |
| |
| --=======================================================================-- |
| |
| package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg |
| |
| procedure Set_Label (The_Widget : in out Label_Widget; |
| L : in Widget_Label_Str) is |
| begin |
| The_Widget.Label := L; |
| end Set_Label; |
| -------------------------------------------------------------- |
| procedure Set_Label_Widget (The_Widget : in out Label_Widget; |
| The_Width : in Widget_Length; |
| The_Height : in Widget_Length; |
| The_Color : in Widget_Color_Enum; |
| The_Label : in Widget_Label_Str) is |
| begin |
| Set_Width (The_Widget, The_Width); -- Twice inherited. |
| Set_Height (The_Widget, The_Height); -- Twice inherited. |
| Set_Color (The_Widget, The_Color); -- Inherited from parent. |
| Set_Label (The_Widget, The_Label); |
| end Set_Label_Widget; |
| -------------------------------------------------------------- |
| function Verify_Label (The_Widget : in Label_Widget; |
| The_Label : in Widget_Label_Str) return Boolean is |
| begin |
| return (The_Widget.Label = The_Label); |
| end Verify_Label; |
| |
| end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg |
| |
| --=======================================================================-- |
| |
| with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg, |
| -- implicitly with Widget_Pkg, |
| -- implicitly with Color_Widget_Pkg |
| with Report; |
| |
| procedure CA11A01 is |
| |
| package Widget_Pkg renames FA11A00; |
| package Color_Widget_Pkg renames FA11A00.CA11A01_0; |
| package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1; |
| |
| use Widget_Pkg; -- All user-defined operators directly visible. |
| |
| Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail"; |
| |
| Default_Widget : Widget; |
| Black_Widget : Color_Widget_Pkg.Color_Widget; |
| Mail_Widget : Label_Widget_Pkg.Label_Widget; |
| |
| begin |
| |
| Report.Test ("CA11A01", "Check that type extended in a public " & |
| "child inherits primitive operations from its " & |
| "ancestor"); |
| |
| Set_Width (Default_Widget, 9); -- Call from parent. |
| Set_Height (Default_Widget, 10); -- Call from parent. |
| |
| If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or |
| Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then |
| Report.Failed ("Incorrect result for Default_Widget"); |
| end if; |
| |
| Color_Widget_Pkg.Set_Color_Widget |
| (Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared. |
| |
| If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or |
| Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or |
| Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then |
| Report.Failed ("Incorrect result for Black_Widget"); |
| end if; |
| |
| Label_Widget_Pkg.Set_Label_Widget |
| (Mail_Widget, 15, 21, Color_Widget_Pkg.White, |
| "Quick_Mail"); -- Explicitly declared. |
| |
| If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or |
| Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or |
| Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or |
| not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then |
| Report.Failed ("Incorrect result for Mail_Widget"); |
| end if; |
| |
| Report.Result; |
| |
| end CA11A01; |
