| -- C650001.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, for a function result type that is a return-by-reference |
| -- type, Program_Error is raised if the return expression is a name that |
| -- denotes an object view whose accessibility level is deeper than that |
| -- of the master that elaborated the function body. |
| -- |
| -- Check for cases where the result type is: |
| -- (a) A tagged limited type. |
| -- (b) A task type. |
| -- (c) A protected type. |
| -- (d) A composite type with a subcomponent of a |
| -- return-by-reference type (task type). |
| -- |
| -- TEST DESCRIPTION: |
| -- The accessibility level of the master that elaborates the body of a |
| -- return-by-reference function will always be less deep than that of |
| -- the function (which is itself a master). |
| -- |
| -- Thus, the return object may not be any of the following, since each |
| -- has an accessibility level at least as deep as that of the function: |
| -- |
| -- (1) An object declared local to the function. |
| -- (2) The result of a local function. |
| -- (3) A parameter of the function. |
| -- |
| -- Verify that Program_Error is raised within the return-by-reference |
| -- function if the return object is any of (1)-(3) above, for various |
| -- subsets of the return types (a)-(d) above. Include cases where (1)-(3) |
| -- are operands of parenthesized expressions. |
| -- |
| -- Verify that no exception is raised if the return object is any of the |
| -- following: |
| -- |
| -- (4) An object declared at a less deep level than that of the |
| -- master that elaborated the function body. |
| -- (5) The result of a function declared at the same level as the |
| -- original function (assuming the new function is also legal). |
| -- (6) A parameter of the master that elaborated the function body. |
| -- |
| -- For (5), pass the new function as an actual via an access-to- |
| -- subprogram parameter of the original function. Check for cases where |
| -- the new function does and does not raise an exception. |
| -- |
| -- Since the functions to be tested cannot be part of an assignment |
| -- statement (since they return values of a limited type), pass each |
| -- function result as an actual parameter to a dummy procedure, e.g., |
| -- |
| -- Dummy_Proc ( Function_Call ); |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 03 May 95 SAIC Initial prerelease version. |
| -- 08 Feb 99 RLB Removed subcase with two errors. |
| -- |
| --! |
| |
| package C650001_0 is |
| |
| type Tagged_Limited is tagged limited record |
| C: String (1 .. 10); |
| end record; |
| |
| task type Task_Type; |
| |
| protected type Protected_Type is |
| procedure Op; |
| end Protected_Type; |
| |
| type Task_Array is array (1 .. 10) of Task_Type; |
| |
| type Variant_Record (Toggle: Boolean) is record |
| case Toggle is |
| when True => |
| T: Task_Type; -- Return-by-reference component. |
| when False => |
| I: Integer; -- Non-return-by-reference component. |
| end case; |
| end record; |
| |
| -- Limited type even though variant contains no limited components: |
| type Non_Task_Variant is new Variant_Record (Toggle => False); |
| |
| end C650001_0; |
| |
| |
| --==================================================================-- |
| |
| |
| package body C650001_0 is |
| |
| task body Task_Type is |
| begin |
| null; |
| end Task_Type; |
| |
| protected body Protected_Type is |
| procedure Op is |
| begin |
| null; |
| end Op; |
| end Protected_Type; |
| |
| end C650001_0; |
| |
| |
| --==================================================================-- |
| |
| |
| with C650001_0; |
| package C650001_1 is |
| |
| type TC_Result_Kind is (OK, P_E, O_E); |
| |
| procedure TC_Display_Results (Actual : in TC_Result_Kind; |
| Expected: in TC_Result_Kind; |
| Message : in String); |
| |
| -- Dummy procedures: |
| |
| procedure Check_Tagged (P: C650001_0.Tagged_Limited); |
| procedure Check_Task (P: C650001_0.Task_Type); |
| procedure Check_Protected (P: C650001_0.Protected_Type); |
| procedure Check_Composite (P: C650001_0.Non_Task_Variant); |
| |
| end C650001_1; |
| |
| |
| --==================================================================-- |
| |
| |
| with Report; |
| package body C650001_1 is |
| |
| procedure TC_Display_Results (Actual : in TC_Result_Kind; |
| Expected: in TC_Result_Kind; |
| Message : in String) is |
| begin |
| if Actual /= Expected then |
| case Actual is |
| when OK => |
| Report.Failed ("No exception raised: " & Message); |
| when P_E => |
| Report.Failed ("Program_Error raised: " & Message); |
| when O_E => |
| Report.Failed ("Unexpected exception raised: " & Message); |
| end case; |
| end if; |
| end TC_Display_Results; |
| |
| |
| procedure Check_Tagged (P: C650001_0.Tagged_Limited) is |
| begin |
| null; |
| end; |
| |
| procedure Check_Task (P: C650001_0.Task_Type) is |
| begin |
| null; |
| end; |
| |
| procedure Check_Protected (P: C650001_0.Protected_Type) is |
| begin |
| null; |
| end; |
| |
| procedure Check_Composite (P: C650001_0.Non_Task_Variant) is |
| begin |
| null; |
| end; |
| |
| end C650001_1; |
| |
| |
| |
| --==================================================================-- |
| |
| |
| with C650001_0; |
| with C650001_1; |
| |
| with Report; |
| procedure C650001 is |
| begin |
| |
| Report.Test ("C650001", "Check that, for a function result type that " & |
| "is a return-by-reference type, Program_Error is raised " & |
| "if the return expression is a name that denotes an " & |
| "object view whose accessibility level is deeper than " & |
| "that of the master that elaborated the function body"); |
| |
| |
| |
| SUBTEST1: |
| declare |
| |
| Result: C650001_1.TC_Result_Kind; |
| PO : C650001_0.Protected_Type; |
| |
| function Return_Prot (P: C650001_0.Protected_Type) |
| return C650001_0.Protected_Type is |
| begin |
| Result := C650001_1.OK; |
| return P; -- Formal parameter (3). |
| exception |
| when Program_Error => |
| Result := C650001_1.P_E; -- Expected result. |
| return PO; |
| when others => |
| Result := C650001_1.O_E; |
| return PO; |
| end Return_Prot; |
| |
| begin -- SUBTEST1. |
| C650001_1.Check_Protected ( Return_Prot(PO) ); |
| C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #1"); |
| exception |
| when others => |
| Report.Failed ("SUBTEST #1: Unexpected exception in outer block"); |
| end SUBTEST1; |
| |
| |
| |
| SUBTEST2: |
| declare |
| |
| Result: C650001_1.TC_Result_Kind; |
| Comp : C650001_0.Non_Task_Variant; |
| |
| function Return_Composite return C650001_0.Non_Task_Variant is |
| Local: C650001_0.Non_Task_Variant; |
| begin |
| Result := C650001_1.OK; |
| return (Local); -- Parenthesized local object (1). |
| exception |
| when Program_Error => |
| Result := C650001_1.P_E; -- Expected result. |
| return Comp; |
| when others => |
| Result := C650001_1.O_E; |
| return Comp; |
| end Return_Composite; |
| |
| begin -- SUBTEST2. |
| C650001_1.Check_Composite ( Return_Composite ); |
| C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #2"); |
| exception |
| when others => |
| Report.Failed ("SUBTEST #2: Unexpected exception in outer block"); |
| end SUBTEST2; |
| |
| |
| |
| SUBTEST3: |
| declare |
| |
| Result: C650001_1.TC_Result_Kind; |
| Tsk : C650001_0.Task_Type; |
| TskArr: C650001_0.Task_Array; |
| |
| function Return_Task (P: C650001_0.Task_Array) |
| return C650001_0.Task_Type is |
| |
| function Inner return C650001_0.Task_Type is |
| begin |
| return P(P'First); -- OK: should not raise exception (6). |
| exception |
| when Program_Error => |
| Report.Failed ("SUBTEST #3: Program_Error incorrectly " & |
| "raised within function Inner"); |
| return Tsk; |
| when others => |
| Report.Failed ("SUBTEST #3: Unexpected exception " & |
| "raised within function Inner"); |
| return Tsk; |
| end Inner; |
| |
| begin -- Return_Task. |
| Result := C650001_1.OK; |
| return Inner; -- Call to local function (2). |
| exception |
| when Program_Error => |
| Result := C650001_1.P_E; -- Expected result. |
| return Tsk; |
| when others => |
| Result := C650001_1.O_E; |
| return Tsk; |
| end Return_Task; |
| |
| begin -- SUBTEST3. |
| C650001_1.Check_Task ( Return_Task(TskArr) ); |
| C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #3"); |
| exception |
| when others => |
| Report.Failed ("SUBTEST #3: Unexpected exception in outer block"); |
| end SUBTEST3; |
| |
| |
| |
| SUBTEST4: |
| declare |
| |
| Result: C650001_1.TC_Result_Kind; |
| TagLim: C650001_0.Tagged_Limited; |
| |
| function Return_TagLim (P: C650001_0.Tagged_Limited'Class) |
| return C650001_0.Tagged_Limited is |
| begin |
| Result := C650001_1.OK; |
| return C650001_0.Tagged_Limited(P); -- Conversion of formal param (3). |
| exception |
| when Program_Error => |
| Result := C650001_1.P_E; -- Expected result. |
| return TagLim; |
| when others => |
| Result := C650001_1.O_E; |
| return TagLim; |
| end Return_TagLim; |
| |
| begin -- SUBTEST4. |
| C650001_1.Check_Tagged ( Return_TagLim(TagLim) ); |
| C650001_1.TC_Display_Results (Result, C650001_1.P_E, |
| "SUBTEST #4 (root type)"); |
| exception |
| when others => |
| Report.Failed ("SUBTEST #4: Unexpected exception in outer block"); |
| end SUBTEST4; |
| |
| |
| |
| SUBTEST5: |
| declare |
| Tsk : C650001_0.Task_Type; |
| begin -- SUBTEST5. |
| |
| declare |
| Result: C650001_1.TC_Result_Kind; |
| |
| type AccToFunc is access function return C650001_0.Task_Type; |
| |
| function Return_Global return C650001_0.Task_Type is |
| begin |
| return Tsk; -- OK: should not raise exception (4). |
| end Return_Global; |
| |
| function Return_Local return C650001_0.Task_Type is |
| Local : C650001_0.Task_Type; |
| begin |
| return Local; -- Propagate Program_Error. |
| end Return_Local; |
| |
| |
| function Return_Func (P: AccToFunc) return C650001_0.Task_Type is |
| begin |
| Result := C650001_1.OK; |
| return P.all; -- Function call (5). |
| exception |
| when Program_Error => |
| Result := C650001_1.P_E; |
| return Tsk; |
| when others => |
| Result := C650001_1.O_E; |
| return Tsk; |
| end Return_Func; |
| |
| RG : AccToFunc := Return_Global'Access; |
| RL : AccToFunc := Return_Local'Access; |
| |
| begin |
| C650001_1.Check_Task ( Return_Func(RG) ); |
| C650001_1.TC_Display_Results (Result, C650001_1.OK, |
| "SUBTEST #5 (global task)"); |
| |
| C650001_1.Check_Task ( Return_Func(RL) ); |
| C650001_1.TC_Display_Results (Result, C650001_1.P_E, |
| "SUBTEST #5 (local task)"); |
| exception |
| when others => |
| Report.Failed ("SUBTEST #5: Unexpected exception in outer block"); |
| end; |
| |
| end SUBTEST5; |
| |
| |
| |
| Report.Result; |
| |
| end C650001; |
