| -- C3A0009.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 subprogram references may be passed as parameters using |
| -- access-to-subprogram types. Check that the passed subprograms may |
| -- be invoked from within the called subprogram. |
| -- |
| -- 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 private extension in the same package |
| -- specification. Declare two new primitive subprograms 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 operations indirectly by |
| -- de-referencing the access value to set value in the extension. |
| -- Call the primitive function to modify the extension by passing |
| -- the access value designating the primitive procedure as a parameter. |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- |
| --! |
| |
| package C3A0009_0 is -- Push_Buttons |
| |
| type Button is tagged private; |
| |
| -- Type accesses to procedures Push and Default_Response |
| type Button_Response_Ptr is access procedure |
| (B : in out Button); |
| |
| 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 Default_Response (B : in out Button); -- to be inherited |
| |
| type Alert_Button is new Button with private; -- private extension of |
| -- root tagged type |
| -- Inherits procedure Push from Button |
| -- Inherits procedure Set_Response from Button |
| -- Inherits procedure Default_Response from Button |
| |
| procedure Replace_Action( B: in out Alert_Button ); |
| |
| -- type accesses to procedure Default_Action |
| type Button_Action_Ptr is access procedure; |
| |
| -- The following function is needed to set value in the |
| -- extension's private component. |
| function Alert (B : in Alert_Button) return Button_Action_Ptr; |
| |
| private |
| |
| type Button is tagged -- root tagged type |
| record |
| Response : Button_Response_Ptr |
| := Default_Response'Access; |
| end record; |
| |
| procedure Default_Action; |
| |
| type Alert_Button is new Button with record |
| Action : Button_Action_Ptr |
| := Default_Action'Access; |
| end record; |
| |
| end C3A0009_0; |
| |
| |
| ----------------------------------------------------------------------------- |
| |
| |
| with TCTouch; |
| package body C3A0009_0 is |
| |
| procedure Push (B : in out Button) is |
| begin |
| TCTouch.Touch( 'P' ); --------------------------------------------- P |
| -- Invoking subprogram designated by access value |
| B.Response (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.Response := R; |
| end Set_Response; |
| |
| |
| procedure Default_Response (B : in out Button) is |
| begin |
| TCTouch.Touch( 'D' ); --------------------------------------------- D |
| end Default_Response; |
| |
| |
| procedure Default_Action is |
| begin |
| TCTouch.Touch( 'd' ); --------------------------------------------- d |
| end Default_Action; |
| |
| procedure Replacement_Action is |
| begin |
| TCTouch.Touch( 'r' ); --------------------------------------------- r |
| end Replacement_Action; |
| |
| procedure Replace_Action( B: in out Alert_Button ) is |
| begin |
| TCTouch.Touch( 'R' ); --------------------------------------------- R |
| B.Action := Replacement_Action'Access; |
| end Replace_Action; |
| |
| function Alert (B : in Alert_Button) return Button_Action_Ptr is |
| begin |
| TCTouch.Touch( 'A' ); --------------------------------------------- A |
| return (B.Action); |
| end Alert; |
| |
| end C3A0009_0; |
| |
| ----------------------------------------------------------------------------- |
| |
| with C3A0009_0; |
| package C3A0009_1 is -- Emergency_Items |
| package Push_Buttons renames C3A0009_0; |
| |
| procedure Emergency (B : in out Push_Buttons.Button); |
| end C3A0009_1; |
| |
| with TCTouch; |
| package body C3A0009_1 is -- Emergency_Items |
| procedure Emergency (B : in out Push_Buttons.Button) is |
| begin |
| TCTouch.Touch( 'E' ); ------------------------------------------- E |
| end Emergency; |
| end C3A0009_1; |
| ----------------------------------------------------------------------------- |
| |
| with Report; |
| |
| with C3A0009_0, C3A0009_1; |
| with TCTouch; |
| procedure C3A0009 is |
| |
| package Push_Buttons renames C3A0009_0; |
| package Emergency_Items renames C3A0009_1; |
| |
| Black_Button : Push_Buttons.Alert_Button; |
| Alert_Ptr : Push_Buttons.Button_Action_Ptr; |
| |
| begin |
| |
| Report.Test ("C3A0009", "Check that subprogram references may be passed " |
| & "as parameters using access-to-subprogram types. " |
| & "Check that the passed subprograms may be " |
| & "invoked from within the called subprogram"); |
| |
| |
| Push_Buttons.Push( Black_Button ); |
| Push_Buttons.Alert( Black_Button ).all; |
| |
| TCTouch.Validate( "PDAd", "Default operation set" ); |
| |
| -- Call inherited operations Set_Response and Push to set |
| -- Emergency value in the extension. |
| Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access); |
| |
| |
| Push_Buttons.Push( Black_Button ); |
| Push_Buttons.Alert( Black_Button ).all; |
| |
| TCTouch.Validate( "SPEAd", "Altered Response set" ); |
| |
| -- Call primitive operation to set action value in the extension. |
| Push_Buttons.Replace_Action( Black_Button ); |
| |
| |
| Push_Buttons.Push( Black_Button ); |
| Push_Buttons.Alert( Black_Button ).all; |
| |
| TCTouch.Validate( "RPEAr", "Altered Action set" ); |
| |
| Report.Result; |
| end C3A0009; |
