Subversion Repositories openrisc_me

-- C330001.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 a variable object of an indefinite type is properly

--      initialized/constrained by an initial value assignment that is

--      a) an aggregate, b) a function, or c) an object.  Check that objects

--      of the above types do not need explicit constraints if they have

--      initial values.

--

-- TEST DESCRIPTION:

--      An indefinite subtype is either:

--         a) An unconstrained array subtype.

--         b) A subtype with unknown discriminants.

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

--

--      Declare several indefinite types in a parent package specification.

--      In the private part, complete one type with a discriminant without

--      default (indefinite) and the other with a default discriminant

--      (definite).  Declare objects of both indefinite and definite subtypes

--      in children (private and public) with initialization expressions.  The

--      test verifies all values of the objects.  It also verifies that

--      Constraint_Error is raised if an attempt is made to change the

--      discriminants of the objects of the indefinite subtypes.

--

--

-- CHANGE HISTORY:

--      15 Jan 95   SAIC    Initial version for ACVC 2.1

--      25 Jul 96   SAIC    Modified test description. Deleted use C330001_0.

--      20 Nov 98   RLB     Added Elaborate pragmas to avoid problems

--                          with an unconventional, but legal, elaboration

--                          order.

--!

package C330001_0 is

   subtype Sub_Type is Integer range 1 .. 20;

   type Tag_W_Disc (D : Sub_Type) is tagged record

       C1 :  String (1 .. D);

   end record;

   -- Indefinite type declarations.

   type FullViewDefinite_Unknown_Disc (<>) is private;

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

   type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged

     record

        C1 : Boolean := False;

     end record;

   type Indefinite_New_W_Disc (ND : Sub_Type) is new

     Indefinite_Tag_W_Disc (ND) with record

        C2 : Integer := 9;

     end record;

   type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with

     record

        S : Sub_Type := 18;

     end record;

   type Indefinite_W_Inherit_Disc_2 is

     new Tag_W_Disc with private;

   function Indef_Func_1 return FullViewDefinite_Unknown_Disc;

   function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2;

private

   type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is

      record

        S : String (1 .. D) := "Hi";

      end record;

   type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with

      record

        S : Sub_Type;

      end record;

end C330001_0;

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

package body C330001_0 is

   function Indef_Func_1 return FullViewDefinite_Unknown_Disc is

      Var_1 : FullViewDefinite_Unknown_Disc;      -- No need for explicit

                                                  -- constraints, use initial

   begin                                          -- values.

      return Var_1;

   end Indef_Func_1;

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

   function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is

      Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P);

   begin

      return Var_2;

   end Indef_Func_2;

end C330001_0;

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

with C330001_0;

pragma Elaborate(C330001_0); -- Insure that the functions can be called.

private

package C330001_0.C330001_1 is

   PrivateChild_Obj    : Tag_W_Disc := (D => 4, C1 => "ACVC");

   PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1

     := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15);

   -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in

   -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization

   -- expression.

   PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19);

   -- Since full view of FullViewDefinite_Unknown_Disc is definite in the

   -- parent package, no initialization expression needed for

   -- PrivateChild_Obj_03.

   PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc;

   PrivateChild_Obj_04 : Indefinite_No_Disc          := (12, 15);

end C330001_0.C330001_1;

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

with C330001_0;

pragma Elaborate(C330001_0); -- Insure that the functions can be called.

package C330001_0.C330001_2 is

   PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1;

   PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2   := Indef_Func_2 (4);

   PublicChild_Obj_03 : Indefinite_No_Disc            := (38, 72, 21, 59);

   PublicChild_Obj_04 : Indefinite_Tag_W_Disc         := (D => 7, C1 => True);

   PublicChild_Obj_05 : Indefinite_Tag_W_Disc         := PublicChild_Obj_04;

   PublicChild_Obj_06 : Indefinite_New_W_Disc (6);

   procedure Assign_Private_Obj_3;

   function Raised_CE_PublicChild_Obj return Boolean;

   function Raised_CE_PrivateChild_Obj return Boolean;

   -- The following functions check the private types defined in the parent

   -- and the private child package from within the client program.

   function Verify_Public_Obj_1 return Boolean;

   function Verify_Public_Obj_2 return Boolean;

   function Verify_Private_Obj_1 return Boolean;

   function Verify_Private_Obj_2 return Boolean;

   function Verify_Private_Obj_3 return Boolean;

