Subversion Repositories openrisc

-- C330002.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 a subtype indication of a variable object defines an

--      indefinite subtype, then there is an initialization expression.

--      Check that the object remains so constrained throughout its lifetime.

--      Check for cases of tagged record, arrays and generic formal type.

--

-- TEST DESCRIPTION:

--      An indefinite subtype is either:

--         a) An unconstrained array subtype.

--         b) A subtype with unknown discriminants (this includes class-wide

--            types).

--         c) A subtype with unconstrained discriminants without defaults.

--

--      Declare tagged types with unconstrained discriminants without

--      defaults.  Declare an unconstrained array.  Declare a generic formal

--      type with an unknown discriminant and a formal object of this type.

--      In the generic package, declare an object of the formal type using

--      the formal object as its initial value.  In the main program,

--      declare objects of tagged types.  Instantiate the generic package.

--      The test checks that Constraint_Error is raised if an attempt is

--      made to change bounds as well as discriminants of the objects of the

--      indefinite subtypes.

--

--

-- CHANGE HISTORY:

--      01 Nov 95   SAIC    Initial prerelease version.

--      27 Jul 96   SAIC    Modified test description & Report.Test.  Added

--                          code to prevent dead variable optimization.

--

--!

package C330002_0 is

   subtype Small_Num is Integer range 1 .. 20;

   -- Types with unconstrained discriminants without defaults.

   type Tag_Type (Disc : Small_Num) is tagged

     record

       S : String (1 .. Disc);

     end record;

   function  Tag_Value return Tag_Type;

   procedure Assign_Tag (A : out Tag_Type);

   procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String);

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

   -- An unconstrained array type.

   type Array_Type is array (Positive range <>) of Integer;

   function  Array_Value return Array_Type;

   procedure Assign_Array (A : out Array_Type);

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

   generic

      -- Type with an unknown discriminant.

      type Formal_Type (<>) is private;

      FT_Obj  : Formal_Type;

   package Gen is

      Gen_Obj : Formal_Type := FT_Obj;

   end Gen;

end C330002_0;

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

with Report;

package body C330002_0 is

   procedure Assign_Tag (A : out Tag_Type) is

   begin

      A := (3, "Bye");

   end Assign_Tag;

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

   procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is

      Default : Tag_Type := (1, "!"); -- Unique value.

   begin

      if P = Default then       -- Both If branches can't do the same thing.

         Report.Failed  (Msg & ": Constraint_Error not raised");

      else                      -- Subtests should always select this path.

         Report.Failed ("Constraint_Error not raised " & Msg);

      end if;

   end Avoid_Optimization_and_Fail;

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

   function  Tag_Value return Tag_Type is

      TO : Tag_Type := (4 , "ACVC");

   begin

      return TO;

   end Tag_Value;

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

   function  Array_Value return Array_Type is

      IA : Array_Type := (20, 31);

   begin

      return IA;

   end Array_Value;

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

   procedure Assign_Array (A : out Array_Type) is

   begin

      A := (84, 36);

   end Assign_Array;

end C330002_0;

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

with Report;

with C330002_0;

use  C330002_0;

procedure C330002 is

