diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cc/cc51d01.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cc/cc51d01.a | 262 |
1 files changed, 0 insertions, 262 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc51d01.a b/gcc/testsuite/ada/acats/tests/cc/cc51d01.a deleted file mode 100644 index 63c68c0d4fc..00000000000 --- a/gcc/testsuite/ada/acats/tests/cc/cc51d01.a +++ /dev/null @@ -1,262 +0,0 @@ --- CC51D01.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, in an instance, each implicit declaration of a user-defined --- subprogram of a formal private extension declares a view of the --- corresponding primitive subprogram of the ancestor, and that if the --- tag in a call is statically determined to be that of the formal type, --- the body executed will be that corresponding to the actual type. --- --- Check subprograms declared within a generic formal package. Check for --- the case where the actual type passed to the formal private extension --- is a specific tagged type. Check for several types in the same class. --- --- --- TEST DESCRIPTION: --- Declare a list abstraction in a generic package which manages lists of --- elements of any nonlimited type (foundation code). Declare a package --- which declares a tagged type and a type derived from it. Declare an --- operation for the root tagged type and override it for the derived --- type. Derive a type from this derived type, but do not override the --- operation. Declare a generic subprogram which operates on lists of --- elements of tagged types. Provide the generic subprogram with two --- formal parameters: (1) a formal derived tagged type which represents a --- list element type, and (2) a generic formal package with the list --- abstraction package as template. Use the formal derived type as the --- generic formal actual part for the formal package. Within the generic --- subprogram, call the operation of the root tagged type. In the main --- program, instantiate the generic list package and the generic --- subprogram with the root tagged type and each derivative, then call --- each instance with an object of the appropriate type. --- --- TEST FILES: --- The following files comprise this test: --- --- FC51D00.A --- -> CC51D01.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- 04 Jan 95 SAIC Moved declaration of type Ranked_ID_Type from --- main subprogram to package CC51D01_0. Removed --- case passing class-wide actual to instance. --- Updated test description and modified comments. --- ---! - -package CC51D01_0 is -- This package simulates support for a personnel - -- database. - - type SSN_Type is new String (1 .. 9); - - type Blind_ID_Type is tagged record -- Root type of - SSN : SSN_Type; -- class. - -- ... Other components. - end record; - - procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation. - - -- ... Other operations. - - - type Name_Type is new String (1 .. 9); - - type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative - Name : Name_Type := "Doe "; -- of root type. - -- ... Other components. - end record; - - -- Inherits Update_ID from parent. - - procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's - -- implementation. - - - type Ranked_ID_Type is new Named_ID_Type with record - Level : Integer := 0; -- Indirect derivative - -- ... Other components. -- of root type. - end record; - - -- Inherits Update_ID from parent. - -end CC51D01_0; - - - --==================================================================-- - - -package body CC51D01_0 is - - -- The implementations of Update_ID are purely artificial; the validity of - -- their implementations in the context of the abstraction is irrelevant to - -- the feature being tested. - - procedure Update_ID (Item : in out Blind_ID_Type) is - begin - Item.SSN := "111223333"; - end Update_ID; - - - procedure Update_ID (Item : in out Named_ID_Type) is - begin - Item.SSN := "444556666"; - -- ... Other stuff. - end Update_ID; - -end CC51D01_0; - - - --==================================================================-- - - --- -- --- Formal package used here. -- --- -- - -with FC51D00; -- Generic list abstraction. -with CC51D01_0; -- Tagged type declarations. -generic -- This procedure simulates a generic operation for types - -- in the class rooted at Blind_ID_Type. - type Elem_Type is new CC51D01_0.Blind_ID_Type with private; - with package List_Mgr is new FC51D00 (Elem_Type); -procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); - - - --==================================================================-- - - --- The implementation of CC51D01_1 is purely artificial; the validity --- of its implementation in the context of the abstraction is irrelevant --- to the feature being tested. --- --- The expected behavior here is as follows: for each actual type corresponding --- to Elem_Type, the call to Update_ID should invoke the actual type's --- implementation, which updates the object's SSN field. Write_Element then --- adds the object to the list. - -procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is - Element : Elem_Type := E; -- Can't update IN parameter. -begin - Update_ID (Element); -- Executes actual type's version. - List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version. -end CC51D01_1; - - - --==================================================================-- - - -with FC51D00; -- Generic list abstraction. -with CC51D01_0; -- Tagged type declarations. -with CC51D01_1; -- Generic operation. - -with Report; -procedure CC51D01 is - - use CC51D01_0; -- All types & ops - -- directly visible. - - -- Begin test code declarations: ----------------------- - - TC_Expected_1 : Blind_ID_Type := (SSN => "111223333"); - TC_Expected_2 : Named_ID_Type := ("444556666", "Doe "); - TC_Expected_3 : Ranked_ID_Type := ("444556666", "Doe ", 0); - - TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); - TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); - TC_Initial_3 : Ranked_ID_Type := ("777889999", "Doe ", 0); - - -- End test code declarations. ------------------------- - - - -- Begin instantiations and list declarations: --------- - - -- At this point in an application, the generic list package would be - -- instantiated for one of the visible tagged types. Next, the generic - -- subprogram would be instantiated for the same tagged type and the - -- preceding list package instance. - -- - -- In order to cover all the important cases, this test instantiates several - -- packages and subprograms (probably more than would typically appear - -- in user code). - - -- Support for lists of blind IDs: - - package Blind_Lists is new FC51D00 (Blind_ID_Type); - procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists); - Blind_List : Blind_Lists.List_Type; - - - -- Support for lists of named IDs: - - package Named_Lists is new FC51D00 (Named_ID_Type); - procedure Update_and_Write is new -- Overloads subprog - CC51D01_1 (Elem_Type => Named_ID_Type, -- for Blind_ID_Type. - List_Mgr => Named_Lists); - Named_List : Named_Lists.List_Type; - - - -- Support for lists of ranked IDs: - - package Ranked_Lists is new FC51D00 (Ranked_ID_Type); - procedure Update_and_Write is new -- Overloads. - CC51D01_1 (Elem_Type => Ranked_ID_Type, - List_Mgr => Ranked_Lists); - Ranked_List : Ranked_Lists.List_Type; - - -- End instantiations and list declarations. ----------- - - -begin - Report.Test ("CC51D01", "Formal private extension, specific tagged " & - "type actual: body of primitive subprogram executed is " & - "that of actual type. Check for subprograms declared in " & - "a formal package"); - - - Update_and_Write (Blind_List, TC_Initial_1); - - if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then - Report.Failed ("Wrong result for root tagged type"); - end if; - - - Update_and_Write (Named_List, TC_Initial_2); - - if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then - Report.Failed ("Wrong result for type derived directly from root"); - end if; - - - Update_and_Write (Ranked_List, TC_Initial_3); - - if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then - Report.Failed ("Wrong result for type derived indirectly from root"); - end if; - - - Report.Result; -end CC51D01; |