| -- CC51001.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 formal parameter of a generic package may be a formal |
| -- derived type. Check that the formal derived type may have an unknown |
| -- discriminant part. Check that the ancestor type in a formal derived |
| -- type definition may be a tagged type, and that the actual parameter |
| -- may be a descendant of the ancestor type. Check that the formal derived |
| -- type belongs to the derivation class rooted at the ancestor type; |
| -- specifically, that components of the ancestor type may be referenced |
| -- within the generic. Check that if a formal derived subtype is |
| -- indefinite then the actual may be either definite or indefinite. |
| -- |
| -- TEST DESCRIPTION: |
| -- Define a class of tagged types with a definite root type. Extend the |
| -- root type with a discriminated component. Since discriminants of |
| -- tagged types may not have defaults, the type is indefinite. |
| -- |
| -- Extend the extension with a second discriminated component, but with |
| -- a new discriminant part. Declare a generic package with a formal |
| -- derived type using the root type of the class as ancestor, and an |
| -- unknown discriminant part. Declare an operation in the generic which |
| -- accesses the common component of types in the class. |
| -- |
| -- In the main program, instantiate the generic with each type in the |
| -- class and verify that the operation correctly accesses the common |
| -- component. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- |
| --! |
| |
| package CC51001_0 is -- Root type for message class. |
| |
| subtype Msg_String is String (1 .. 20); |
| |
| type Msg_Type is tagged record -- Root type of |
| Text : Msg_String := (others => ' '); -- class (definite). |
| end record; |
| |
| end CC51001_0; |
| |
| |
| -- No body for CC51001_0. |
| |
| |
| --==================================================================-- |
| |
| |
| with CC51001_0; -- Root type for message class. |
| package CC51001_1 is -- Extensions to message class. |
| |
| subtype Source_Length is Natural range 0 .. 10; |
| |
| type From_Msg_Type (SLen : Source_Length) is -- Direct derivative |
| new CC51001_0.Msg_Type with record -- of root type |
| From : String (1 .. SLen); -- (indefinite). |
| end record; |
| |
| subtype Dest_Length is Natural range 0 .. 10; |
| |
| |
| |
| type To_From_Msg_Type (DLen : Dest_Length) is -- Indirect |
| new From_Msg_Type (SLen => 10) with record -- derivative of |
| To : String (1 .. DLen); -- root type |
| end record; -- (indefinite). |
| |
| end CC51001_1; |
| |
| |
| -- No body for CC51001_1. |
| |
| |
| --==================================================================-- |
| |
| |
| with CC51001_0; -- Root type for message class. |
| generic -- I/O operations for message class. |
| type Message_Type (<>) is new CC51001_0.Msg_Type with private; |
| package CC51001_2 is |
| |
| -- This subprogram contains an artificial result for testing purposes: |
| -- the function returns the text of the message to the caller as a string. |
| |
| function Print_Message (M : in Message_Type) return String; |
| |
| -- ... Other operations. |
| |
| end CC51001_2; |
| |
| |
| --==================================================================-- |
| |
| |
| package body CC51001_2 is |
| |
| -- The implementations of the operations below are purely artificial; the |
| -- validity of their implementations in the context of the abstraction is |
| -- irrelevant to the feature being tested. |
| |
| function Print_Message (M : in Message_Type) return String is |
| begin |
| return M.Text; |
| end Print_Message; |
| |
| end CC51001_2; |
| |
| |
| --==================================================================-- |
| |
| |
| with CC51001_0; -- Root type for message class. |
| with CC51001_1; -- Extensions to message class. |
| with CC51001_2; -- I/O operations for message class. |
| |
| with Report; |
| procedure CC51001 is |
| |
| -- Instantiate for various types in the class: |
| |
| package Msgs is new CC51001_2 (CC51001_0.Msg_Type); -- Definite. |
| package FMsgs is new CC51001_2 (CC51001_1.From_Msg_Type); -- Indefinite. |
| package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite. |
| |
| |
| |
| Msg : CC51001_0.Msg_Type := (Text => "This is message #001"); |
| FMsg : CC51001_1.From_Msg_Type := (Text => "This is message #002", |
| SLen => 2, |
| From => "Me"); |
| TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003", |
| From => "You ", |
| DLen => 4, |
| To => "Them"); |
| |
| Expected_Msg : constant String := "This is message #001"; |
| Expected_FMsg : constant String := "This is message #002"; |
| Expected_TFMsg : constant String := "This is message #003"; |
| |
| begin |
| Report.Test ("CC51001", "Check that the formal derived type may have " & |
| "an unknown discriminant part. Check that the ancestor " & |
| "type in a formal derived type definition may be a " & |
| "tagged type, and that the actual parameter may be any " & |
| "definite or indefinite descendant of the ancestor type"); |
| |
| if (Msgs.Print_Message (Msg) /= Expected_Msg) then |
| Report.Failed ("Wrong result for definite root type"); |
| end if; |
| |
| if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then |
| Report.Failed ("Wrong result for direct indefinite derivative"); |
| end if; |
| |
| if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then |
| Report.Failed ("Wrong result for Indirect indefinite derivative"); |
| end if; |
| |
| Report.Result; |
| end CC51001; |