begin

   Report.Test ("C330002", "Check that if a subtype indication of a "      &

                "variable object defines an indefinite subtype, then "     &

                "there is an initialization expression.  Check that "      &

                "the object remains so constrained throughout its "        &

                "lifetime.  Check that Constraint_Error is raised "        &

                "if an attempt is made to change bounds as well as "       &

                "discriminants of the objects of the indefinite "          &

                "subtypes.  Check for cases of tagged record and generic " &

                "formal types");

   TagObj_Block:

   declare

      TObj_ByAgg  : Tag_Type := (5, "Hello");    -- Initial assignment is

                                                 -- aggregate.

      TObj_ByObj  : Tag_Type := TObj_ByAgg;      -- Initial assignment is

                                                 -- an object.

      TObj_ByFunc : Tag_Type := Tag_Value;       -- Initial assignment is

                                                 -- function return value.

      Ren_Obj     : Tag_Type renames TObj_ByAgg;

   begin

      begin

         if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then

            Report.Failed ("Wrong initial values for TObj_ByAgg");

         end if;

         TObj_ByAgg := (2, "Hi");                -- C_E, can't change the

                                                 -- value of the discriminant.

         Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1");

      exception

         when Constraint_Error => null;          -- Exception is expected.

         when others           =>

            Report.Failed ("Unexpected exception - Subtest 1");

      end;

      begin

         Assign_Tag (Ren_Obj);                   -- C_E, can't change the

                                                 -- value of the discriminant.

         Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2");

      exception

         when Constraint_Error => null;          -- Exception is expected.

         when others           =>

            Report.Failed ("Unexpected exception - Subtest 2");

      end;

      begin

         if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then

            Report.Failed ("Wrong initial values for TObj_ByObj");

         end if;

         TObj_ByObj := (3, "Bye");               -- C_E, can't change the

                                                 -- value of the discriminant.

         Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3");

      exception

         when Constraint_Error => null;          -- Exception is expected.

         when others           =>

            Report.Failed ("Unexpected exception - Subtest 3");

      end;

      begin

         if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then

            Report.Failed ("Wrong initial values for TObj_ByFunc");

         end if;

         TObj_ByFunc := (5, "Aloha");            -- C_E, can't change the

                                                 -- value of the discriminant.

         Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4");

      exception

         when Constraint_Error => null;          -- Exception is expected.

         when others           =>

            Report.Failed ("Unexpected exception - Subtest 4");

      end;

   end TagObj_Block;

   ArrObj_Block:

   declare

      Arr_Const   :  constant Array_Type

                  := (9, 7, 6, 8);

      Arr_ByAgg   :  Array_Type                  -- Initial assignment is

                  := (10, 11, 12);               -- aggregate.

      Arr_ByFunc  :  Array_Type                  -- Initial assignment is

                  := Array_Value;                -- function return value.

      Arr_ByObj   :  Array_Type                  -- Initial assignment is

                  := Arr_ByAgg;                  -- object.

      Arr_Obj     :  array (Positive range <>) of Integer

                  := (1, 2, 3, 4, 5);

    begin

      begin

         if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then

            Report.Failed ("Wrong bounds for Arr_Const");

         end if;

         if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then

            Report.Failed ("Wrong bounds for Arr_ByAgg");

         end if;

         if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then

            Report.Failed ("Wrong bounds for Arr_ByFunc");

         end if;

         if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then

            Report.Failed ("Wrong bounds for Arr_ByObj");

         end if;

         Assign_Array (Arr_ByObj);               -- C_E, Arr_ByObj bounds are

                                                 -- 1..3.

         Report.Failed ("Constraint_Error not raised - Subtest 5");

      exception

            when Constraint_Error => null;        -- Exception is expected.

            when others           =>

               Report.Failed ("Unexpected exception - Subtest 5");

      end;

      begin

         if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then

            Report.Failed ("Wrong bounds for Arr_Obj");

         end if;

         for I in 0 .. 5 loop

            Arr_Obj (I + 1) := I + 5;             -- C_E, Arr_Obj bounds are

         end loop;                                -- 1..5.

         Report.Failed ("Constraint_Error not raised - Subtest 6");

      exception

            when Constraint_Error => null;        -- Exception is expected.

            when others           =>

               Report.Failed ("Unexpected exception - Subtest 6");

      end;

   end ArrObj_Block;

   GenericObj_Block:

   declare

      type Rec (Disc : Small_Num) is

        record

           S : Small_Num := Disc;

        end record;

      Rec_Obj : Rec := (2, 2);

      package IGen is new Gen (Rec, Rec_Obj);

   begin

      IGen.Gen_Obj := (3, 3);                    -- C_E, can't change the

                                                 -- value of the discriminant.

      Report.Failed ("Constraint_Error not raised - Subtest 7");

      -- Next line prevents dead assignment.

      Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc));

   exception

      when Constraint_Error => null;             -- Exception is expected.

      when others           =>

         Report.Failed ("Unexpected exception - Subtest 7");

   end GenericObj_Block;

   Report.Result;

end C330002;