1 files changed, 219 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c3a0009.a b/gcc/testsuite/ada/acats/tests/c3/c3a0009.a
new file mode 100644
index 000000000..ba3f2f6e1
--- /dev/null
+++ b/gcc/testsuite/ada/acats/tests/c3/c3a0009.a
@@ -0,0 +1,219 @@
+-- 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;