c460005.a

来自「linux下编程用 编译软件」· A 代码 · 共 261 行

-- C460005.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 view conversion of a tagged type that is the left 
--      side of an assignment statement, the assignment assigns to the 
--      corresponding part of the object denoted by the operand.
--
-- 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.
--
--      For the cases where the view conversion is the left side of an
--      assignment statement, and Constraint_Error should not be raised,
--      an additional check is made that only the corresponding portion
--      of the operand is updated by the assignment. For example:
--
--         type T is tagged record
--            C1 : Integer := 0;
--         end record;
--
--         type DT is new T with record
--            C2 : Integer := 0;
--         end record;
--
--         A    : T       := (C1 => 5);
--         B    : DT      := (C1 => 0, C2 => 10);
--         CWDT : T'Class := B;
--
--         T(CWDT) := A;  -- Updates component C1; C2 remains unchanged.
--                        -- Value of CWDT is (C1 => 5, C2 => 10).
--
--
-- CHANGE HISTORY:
--      31 Jul 95   SAIC    Initial prerelease version.
--      22 Apr 96   SAIC    ACVC 2.1: Added a check for correct tag.
--      08 Sep 96   SAIC    ACVC 2.1: Modified Report.Test. 
--
--!

package C460005_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);

end C460005_0;


     --==================================================================--


package body C460005_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;

end C460005_0;


     --==================================================================--


with C460005_0;
use  C460005_0;

with Report;
procedure C460005 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");

   Tag_Type_Res     :  constant Tag_Type   := (C1 => 25);
   DTag_Type_Res    :  constant DTag_Type  := (Tag_Type_Res  with "Hello");
   DDTag_Type_Res   :  constant DDTag_Type := (DTag_Type_Res with "World");

begin

   Report.Test ("C460005", "Check that, for a view conversion of a tagged " &
                "type that is the left side of an assignment statement, "   &
                "the assignment assigns to the corresponding part of the "  &
                "object denoted by the operand");


   declare
      procedure CW_Proc (P : Tag_Type'Class) is
         Operand : Tag_Type'Class := P;               
      begin
         Tag_Type(Operand) := Tag_Type_Value;         

         if (Operand /= Tag_Type'Class (Tag_Type_Value)) then
            Report.Failed ("Operand 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 (Tag_Type_Init);
   end;

   ----------------------------------------------------------------------

   declare
      procedure CW_Proc (P : Tag_Type'Class) is
         Operand : Tag_Type'Class := P;               
      begin
         DTag_Type(Operand) := DTag_Type_Value;
         Report.Failed ("Constraint_Error not raised: #02"); 

      exception
         when Constraint_Error => null;              -- expected exception
         when others           => Report.Failed ("Unexpected exception: #02");
      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
         DDTag_Type(Operand) := DDTag_Type_Value;
         Report.Failed ("Constraint_Error not raised: #03"); 

      exception
         when Constraint_Error => null;              -- expected exception
         when others           => Report.Failed ("Unexpected exception: #03");
      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
         Tag_Type(Operand) := Tag_Type_Value;  

         if Operand not in DTag_Type then
            Report.Failed ("Operand has wrong tag: #04");
         elsif (Operand /= Tag_Type'Class (DTag_Type_Res)) 
         then                                              -- Check to make 
           Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was
         end if;                                           -- not modified.

      exception
         when Constraint_Error => 
            Report.Failed ("Constraint_Error raised: #04");
         when others           => 
            Report.Failed ("Unexpected exception: #04");
      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
         Tag_Type(Operand) := Tag_Type_Value;         

         if Operand not in DDTag_Type then
            Report.Failed ("Operand has wrong tag: #05");
         elsif (Operand /= Tag_Type'Class (DDTag_Type_Res)) 
         then                                              -- Check to make 
           Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3
         end if;                                           -- were not changed.

      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_Init);
   end;

   Report.Result;

end C460005;