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, 0 insertions, 156 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a b/gcc/testsuite/ada/acats/tests/ca/ca11a02.a deleted file mode 100644 index e7c161423fb..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11a02.a +++ /dev/null @@ -1,156 +0,0 @@ --- 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; |