| -- CC51D02.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 class-wide 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 derivative. Declare an operation |
| -- for the root tagged type and override it for the derivative. 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 class-wide |
| -- type for the root tagged type. |
| -- |
| -- TEST FILES: |
| -- The following files comprise this test: |
| -- |
| -- FC51D00.A |
| -- -> CC51D02.A |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 05 Jan 95 SAIC Changed types of TC_Expected_1 and TC_Expected_2 |
| -- from specific to class-wide. Eliminated (illegal) |
| -- assignment step prior to comparison of |
| -- TC_Expected_X with item on stack. |
| -- |
| --! |
| |
| package CC51D02_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. |
| |
| end CC51D02_0; |
| |
| |
| --==================================================================-- |
| |
| |
| package body CC51D02_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 CC51D02_0; |
| |
| |
| --==================================================================-- |
| |
| |
| -- -- |
| -- Formal package used here. -- |
| -- -- |
| |
| with FC51D00; -- Generic list abstraction. |
| with CC51D02_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 CC51D02_0.Blind_ID_Type with private; |
| with package List_Mgr is new FC51D00 (Elem_Type); |
| procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); |
| |
| |
| --==================================================================-- |
| |
| |
| -- The implementation of CC51D02_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 (based on the tag of the actual), which updates the object's |
| -- SSN field. Write_Element then adds the object to the list. |
| |
| procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is |
| Element : Elem_Type := E; -- Can't update IN parameter. |
| -- Initialization of unconstrained variable. |
| begin |
| Update_ID (Element); -- Executes actual type's version |
| -- (for this test, this will be a |
| -- dispatching call). |
| List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version |
| -- (for this test, this will be a |
| -- class-wide operation). |
| end CC51D02_1; |
| |
| |
| --==================================================================-- |
| |
| |
| with FC51D00; -- Generic list abstraction. |
| with CC51D02_0; -- Tagged type declarations. |
| with CC51D02_1; -- Generic operation. |
| |
| with Report; |
| procedure CC51D02 is |
| |
| use CC51D02_0; -- All types & ops |
| -- directly visible. |
| |
| -- Begin test code declarations: ----------------------- |
| |
| TC_Expected_1 : Blind_ID_Type'Class := |
| Blind_ID_Type'(SSN => "111223333"); |
| TC_Expected_2 : Blind_ID_Type'Class := |
| Named_ID_Type'("444556666", "Doe "); |
| |
| |
| TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); |
| TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); |
| TC_Initial_3 : Blind_ID_Type'Class := TC_Initial_2; |
| |
| -- End test code declarations. ------------------------- |
| |
| |
| package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class); |
| |
| procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class, |
| ID_Class_Lists); |
| |
| Blind_List : ID_Class_Lists.List_Type; |
| Named_List : ID_Class_Lists.List_Type; |
| Maimed_List : ID_Class_Lists.List_Type; |
| |
| |
| begin |
| Report.Test ("CC51D02", "Formal private extension, class-wide actual: " & |
| "body of primitive subprogram executed is that of actual " & |
| "type. Check for subprograms declared in formal package"); |
| |
| |
| Update_and_Write (Blind_List, TC_Initial_1); -- Test root type actual. |
| |
| if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then |
| Report.Failed ("Result for root type actual is not in proper class"); |
| elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then |
| Report.Failed ("Wrong result for root type actual"); |
| end if; |
| |
| |
| Update_and_Write (Named_List, TC_Initial_2); -- Test derived type actual. |
| |
| if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then |
| Report.Failed ("Result for derived type actual is not in proper class"); |
| elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then |
| Report.Failed ("Wrong result for derived type actual"); |
| end if; |
| |
| |
| -- In the subtest below, an object of a class-wide type (TC_Initial_3) is |
| -- passed to Update_and_Write. It has been initialized with an object of |
| -- type Named_ID_Type, so the result should be identical to |
| -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that |
| -- a new list of Named IDs is used (Maimed_List). This is to assure test |
| -- validity, since Named_List has already been updated by a previous |
| -- subtest. |
| |
| Update_and_Write (Maimed_List, TC_Initial_3); -- Test class-wide actual. |
| |
| if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then |
| Report.Failed ("Result for class-wide actual is not in proper class"); |
| elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then |
| Report.Failed ("Wrong result for class-wide actual"); |
| end if; |
| |
| |
| Report.Result; |
| end CC51D02; |
