diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/ca/ca11a02.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/ca/ca11a02.a | 156 |
1 files changed, 156 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a new file mode 100644 index 000000000..e7c161423 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a @@ -0,0 +1,156 @@ +-- CA11A02.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 a type extended in a client of a public child inherits +-- primitive operations from parent. +-- +-- 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. +-- +-- In the main program, "with" the child. Declare an extension of +-- the child extension. Access the primitive operations from both +-- parent and child packages. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11A00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level +-- +--! + +package FA11A00.CA11A02_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 parent. + -- Inherits procedure Set_Height from parent. + + -- To be inherited by its derivatives. + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum); + +end FA11A00.CA11A02_0; -- Color_Widget_Pkg + +--=======================================================================-- + +package body FA11A00.CA11A02_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; + +end FA11A00.CA11A02_0; -- Color_Widget_Pkg + +--=======================================================================-- + +with FA11A00.CA11A02_0; -- Color_Widget_Pkg. + +package CA11A02_1 is + + type Label_Widget (Str_Disc : Integer) is new + FA11A00.CA11A02_0.Color_Widget with + record + Label : String (1 .. Str_Disc); + end record; + + -- Inherits (inherited) procedure Set_Width from Color_Widget. + -- Inherits (inherited) procedure Set_Height from Color_Widget. + -- Inherits procedure Set_Color from Color_Widget. + +end CA11A02_1; + +--=======================================================================-- + +with FA11A00.CA11A02_0; -- Color_Widget_Pkg, + -- implicitly with Widget_Pkg +with CA11A02_1; + +with Report; + +procedure CA11A02 is + + package Widget_Pkg renames FA11A00; + package Color_Widget_Pkg renames FA11A00.CA11A02_0; + + use Widget_Pkg; -- All user-defined operators directly visible. + + procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget; + L : in String) is + begin + The_Widget.Label := L; + end Set_Label; + --------------------------------------------------------- + procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in + Color_Widget_Pkg.Widget_Color_Enum; + The_Label : in String) is + begin + CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited. + CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited. + CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited. + Set_Label (The_Widget, The_Label); -- Explicitly declared. + end Set_Widget; + + White_Widget : CA11A02_1.Label_Widget (11); + +begin + + Report.Test ("CA11A02", "Check that a type extended in a client of " & + "a public child inherits primitive operations from parent"); + + Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock"); + + If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or + White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or + Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or + White_Widget.Label /= "Alarm_Clock" then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + Report.Result; + +end CA11A02; |