-- 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;