Subversion Repositories openrisc

-- C540001.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 an expression in a case statement may be of a generic formal

--      type.  Check that a function call may be used as a case statement

--      expression.  Check that a call to a generic formal function may be

--      used as a case statement expression.  Check that a call to an inherited

--      function may be used as a case statement expression even if its result

--      type does not correspond to any nameable subtype.

--

-- TEST DESCRIPTION:

--      This transition test creates examples where expressions in a case

--      statement can be a generic formal object and a call to a generic formal

--      function.  This test also creates examples when either a function call,

--      a renaming of a function, or a call to an inherited function is used

--      in the case expressions, the choices of the case statement only need

--      to cover the values in the result of the function.

--

--      Inspired by B54A08A.ADA.

--

--

-- CHANGE HISTORY:

--      12 Feb 96   SAIC    Initial version for ACVC 2.1.

--

--!

package C540001_0 is

   type Int is range 1 .. 2;

end C540001_0;

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

with C540001_0;

package C540001_1 is

   type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3.

   type Mixed     is ('A','B', 'C', None);

   subtype Small_Num is Natural range 0 .. 10;

   type Small_Int is range 1 .. 2;

   function Get_Small_Int (P : Boolean) return Small_Int;

   procedure Assign_Mixed (P1 : in     Boolean;

                           P2 :    out Mixed);

   type Tagged_Type is tagged

     record

        C1 : Enum_Type;

     end record;

   function Get_Tagged (P : Tagged_Type) return C540001_0.Int;

end C540001_1;

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

package body C540001_1 is

   function Get_Small_Int (P : Boolean) return Small_Int is

   begin

      if P then

         return Small_Int'First;

      else

         return Small_Int'Last;

      end if;

   end Get_Small_Int;

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

   procedure Assign_Mixed (P1 : in     Boolean;

                           P2 :    out Mixed) is

   begin

      case Get_Small_Int (P1) is          -- Function call as expression

           when 1  => P2 := None;         -- in case statement.

           when 2  => P2 := 'A';

           -- No others needed.

      end case;

   end Assign_Mixed;

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

   function Get_Tagged (P : Tagged_Type) return C540001_0.Int is

   begin

      return C540001_0.Int'Last;

   end Get_Tagged;

end C540001_1;

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

generic

   type Formal_Scalar is range <>;

   FSO : Formal_Scalar;

package C540001_2 is

   type Enum is (Alpha, Beta, Theta);

   procedure Assign_Enum (ET : out Enum);

end C540001_2;

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

package body C540001_2 is

   procedure Assign_Enum (ET : out Enum) is

   begin

      case FSO is                         -- Type of expression in case

           when 1      => ET := Alpha;    -- statement is generic formal type.

           when 2      => ET := Beta;

           when others => ET := Theta;

      end case;

   end Assign_Enum;

end C540001_2;

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

with C540001_1;

generic

   type Formal_Enum_Type is new C540001_1.Enum_Type;

   with function Formal_Func (P : C540001_1.Small_Num)

     return Formal_Enum_Type is <>;

function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type;

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

function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is

begin

   return Formal_Func (P);

end C540001_3;

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

with C540001_1;

generic

   type Formal_Int_Type is new C540001_1.Small_Int;

   with function Formal_Func return Formal_Int_Type;

package C540001_4 is

   procedure Gen_Assign_Mixed (P : out C540001_1.Mixed);

end C540001_4;

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

package body C540001_4 is

   procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is

   begin

      case Formal_Func is                          -- Case expression is

         when 1      => P := C540001_1.'A';        -- generic function.

         when others => P := C540001_1.'B';

      end case;

   end Gen_Assign_Mixed;

end C540001_4;

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

with C540001_1;

package C540001_5 is

   type New_Tagged is new C540001_1.Tagged_Type with

      record

         C2 : C540001_1.Mixed;

      end record;

    -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int;

    -- Note that the return type of the inherited function is not

    -- nameable here.

   procedure Assign_Tagged (P1 : in     New_Tagged;

                            P2 :    out New_Tagged);

end C540001_5;

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

package body C540001_5 is

   procedure Assign_Tagged (P1 : in     New_Tagged;

                            P2 :    out New_Tagged) is

   begin

      case Get_Tagged (P1) is                      -- Case expression is

                                                   -- inherited function.

         when 2      => P2 := (C540001_1.Bee, 'B');

         when others => P2 := (C540001_1.Sea, C540001_1.None);

      end case;

   end Assign_Tagged;

end C540001_5;

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

with Report;

with C540001_1;

with C540001_2;

with C540001_3;

with C540001_4;

with C540001_5;

procedure C540001 is

   type Value is range 1 .. 5;