end C330001_0.C330001_2;

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

with Report;

with C330001_0.C330001_1;

package body C330001_0.C330001_2 is

   procedure Assign_Private_Obj_3 is

   begin

      C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha");

   end Assign_Private_Obj_3;

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

   function Raised_CE_PublicChild_Obj return Boolean is

   begin

      PublicChild_Obj_03 := (16, 13);       -- C_E, can't change constraints

                                            -- of PublicChild_Obj_03.

      Report.Failed ("Constraint_Error not raised - Public child");

      -- Next line prevents dead assignment.

      Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image

                      (PublicChild_Obj_03'First) );

      return False;

   exception

      when Constraint_Error =>

         return True;                       -- Exception is expected.

      when others           =>

         return False;

   end Raised_CE_PublicChild_Obj;

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

   function Raised_CE_PrivateChild_Obj return Boolean is

   begin

      C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18);

                                            -- C_E, can't change constraints

                                            -- of PrivateChild_Obj_04.

      Report.Failed ("Constraint_Error not raised - Private child");

      -- Next line prevents dead assignment.

      Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image

                      (C330001_0.C330001_1.PrivateChild_Obj_04'Last) );

      return False;

   exception

      when Constraint_Error =>

         return True;                       -- Exception is expected.

      when others           =>

         return False;

   end Raised_CE_PrivateChild_Obj;

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

   function Verify_Public_Obj_1 return Boolean is

   begin

      return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi");

   end Verify_Public_Obj_1;

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

   function Verify_Public_Obj_2 return Boolean is

   begin

      return (PublicChild_Obj_02.D  = 5       and

              PublicChild_Obj_02.C1 = "Hello" and

              PublicChild_Obj_02.S  = 4);

   end Verify_Public_Obj_2;

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

   function Verify_Private_Obj_1 return Boolean is

   begin

      return (C330001_0.C330001_1.PrivateChild_Obj_01.D  = 4      and

              C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and

              C330001_0.C330001_1.PrivateChild_Obj_01.S  = 15);

   end Verify_Private_Obj_1;

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

   function Verify_Private_Obj_2 return Boolean is

   begin

      return (C330001_0.C330001_1.PrivateChild_Obj_02.D  = 5       and

              C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and

              C330001_0.C330001_1.PrivateChild_Obj_02.S  = 19);

   end Verify_Private_Obj_2;

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

   function Verify_Private_Obj_3 return Boolean is

   begin

      return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and

              C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha");

   end Verify_Private_Obj_3;

end C330001_0.C330001_2;

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

with C330001_0.C330001_2;

with Report;

use  C330001_0.C330001_2;

procedure C330001 is

begin

   Report.Test ("C330001", "Check that a variable object of an indefinite " &

                "type is properly initialized/constrained by an initial "   &

                "value assignment that is a) an aggregate, b) a function, " &

                "or c) an object.  Check that objects of the above types "  &

                "do not need explicit constraints if they have initial "    &

                "values");

   -- Verify values of public child objects.

   if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then

      Report.Failed ("Wrong values for PublicChild_Obj_01 or " &

                     "PublicChild_Obj_02");

   end if;

   if PublicChild_Obj_03'First /= 1 or

      PublicChild_Obj_03'Last  /= 4 then

      Report.Failed ("Wrong values for PublicChild_Obj_03");

   end if;

   if PublicChild_Obj_05.D  /= 7 or

      not PublicChild_Obj_05.C1  then

      Report.Failed ("Wrong values for PublicChild_Obj_05");

   end if;

   if PublicChild_Obj_06.ND /= 6 or

      PublicChild_Obj_06.C2 /= 9 or

      PublicChild_Obj_06.C1      then

      Report.Failed ("Wrong values for PublicChild_Obj_06");

   end if;

   -- Definite object can have its discriminant changed by assignment to

   -- the entire object.

   Assign_Private_Obj_3;

   -- Verify values of private child objects.

   if not Verify_Private_Obj_1 or not

          Verify_Private_Obj_2 or not

          Verify_Private_Obj_3 then

      Report.Failed ("Wrong values for PrivateChild_Obj_01 or " &

                     "PrivateChild_Obj_02 or PrivateChild_Obj_03");

   end if;

   -- Attempt to change the discriminants of the objects of the indefinite

   -- subtypes:  Constraint_Error.

   if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then

      Report.Failed ("Constraint_Error not raised");

   end if;

   Report.Result;

end C330001;