-- C460004.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 operand type of a type conversion is class-wide, -- Constraint_Error is raised if the tag of the operand does not -- identify a specific type that is covered by or descended from the -- target type. -- -- TEST DESCRIPTION: -- View conversions of class-wide operands to specific types are -- placed on the right and left sides of assignment statements, and -- conversions of class-wide operands to class-wide types are used -- as actual parameters to dispatching operations. In all cases, a -- check is made that Constraint_Error is raised if the tag of the -- operand does not identify a specific type covered by or descended -- from the target type, and not raised otherwise. -- -- A specific type is descended from itself and from those types it is -- directly or indirectly derived from. A specific type is covered by -- itself and each class-wide type to whose class it belongs. -- -- A class-wide type T'Class is descended from T and those types which -- T is descended from. A class-wide type is covered by each class-wide -- type to whose class it belongs. -- -- -- CHANGE HISTORY: -- 19 Jul 95 SAIC Initial prerelease version. -- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. -- --! package C460004_0 is type Tag_Type is tagged record C1 : Natural; end record; procedure Proc (X : in out Tag_Type); type DTag_Type is new Tag_Type with record C2 : String (1 .. 5); end record; procedure Proc (X : in out DTag_Type); type DDTag_Type is new DTag_Type with record C3 : String (1 .. 5); end record; procedure Proc (X : in out DDTag_Type); procedure NewProc (X : in DDTag_Type); function CWFunc (X : Tag_Type'Class) return Tag_Type'Class; end C460004_0; --==================================================================-- with Report; package body C460004_0 is procedure Proc (X : in out Tag_Type) is begin X.C1 := 25; end Proc; ----------------------------------------- procedure Proc (X : in out DTag_Type) is begin Proc ( Tag_Type(X) ); X.C2 := "Earth"; end Proc; ----------------------------------------- procedure Proc (X : in out DDTag_Type) is begin Proc ( DTag_Type(X) ); X.C3 := "Orbit"; end Proc; ----------------------------------------- procedure NewProc (X : in DDTag_Type) is Y : DDTag_Type := X; begin Proc (Y); exception when others => Report.Failed ("Unexpected exception in NewProc"); end NewProc; ----------------------------------------- function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is Y : Tag_Type'Class := X; begin Proc (Y); return Y; end CWFunc; end C460004_0; --==================================================================-- with C460004_0; use C460004_0; with Report; procedure C460004 is Tag_Type_Init : constant Tag_Type := (C1 => 0); DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); Tag_Type_Value : constant Tag_Type := (C1 => 25); DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); begin Report.Test ("C460004", "Check that for a view conversion of a " & "class-wide operand, Constraint_Error is raised if the " & "tag of the operand does not identify a specific type " & "covered by or descended from the target type"); -- -- View conversion to specific type: -- declare procedure CW_Proc (P : Tag_Type'Class) is Target : Tag_Type := Tag_Type_Init; begin Target := Tag_Type(P); if (Target /= Tag_Type_Value) then Report.Failed ("Target has wrong value: #01"); end if; exception when Constraint_Error => Report.Failed ("Constraint_Error raised: #01"); when others => Report.Failed ("Unexpected exception: #01"); end CW_Proc; begin CW_Proc (DDTag_Type_Value); end; ---------------------------------------------------------------------- declare Target : DTag_Type := DTag_Type_Init; begin Target := DTag_Type(CWFunc(DDTag_Type_Value)); if (Target /= DTag_Type_Value) then Report.Failed ("Target has wrong value: #02"); end if; exception when Constraint_Error => Report.Failed ("Constraint_Error raised: #02"); when others => Report.Failed ("Unexpected exception: #02"); end; ---------------------------------------------------------------------- declare Target : DDTag_Type; begin Target := DDTag_Type(CWFunc(Tag_Type_Value)); -- CWFunc returns a Tag_Type; its tag is preserved through -- the view conversion. Constraint_Error should be raised. Report.Failed ("Constraint_Error not raised: #03"); exception when Constraint_Error => null; -- expected exception when others => Report.Failed ("Unexpected exception: #03"); end; ---------------------------------------------------------------------- declare procedure CW_Proc (P : Tag_Type'Class) is begin NewProc (DDTag_Type(P)); Report.Failed ("Constraint_Error not raised: #04"); exception when Constraint_Error => null; -- expected exception when others => Report.Failed ("Unexpected exception: #04"); end CW_Proc; begin CW_Proc (DTag_Type_Value); end; ---------------------------------------------------------------------- declare procedure CW_Proc (P : Tag_Type'Class) is Target : DDTag_Type := DDTag_Type_Init; begin Target := DDTag_Type(P); if (Target /= DDTag_Type_Value) then Report.Failed ("Target has wrong value: #05"); end if; exception when Constraint_Error => Report.Failed ("Constraint_Error raised: #05"); when others => Report.Failed ("Unexpected exception: #05"); end CW_Proc; begin CW_Proc (DDTag_Type_Value); end; -- -- View conversion to class-wide type: -- declare procedure CW_Proc (P : Tag_Type'Class) is Operand : Tag_Type'Class := P; begin Proc( DTag_Type'Class(Operand) ); Report.Failed ("Constraint_Error not raised: #06"); exception when Constraint_Error => null; -- expected exception when others => Report.Failed ("Unexpected exception: #06"); end CW_Proc; begin CW_Proc (Tag_Type_Init); end; ---------------------------------------------------------------------- declare procedure CW_Proc (P : Tag_Type'Class) is Operand : Tag_Type'Class := P; begin Proc( DDTag_Type'Class(Operand) ); Report.Failed ("Constraint_Error not raised: #07"); exception when Constraint_Error => null; -- expected exception when others => Report.Failed ("Unexpected exception: #07"); end CW_Proc; begin CW_Proc (Tag_Type_Init); end; ---------------------------------------------------------------------- declare procedure CW_Proc (P : Tag_Type'Class) is Operand : Tag_Type'Class := P; begin Proc( DTag_Type'Class(Operand) ); if Operand not in DTag_Type then Report.Failed ("Operand has wrong tag: #08"); elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then Report.Failed ("Operand has wrong value: #08"); end if; exception when Constraint_Error => Report.Failed ("Constraint_Error raised: #08"); when others => Report.Failed ("Unexpected exception: #08"); end CW_Proc; begin CW_Proc (DTag_Type_Init); end; ---------------------------------------------------------------------- declare procedure CW_Proc (P : Tag_Type'Class) is Operand : Tag_Type'Class := P; begin Proc( Tag_Type'Class(Operand) ); if Operand not in DDTag_Type then Report.Failed ("Operand has wrong tag: #09"); elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then Report.Failed ("Operand has wrong value: #09"); end if; exception when Constraint_Error => Report.Failed ("Constraint_Error raised: #09"); when others => Report.Failed ("Unexpected exception: #09"); end CW_Proc; begin CW_Proc (DDTag_Type_Init); end; Report.Result; end C460004;