| -- C3A0007.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 call to a subprogram via an access-to-subprogram value |
| -- stored in a data structure will correctly dispatch according to the |
| -- tag of the class-wide parameter passed via that call. |
| -- |
| -- TEST DESCRIPTION: |
| -- Declare an access to procedure type in a package specification. |
| -- Declare a root tagged type with the access to procedure type as a |
| -- component. Declare three primitive procedures for the type that |
| -- can be referred to by the access to procedure type. Use the access |
| -- to procedure type to initialize the component of a record. |
| -- |
| -- Extend the root type with a record extension in another package |
| -- specification. Declare a new primitive procedure for the extension |
| -- (in addition to its three inherited subprograms). |
| -- |
| -- In the main program, declare an operation for the root tagged type |
| -- which can be passed as an access value to change the initial value |
| -- of the component. Call the inherited operation indirectly by |
| -- dereferencing the access value to check on the initial value of the |
| -- extension. Call inherited operations indirectly by dereferencing |
| -- the access value to replace the initial value. Call the primitive |
| -- procedure indirectly by dereferencing the access value to modify the |
| -- extension. |
| -- |
| -- type Button |
| -- procedure Push(Button) |
| -- procedure Set_Response(Button,Button_Response_Ptr) |
| -- procedure Default_Response(Button) |
| -- |
| -- type Priority_Button (new Button) |
| -- procedures Push, Set_Response inherited |
| -- procedure Default_Response |
| -- procedure Set_Priority |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- |
| --! |
| |
| package C3A0007_0 is |
| |
| Default_Call : Boolean := False; |
| |
| type Button is tagged private; |
| |
| type Button_Response_Ptr is access procedure |
| (B : in out Button'Class); |
| |
| procedure Push (B : in out Button); -- to be inherited |
| |
| procedure Set_Response (B : in out Button; -- to be inherited |
| R : in Button_Response_Ptr); |
| |
| procedure Response (B : in out Button); -- to be inherited |
| |
| private |
| procedure Default_Response(B: in out Button'Class); |
| type Button is tagged -- root tagged type |
| record |
| Action : Button_Response_Ptr |
| := Default_Response'Access; |
| end record; |
| end C3A0007_0; |
| |
| with C3A0007_0; |
| package C3A0007_1 is |
| |
| type Priority_Button is new C3A0007_0.Button |
| with record |
| Priority : Integer := 0; |
| end record; |
| |
| -- Inherits procedure Push from Button |
| -- Inherits procedure Set_Response from Button |
| |
| -- Override procedure Response from Button |
| procedure Response (B : in out Priority_Button); |
| |
| -- Primitive operation of the extension |
| procedure Set_Priority (B : in out Priority_Button); |
| |
| end C3A0007_1; |
| |
| with C3A0007_0; |
| package C3A0007_2 is |
| |
| Emergency_Call : Boolean := False; |
| |
| procedure Emergency (B : in out C3A0007_0.Button'Class); |
| end C3A0007_2; |
| |
| ----------------------------------------------------------------------------- |
| |
| with TCTouch; |
| package body C3A0007_0 is |
| |
| procedure Push (B : in out Button) is |
| begin |
| TCTouch.Touch( 'P' ); --------------------------------------------- P |
| -- Invoking subprogram designated by access value |
| B.Action (B); |
| end Push; |
| |
| |
| procedure Set_Response (B : in out Button; |
| R : in Button_Response_Ptr) is |
| begin |
| TCTouch.Touch( 'S' ); --------------------------------------------- S |
| -- Set procedure value in record |
| B.Action := R; |
| end Set_Response; |
| |
| |
| procedure Response (B : in out Button) is |
| begin |
| TCTouch.Touch( 'D' ); --------------------------------------------- D |
| Default_Call := True; |
| end Response; |
| |
| procedure Default_Response (B : in out Button'Class) is |
| begin |
| TCTouch.Touch( 'C' ); --------------------------------------------- C |
| Response(B); |
| end Default_Response; |
| |
| end C3A0007_0; |
| |
| with TCTouch; |
| package body C3A0007_1 is |
| |
| procedure Set_Priority (B : in out Priority_Button) is |
| begin |
| TCTouch.Touch( 's' ); --------------------------------------------- s |
| B.Priority := 1; |
| end Set_Priority; |
| |
| procedure Response (B : in out Priority_Button) is |
| begin |
| TCTouch.Touch( 'd' ); --------------------------------------------- d |
| end Response; |
| |
| end C3A0007_1; |
| |
| with TCTouch; |
| package body C3A0007_2 is |
| procedure Emergency (B : in out C3A0007_0.Button'Class) is |
| begin |
| TCTouch.Touch( 'E' ); ------------------------------------------- E |
| Emergency_Call := True; |
| end Emergency; |
| end C3A0007_2; |
| |
| ----------------------------------------------------------------------------- |
| |
| with Report; |
| with TCTouch; |
| |
| with C3A0007_0; |
| with C3A0007_1; |
| with C3A0007_2; |
| procedure C3A0007 is |
| |
| Pink_Button : C3A0007_0.Button; |
| Green_Button : C3A0007_1.Priority_Button; |
| |
| begin |
| |
| Report.Test ("C3A0007", "Check that a call to a subprogram via an " |
| & "access-to-subprogram value stored in a data " |
| & "structure will correctly dispatch according to " |
| & "the tag of the class-wide parameter passed " |
| & "via that call" ); |
| |
| -- Call inherited operation Push to set Default_Response value |
| -- in the extension. |
| |
| C3A0007_1.Push (Green_Button); |
| TCTouch.Validate("PCd", "First Green Button Push"); |
| |
| TCTouch.Assert_Not(C3A0007_0.Default_Call, |
| "Incorrect Green Default_Response"); |
| |
| C3A0007_0.Push (Pink_Button); |
| TCTouch.Validate("PCD", "First Pink Button Push"); |
| |
| -- Call inherited operations Set_Response and Push to set |
| -- Emergency value in the extension. |
| C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access); |
| C3A0007_1.Push (Green_Button); |
| TCTouch.Validate("SPE", "Second Green Button Push"); |
| |
| TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency"); |
| |
| C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access); |
| C3A0007_0.Push (Pink_Button); |
| TCTouch.Validate("SPE", "Second Pink Button Push"); |
| |
| -- Call primitive operation to set priority value |
| -- in the extension. |
| C3A0007_1.Set_Priority (Green_Button); |
| TCTouch.Validate("s", "Green Button Priority"); |
| |
| TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority"); |
| |
| Report.Result; |
| |
| end C3A0007; |
