URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c460a01.a] - Rev 154
Go to most recent revision | Compare with Previous | Blame | View Log
-- C460A01.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 if the target type of a type conversion is a general
-- access type, Program_Error is raised if the accessibility level of
-- the operand type is deeper than that of the target type. Check for
-- cases where the type conversion occurs in an instance body, and
-- the operand type is passed as an actual during instantiation.
--
-- TEST DESCRIPTION:
-- In order to satisfy accessibility requirements, the operand type must
-- be at the same or a less deep nesting level than the target type -- the
-- operand type must "live" as long as the target type. Nesting levels
-- are the run-time nestings of masters: block statements; subprogram,
-- task, and entry bodies; and accept statements. Packages are invisible
-- to accessibility rules.
--
-- This test checks for cases where the operand is a subprogram formal
-- parameter.
--
-- The test declares three generic packages, each containing an access
-- type conversion in which the operand type is a formal type:
--
-- (1) One in which the target type is declared within the
-- specification, and the conversion occurs within a nested
-- function.
--
-- (2) One in which the target type is also a formal type, and
-- the conversion occurs within a nested function.
--
-- (3) One in which the target type is declared outside the
-- generic, and the conversion occurs within a nested
-- procedure.
--
-- The test verifies the following:
--
-- For (1), Program_Error is not raised when the nested function is
-- called. Since the actual corresponding to the formal operand type
-- must always have the same or a less deep level than the target
-- type declared within the instance, the access type conversion is
-- always safe.
--
-- For (2), Program_Error is raised when the nested function is
-- called if the operand type passed as an actual during instantiation
-- has an accessibility level deeper than that of the target type
-- passed as an actual, and that no exception is raised otherwise.
-- The exception is propagated to the innermost enclosing master.
--
-- For (3), Program_Error is raised when the nested procedure is
-- called if the operand type passed as an actual during instantiation
-- has an accessibility level deeper than that of the target type.
-- The exception is handled within the nested procedure.
--
-- TEST FILES:
-- The following files comprise this test:
--
-- F460A00.A
-- => C460A01.A
--
--
-- CHANGE HISTORY:
-- 09 May 95 SAIC Initial prerelease version.
-- 24 Apr 96 SAIC Added code to avoid dead variable optimization.
-- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342.
--!
generic
type Designated_Type is tagged private;
type Operand_Type is access Designated_Type;
package C460A01_0 is
type Target_Type is access all Designated_Type;
function Convert (P : Operand_Type) return Target_Type;
end C460A01_0;
--==================================================================--
package body C460A01_0 is
function Convert (P : Operand_Type) return Target_Type is
begin
return Target_Type(P); -- Never fails.
end Convert;
end C460A01_0;
--==================================================================--
generic
type Designated_Type is tagged private;
type Operand_Type is access all Designated_Type;
type Target_Type is access all Designated_Type;
package C460A01_1 is
function Convert (P : Operand_Type) return Target_Type;
end C460A01_1;
--==================================================================--
package body C460A01_1 is
function Convert (P : Operand_Type) return Target_Type is
begin
return Target_Type(P);
end Convert;
end C460A01_1;
--==================================================================--
with F460A00;
generic
type Designated_Type (<>) is new F460A00.Tagged_Type with private;
type Operand_Type is access Designated_Type;
package C460A01_2 is
procedure Proc (P : Operand_Type;
Res : out F460A00.TC_Result_Kind);
end C460A01_2;
--==================================================================--
with Report;
package body C460A01_2 is
procedure Proc (P : Operand_Type;
Res : out F460A00.TC_Result_Kind) is
Ptr : F460A00.AccTag_L0;
begin
Ptr := F460A00.AccTag_L0(P);
-- Avoid optimization (dead variable removal of Ptr):
if not Report.Equal (Ptr.C, Ptr.C) then -- Always false.
Report.Failed ("Unexpected error in C460A01_2 instance");
end if;
Res := F460A00.OK;
exception
when Program_Error => Res := F460A00.PE_Exception;
when others => Res := F460A00.Others_Exception;
end Proc;
end C460A01_2;
--==================================================================--
with F460A00;
with C460A01_0;
with C460A01_1;
with C460A01_2;
with Report;
procedure C460A01 is
begin -- C460A01. -- [ Level = 1 ]
Report.Test ("C460A01", "Run-time accessibility checks: instance " &
"bodies. Operand type of access type conversion is " &
"passed as actual to instance");
SUBTEST1:
declare -- [ Level = 2 ]
type AccTag_L2 is access all F460A00.Tagged_Type;
Operand: AccTag_L2 := new F460A00.Tagged_Type;
Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
begin -- SUBTEST1.
declare -- [ Level = 3 ]
-- The instantiation of C460A01_0 should NOT result in any
-- exceptions.
package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2);
Target : Pack_OK.Target_Type;
begin
-- The accessibility level of Pack_OK.Target_Type will always be at
-- least as deep as the operand type passed as an actual. Thus,
-- a call to Pack_OK.Convert does not propagate an exception:
Target := Pack_OK.Convert(Operand);
-- Avoid optimization (dead variable removal of Target):
if not Report.Equal (Target.C, Target.C) then -- Always false.
Report.Failed ("Unexpected error in SUBTEST #1");
end if;
Result := F460A00.OK; -- Expected result.
exception
when Program_Error => Result := F460A00.PE_Exception;
when others => Result := F460A00.Others_Exception;
end;
F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1");
exception
when Program_Error =>
Report.Failed ("SUBTEST #1: Program_Error incorrectly raised");
when others =>
Report.Failed ("SUBTEST #1: Unexpected exception raised");
end SUBTEST1;
SUBTEST2:
declare -- [ Level = 2 ]
type AccTag_L2 is access all F460A00.Tagged_Type;
Operand : AccTag_L2 := new F460A00.Tagged_Type;
Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
begin -- SUBTEST2.
declare -- [ Level = 3 ]
type AccTag_L3 is access all F460A00.Tagged_Type;
Target : AccTag_L3;
-- The instantiation of C460A01_1 should NOT result in any
-- exceptions.
package Pack_OK is new C460A01_1
(Designated_Type => F460A00.Tagged_Type,
Operand_Type => AccTag_L2,
Target_Type => AccTag_L3);
begin
-- The accessibility level of the actual passed as the operand type
-- in Pack_OK is 2. The accessibility level of the actual passed as
-- the target type is 3. Therefore, the access type conversion in
-- Pack_OK.Convert does not raise an exception when the subprogram is
-- called. If an exception is (incorrectly) raised, it is propagated
-- to the innermost enclosing master:
Target := Pack_OK.Convert(Operand);
-- Avoid optimization (dead variable removal of Target):
if not Report.Equal (Target.C, Target.C) then -- Always false.
Report.Failed ("Unexpected error in SUBTEST #2");
end if;
Result := F460A00.OK; -- Expected result.
exception
when Program_Error => Result := F460A00.PE_Exception;
when others => Result := F460A00.Others_Exception;
end;
F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2");
exception
when Program_Error =>
Report.Failed ("SUBTEST #2: Program_Error incorrectly raised");
when others =>
Report.Failed ("SUBTEST #2: Unexpected exception raised");
end SUBTEST2;
SUBTEST3:
declare -- [ Level = 2 ]
type AccTag_L2 is access all F460A00.Tagged_Type;
Target : AccTag_L2;
Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
begin -- SUBTEST3.
declare -- [ Level = 3 ]
type AccTag_L3 is access all F460A00.Tagged_Type;
Operand : AccTag_L3 := new F460A00.Tagged_Type;
-- The instantiation of C460A01_1 should NOT result in any
-- exceptions.
package Pack_PE is new C460A01_1
(Designated_Type => F460A00.Tagged_Type,
Operand_Type => AccTag_L3,
Target_Type => AccTag_L2);
begin
-- The accessibility level of the actual passed as the operand type
-- in Pack_PE is 3. The accessibility level of the actual passed as
-- the target type is 2. Therefore, the access type conversion in
-- Pack_PE.Convert raises Program_Error when the subprogram is
-- called. The exception is propagated to the innermost enclosing
-- master:
Target := Pack_PE.Convert(Operand);
-- Avoid optimization (dead variable removal of Target):
if not Report.Equal (Target.C, Target.C) then -- Always false.
Report.Failed ("Unexpected error in SUBTEST #3");
end if;
Result := F460A00.OK;
exception
when Program_Error => Result := F460A00.PE_Exception;
-- Expected result.
when others => Result := F460A00.Others_Exception;
end;
F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3");
exception
when Program_Error =>
Report.Failed ("SUBTEST #3: Program_Error incorrectly raised");
when others =>
Report.Failed ("SUBTEST #3: Unexpected exception raised");
end SUBTEST3;
SUBTEST4:
declare -- [ Level = 2 ]
Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
begin -- SUBTEST4.
declare -- [ Level = 3 ]
TType : F460A00.Tagged_Type;
Operand : F460A00.AccTagClass_L0
:= new F460A00.Tagged_Type'(TType);
-- The instantiation of C460A01_2 should NOT result in any
-- exceptions.
package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class,
F460A00.AccTagClass_L0);
begin
-- The accessibility level of the actual passed as the operand type
-- in Pack_OK is 0. The accessibility level of the target type
-- (F460A00.AccTag_L0) is also 0. Therefore, the access type
-- conversion in Pack_OK.Proc does not raise an exception when the
-- subprogram is called. If an exception is (incorrectly) raised,
-- it is handled within the subprogram:
Pack_OK.Proc(Operand, Result);
end;
F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4");
exception
when Program_Error =>
Report.Failed ("SUBTEST #4: Program_Error incorrectly raised");
when others =>
Report.Failed ("SUBTEST #4: Unexpected exception raised");
end SUBTEST4;
SUBTEST5:
declare -- [ Level = 2 ]
Result : F460A00.TC_Result_Kind := F460A00.UN_Init;
begin -- SUBTEST5.
declare -- [ Level = 3 ]
type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type;
Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type;
-- The instantiation of C460A01_2 should NOT result in any
-- exceptions.
package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type,
AccDerTag_L3);
begin
-- The accessibility level of the actual passed as the operand type
-- in Pack_PE is 3. The accessibility level of the target type
-- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion
-- in Pack_PE.Proc raises Program_Error when the subprogram is
-- called. The exception is handled within the subprogram:
Pack_PE.Proc(Operand, Result);
end;
F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5");
exception
when Program_Error =>
Report.Failed ("SUBTEST #5: Program_Error incorrectly raised");
when others =>
Report.Failed ("SUBTEST #5: Unexpected exception raised");
end SUBTEST5;
Report.Result;
end C460A01;
Go to most recent revision | Compare with Previous | Blame | View Log