diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11b02.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11b02.a | 169 |
1 files changed, 169 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11b02.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11b02.a new file mode 100644 index 000000000..0743f7333 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/ca/ca11b02.a @@ -0,0 +1,169 @@ +-- CA11B02.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 derived in a client of a public child inherits +-- primitive operations from parent. +-- +-- TEST DESCRIPTION: +-- Declare a root record type with discriminant in a package +-- specification. Declare a primitive subprogram for the type +-- (foundation code). +-- +-- Add a public child to the above package. Derive a new type +-- with constraint to the discriminant record type from the parent +-- package. Declare a new primitive subprogram to write to the child +-- derived type. +-- +-- In the main program, "with" the child. Derive a new type using the +-- record type from the child package. Access the inherited operations +-- from both parent and child packages. +-- +-- TEST FILES: +-- This test depends on the following foundation code: +-- +-- FA11B00.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +-- Child package of FA11B00. +package FA11B00.CA11B02_0 is -- Application_Two_Widget +-- This public child declares a derived type from its parent. It +-- represents processing of widgets in a window system. + + -- Dimension of app2_widget is limited to 5000 pixels. + + type App2_Widget is new App1_Widget (Maximum_Size => 5000); + -- Derived record of parent type. + + -- Inherits procedure App1_Widget_Specific_Oper from parent. + + + -- Primitive operation of type App2_Widget. + + procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; + S : in Widget_Size); + + -- Primitive operation of type App2_Widget. + + procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; + Loc : in Widget_Location); + +end FA11B00.CA11B02_0; -- Application_Two_Widget + + +--=======================================================================-- + + +package body FA11B00.CA11B02_0 is -- Application_Two_Widget + + procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; + S : in Widget_Size) is + begin + The_Widget.Size := S; + end App2_Widget_Specific_Op1; + + --==============================================-- + + procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; + Loc : in Widget_Location) is + begin + The_Widget.Location := Loc; + end App2_Widget_Specific_Op2; + +end FA11B00.CA11B02_0; -- Application_Two_Widget + + +--=======================================================================-- + +with FA11B00.CA11B02_0; -- Application_Two_Widget + -- implicitly with Application_One_Widget. +with Report; + +procedure CA11B02 is + + package Application_One_Widget renames FA11B00; + + package Application_Two_Widget renames FA11B00.CA11B02_0; + + use Application_One_Widget ; + use Application_Two_Widget ; + + type Emulator_Widget is new App2_Widget; -- Derived record of + -- parent type. + + White_Widget, Amber_Widget : Emulator_Widget; + + +begin + + Report.Test ("CA11B02", "Check that a type derived in client of a " & + "public child inherits primitive operations from parent"); + + App1_Widget_Specific_Oper (C => White, L => "Line Editor ", + The_Widget => White_Widget, I => 10); + -- Inherited from Application_One_Widget. + If White_Widget.Color /= White or + White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or + White_Widget.Label /= "Line Editor " + then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + -- perform an App2_Widget specific operation. + + App2_Widget_Specific_Op1 (White_Widget, S => (100, 200)); + + If White_Widget.Size.X_Length /= 100 or + White_Widget.Size.Y_Length /= 200 + then + Report.Failed ("Incorrect size for White_Widget"); + end if; + + App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor "); + -- Inherited from Application_One_Widget. + + -- perform an App2_Widget specific operations. + + App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget); + App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760)); + + If Amber_Widget.Color /= Amber or + Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or + Amber_Widget.Label /= "Screen Editor " or + Amber_Widget.Size /= (1024,100) or + Amber_Widget.Location.X_Location /= 1024 or + Amber_Widget.Location.Y_Location /= 760 + then + Report.Failed ("Incorrect result for Amber_Widget"); + end if; + + Report.Result; + +end CA11B02; |