From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/cc/cc54003.a | 234 +++++++++++++++++++++++++++++ 1 file changed, 234 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/cc/cc54003.a (limited to 'gcc/testsuite/ada/acats/tests/cc/cc54003.a') diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54003.a b/gcc/testsuite/ada/acats/tests/cc/cc54003.a new file mode 100644 index 000000000..d8aaeaf9c --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/cc/cc54003.a @@ -0,0 +1,234 @@ +-- CC54003.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 general access-to-subprogram type may be passed as an +-- actual to a generic formal access-to-subprogram type. Check that +-- designated subprograms may be called by dereferencing the access +-- values. +-- +-- TEST DESCRIPTION: +-- The generic implements a stack of access-to-subprogram objects as an +-- array. The profile of the access-to-subprogram formal corresponds to +-- a function which accepts a parameter of some type and returns an +-- object of the same type. +-- +-- For this test, the functions for which access values will be pushed +-- onto the stack accept a parameter of type access-to-string, lengthen +-- the pointed-to string, then return an access object pointing to this +-- lengthened string. +-- +-- The instance declares a function Execute_Stack which executes each +-- subprogram on the stack in sequence. This function accepts some initial +-- access-to-string, then returns an access object pointing to the +-- lengthened string resulting from the execution of the stacked +-- subprograms. Access-to-string objects are used rather than strings +-- themselves because the initial string "grows" during each iteration. +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause +-- preceding CC54003_2. +-- +--! + +generic + + Size : in Positive; + + type Item_Type (<>) is private; + type Item_Ptr is access Item_Type; + + type Function_Ptr is access function (Item : Item_Ptr) + return Item_Ptr; + +package CC54003_0 is -- Generic stack of pointers. + + type Stack_Type is private; + + procedure Push (Stack : in out Stack_Type; + Func_Ptr : in Function_Ptr); + + function Execute_Stack (Stack : Stack_Type; + Initial_Input : Item_Ptr) return Item_Ptr; + + -- ... Other operations. + +private + + subtype Index is Positive range 1 .. (Size + 1); + type Stack_Type is array (Index) of Function_Ptr; -- Last slot unused. + + Top : Index := 1; -- Top refers to the next available slot. + +end CC54003_0; + + + --===================================================================-- + + +package body CC54003_0 is + + procedure Push (Stack : in out Stack_Type; + Func_Ptr : in Function_Ptr) is + begin + Stack(Top) := Func_Ptr; + Top := Top + 1; -- Artificial: no Constraint_Error protection. + end Push; + + + -- Call each subprogram on the stack in sequence. For the first call, pass + -- Initial_Input. For succeeding calls, pass the result of the previous + -- call. + + function Execute_Stack (Stack : Stack_Type; + Initial_Input : Item_Ptr) return Item_Ptr is + Result : Item_Ptr := Initial_Input; + begin + for I in reverse Index'First .. (Top - 1) loop -- Artificial: no C_E + Result := Stack(I)(Result); -- protection. + end loop; + return Result; + end Execute_Stack; + +end CC54003_0; + + + --===================================================================-- + + +package CC54003_1 is + + subtype Message is String; + type Message_Ptr is access Message; + + function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr; + function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr; + + -- ...Other operations. + +end CC54003_1; + + + --===================================================================-- + + +package body CC54003_1 is + + function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr is + Sender : constant String := "Dummy: "; -- Artificial; in a real + -- application Sender might + New_Msg : Message := Sender & Msg_Ptr.all; -- be a call to a function. + begin + return new Message'(New_Msg); + end Add_Prefix; + + + function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr is + Time : constant String := " (12:03pm)"; -- Artificial; in a real + -- application Time might be a + New_Msg : Message := Msg_Ptr.all & Time; -- be a call to a function. + begin + return new Message'(New_Msg); + end Add_Suffix; + +end CC54003_1; + + + --===================================================================-- + + +with CC54003_0; -- Generic stack of pointers. +pragma Elaborate (CC54003_0); + +with CC54003_1; -- Message abstraction. + +package CC54003_2 is + + type Operation_Ptr is access function (Msg_Ptr : CC54003_1.Message_Ptr) + return CC54003_1.Message_Ptr; + + Maximum_Ops : constant := 4; -- Arbitrary. + + package Stack_of_Ops is new CC54003_0 + (Item_Type => CC54003_1.Message, + Item_Ptr => CC54003_1.Message_Ptr, + Function_Ptr => Operation_Ptr, + Size => Maximum_Ops); + + Operation_Stack : Stack_Of_Ops.Stack_Type; + + + procedure Create_Operation_Stack; + +end CC54003_2; + + --===================================================================-- + + +package body CC54003_2 is + + procedure Create_Operation_Stack is + begin + Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Prefix'Access); + Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Suffix'Access); + end Create_Operation_Stack; + +end CC54003_2; + + + --===================================================================-- + + +with CC54003_1; -- Message abstraction. +with CC54003_2; -- Message-operation stack. + +with Report; +procedure CC54003 is + + package Msg_Ops renames CC54003_2.Stack_Of_Ops; + + Msg : CC54003_1.Message_Ptr := new CC54003_1.Message'("Hello there"); + Expected : CC54003_1.Message := "Dummy: Hello there (12:03pm)"; + +begin + Report.Test ("CC54003", "Check that a general access-to-subprogram type " & + "may be passed as an actual to a generic formal " & + "access-to-subprogram type"); + + CC54003_2.Create_Operation_Stack; + + declare + Actual : CC54003_1.Message_Ptr := + Msg_Ops.Execute_Stack (CC54003_2.Operation_Stack, Msg); + begin + if Actual.all /= Expected then + Report.Failed ("Wrong result from dereferenced subprogram execution"); + end if; + end; + + Report.Result; +end CC54003; -- cgit v1.2.3