| -- 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; |
