diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cc/cc54003.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cc/cc54003.a | 234 |
1 files changed, 0 insertions, 234 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc54003.a b/gcc/testsuite/ada/acats/tests/cc/cc54003.a deleted file mode 100644 index d8aaeaf9c81..00000000000 --- a/gcc/testsuite/ada/acats/tests/cc/cc54003.a +++ /dev/null @@ -1,234 +0,0 @@ --- 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; |