| -- CC51002.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, for formal derived tagged types, the formal parameter |
| -- names and default expressions for a primitive subprogram in an |
| -- instance are determined by the primitive subprogram of the ancestor |
| -- type, but that the primitive subprogram body executed is that of the |
| -- actual type. |
| -- |
| -- TEST DESCRIPTION: |
| -- Define a root tagged type in a library-level package and give it a |
| -- primitive subprogram. Provide a default expression for a non-tagged |
| -- parameter of the subprogram. Declare a library-level generic subprogram |
| -- with a formal derived type using the root type as ancestor. Call |
| -- the primitive subprogram of the root type using named association for |
| -- the tagged parameter, and provide no actual for the defaulted |
| -- parameter. Extend the root type in a second package and override the |
| -- root type's subprogram with one which has different parameter names |
| -- and no default expression for the non-tagged parameter. Instantiate |
| -- the generic subprogram for each of the tagged types in the class and |
| -- call the instances. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- |
| --! |
| |
| package CC51002_0 is -- Root message type and operations. |
| |
| type Recipients is (None, Root, Sysop, Local, Remote); |
| |
| type Msg_Type is tagged record -- Root type of |
| Text : String (1 .. 10); -- class. |
| end record; |
| |
| function Send (Msg : in Msg_Type; -- Primitive |
| To : Recipients := Local) return Boolean; -- subprogram. |
| |
| -- ...Other message operations. |
| |
| end CC51002_0; |
| |
| |
| --==================================================================-- |
| |
| |
| package body CC51002_0 is |
| |
| -- The implementation of Send is purely artificial; the validity of |
| -- its implementation in the context of the abstraction is irrelevant to |
| -- the feature being tested. |
| |
| function Send (Msg : in Msg_Type; |
| To : Recipients := Local) return Boolean is |
| begin |
| return (Msg.Text = "Greetings!" and To = Local); |
| end Send; |
| |
| end CC51002_0; |
| |
| |
| --==================================================================-- |
| |
| |
| with CC51002_0; -- Root message type and operations. |
| generic -- Message class function. |
| type Msg_Block is new CC51002_0.Msg_Type with private; |
| function CC51002_1 (M : in Msg_Block) return Boolean; |
| |
| |
| --==================================================================-- |
| |
| |
| function CC51002_1 (M : in Msg_Block) return Boolean is |
| Okay : Boolean := False; |
| begin |
| |
| -- The call to Send below uses the ancestor type's parameter name, which |
| -- should be legal even if the actual subprogram called does not have a |
| -- parameter of that name. Furthermore, it uses the ancestor type's default |
| -- expression for the second parameter, which should be legal even if the |
| -- the actual subprogram called has no such default expression. |
| |
| Okay := Send (Msg => M); |
| -- ...Other processing. |
| return Okay; |
| |
| end CC51002_1; |
| |
| |
| --==================================================================-- |
| |
| |
| with CC51002_0; -- Root message type and operations. |
| package CC51002_2 is -- Extended message type and operations. |
| |
| type Sender_Type is (Inside, Outside); |
| |
| type Who_Msg_Type is new CC51002_0.Msg_Type with record -- Derivative of |
| From : Sender_Type; -- root type of |
| end record; -- class. |
| |
| |
| -- Note: this overriding version of Send has different parameter names |
| -- from the root type's function. It also has no default expression. |
| |
| function Send (M : Who_Msg_Type; -- Overrides |
| R : CC51002_0.Recipients) return Boolean; -- root type's |
| -- operation. |
| -- ...Other extended message operations. |
| |
| end CC51002_2; |
| |
| |
| --==================================================================-- |
| |
| |
| package body CC51002_2 is |
| |
| -- The implementation of Send is purely artificial; the validity of |
| -- its implementation in the context of the abstraction is irrelevant to |
| -- the feature being tested. |
| |
| function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is |
| use type CC51002_0.Recipients; |
| begin |
| return (M.Text = "Willkommen" and |
| M.From = Outside and |
| R = CC51002_0.Local); |
| end Send; |
| |
| end CC51002_2; |
| |
| |
| --==================================================================-- |
| |
| |
| with CC51002_0; -- Root message type and operations. |
| with CC51002_1; -- Message class function. |
| with CC51002_2; -- Extended message type and operations. |
| |
| with Report; |
| procedure CC51002 is |
| |
| function Send_Msg is new CC51002_1 (CC51002_0.Msg_Type); |
| function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type); |
| |
| Mess : CC51002_0.Msg_Type := (Text => "Greetings!"); |
| WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen", |
| From => CC51002_2.Outside); |
| |
| TC_Okay_MStatus : Boolean := False; |
| TC_Okay_WMStatus : Boolean := False; |
| |
| begin |
| Report.Test ("CC51002", "Check that, for formal derived tagged types, " & |
| "the formal parameter names and default expressions for " & |
| "a primitive subprogram in an instance are determined by " & |
| "the primitive subprogram of the ancestor type, but that " & |
| "the primitive subprogram body executed is that of the" & |
| "actual type"); |
| |
| TC_Okay_MStatus := Send_Msg (Mess); |
| if not TC_Okay_MStatus then |
| Report.Failed ("Wrong result from call to root type's operation"); |
| end if; |
| |
| TC_Okay_WMStatus := Send_WMsg (WMess); |
| if not TC_Okay_WMStatus then |
| Report.Failed ("Wrong result from call to derived type's operation"); |
| end if; |
| |
| Report.Result; |
| end CC51002; |
