diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/ca/ca11a01.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/ca/ca11a01.a | 228 |
1 files changed, 0 insertions, 228 deletions
diff --git a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a b/gcc/testsuite/ada/acats/tests/ca/ca11a01.a deleted file mode 100644 index a84c6b84f44..00000000000 --- a/gcc/testsuite/ada/acats/tests/ca/ca11a01.a +++ /dev/null @@ -1,228 +0,0 @@ --- 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; |