begin

   Report.Test ("C540001", "Check that an expression in a case statement " &

                "may be of a generic formal type.  Check that a function " &

                "call may be used as a case statement expression.  Check " &

                "that a call to a generic formal function may be used as " &

                "a case statement expression.  Check that a call to an "   &

                "inherited function may be used as a case statement "      &

                "expression");

   Generic_Formal_Object_Subtest:

   begin

      declare

         One  : Value := 1;

         package One_Pck is new C540001_2 (Value, One);

         use One_Pck;

         EObj : Enum;

      begin

         Assign_Enum (EObj);

         if EObj /= Alpha then

            Report.Failed ("Incorrect result for value of one in generic" &

                           "formal object subtest");

         end if;

      end;

      declare

         Five : Value := 5;

         package Five_Pck is new C540001_2 (Value, Five);

         use Five_Pck;

         EObj : Enum;

      begin

         Assign_Enum (EObj);

         if EObj /= Theta then

            Report.Failed ("Incorrect result for value of five in generic" &

                           "formal object subtest");

         end if;

      end;

   end Generic_Formal_Object_Subtest;

   Instantiated_Generic_Function_Subtest:

   declare

      type New_Enum_Type is new C540001_1.Enum_Type;

      function Get_Enum_Value (P : C540001_1.Small_Num)

        return New_Enum_Type is

      begin

         return New_Enum_Type'Val (P);

      end Get_Enum_Value;

      function Val_Func is new C540001_3

        (Formal_Enum_Type => New_Enum_Type,

         Formal_Func      => Get_Enum_Value);

      procedure Assign_Num (P : in out C540001_1.Small_Num) is

      begin

         case Val_Func (P) is                         -- Case expression is

                                                      -- instantiated generic

             when New_Enum_Type (C540001_1.Eh) |      -- function.

                  New_Enum_Type (C540001_1.Sea)   => P := 4;

             when New_Enum_Type (C540001_1.Bee)   => P := 7;

             when others                          => P := 9;

         end case;

      end Assign_Num;

      SNObj  : C540001_1.Small_Num;

   begin

      SNObj := 0;

      Assign_Num (SNObj);

      if SNObj /= 4 then

         Report.Failed ("Incorrect result for value of zero in call to " &

                        "generic function subtest");

      end if;

      SNObj := 3;

      Assign_Num (SNObj);

      if SNObj /= 9 then

         Report.Failed ("Incorrect result for value of three in call to " &

                        "generic function subtest");

      end if;

   end Instantiated_Generic_Function_Subtest;

   -- When a function call, a renaming of a function, or a call to an

   -- inherited function is used in the case expressions, the choices

   -- of the case statement only need to cover the values in the result

   -- of the function.

   Function_Call_Subtest:

   declare

      MObj : C540001_1.Mixed := 'B';

      BObj : Boolean         := True;

      use type C540001_1.Mixed;

   begin

      C540001_1.Assign_Mixed (BObj, MObj);

      if MObj /= C540001_1.None then

         Report.Failed ("Incorrect result for value of true in function" &

                        "call subtest");

         end if;

      BObj := False;

      C540001_1.Assign_Mixed (BObj, MObj);

      if MObj /= C540001_1.'A' then

         Report.Failed ("Incorrect result for value of false in function" &

                        "call subtest");

      end if;

   end Function_Call_Subtest;

   Function_Renaming_Subtest:

   declare

      use C540001_1;

      function Rename_Get_Small_Int (P : Boolean)

        return Small_Int renames Get_Small_Int;

      MObj : Mixed   := None;

      BObj : Boolean := False;

   begin

      case Rename_Get_Small_Int (BObj) is

          when 1 => MObj := 'A';

          when 2 => MObj := 'B';

          -- No others needed.

      end case;

      if MObj /= 'B' then

         Report.Failed ("Incorrect result for value of false in function" &

                        "renaming subtest");

      end if;

   end Function_Renaming_Subtest;

   Call_To_Generic_Formal_Function_Subtest:

   declare

      type New_Small_Int is new C540001_1.Small_Int;

      function Get_Int_Value return New_Small_Int is

      begin

         return New_Small_Int'First;

      end Get_Int_Value;

      package Int_Pck is new C540001_4

        (Formal_Int_Type => New_Small_Int,

         Formal_Func     => Get_Int_Value);

      use type C540001_1.Mixed;

      MObj : C540001_1.Mixed := C540001_1.None;

   begin

      Int_Pck.Gen_Assign_Mixed (MObj);

      if MObj /= C540001_1.'A' then

         Report.Failed ("Incorrect result in call to generic formal " &

                        "function subtest");

      end if;

   end Call_To_Generic_Formal_Function_Subtest;

   Call_To_Inherited_Function_Subtest:

   declare

      NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh,

                                        C2 => C540001_1.'A');

      NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C');

      use type C540001_1.Mixed;

      use type C540001_1.Enum_Type;

   begin

      C540001_5.Assign_Tagged (NTObj1, NTObj2);

      if NTObj2.C1 /= C540001_1.Bee or

         NTObj2.C2 /= C540001_1.'B' then

         Report.Failed ("Incorrect result in inherited function subtest");

      end if;

   end Call_To_Inherited_Function_Subtest;

   Report.Result;

end C540001;