Subversion Repositories openrisc_me

-- C730001.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 the full view of a private extension may be derived

--      indirectly from the ancestor type (i.e., the parent type of the full

--      type may be any descendant of the ancestor type). Check that, for

--      a primitive subprogram of the private extension that is inherited from

--      the ancestor type and not overridden, the formal parameter names and

--      default expressions come from the corresponding primitive subprogram

--      of the ancestor type, while the body comes from that of the parent

--      type.  Check both dispatching and non-dispatching cases.

--

-- TEST DESCRIPTION:

--      Consider:

--

--      package P is

--         type Ancestor is tagged ...

--         procedure Op (P1: Ancestor; P2: Boolean := True);

--      end P;

--

--      with P;

--      package Q is

--         type Derived is new P.Ancestor with ...

--         procedure Op (X: Ancestor; Y: Boolean := False);

--      end Q;

--

--      with P, Q;

--      package R is

--         type Priv_Ext is new P.Ancestor with private;   -- (A)

--         -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);

--         -- But body executed is that of Q.Op.

--      private

--         type Priv_Ext is new Q.Derived with record ...  -- (B)

--      end R;

--

--      The ancestor type in (A) differs from the parent type in (B); the

--      parent of the full type is descended from the ancestor type of the

--      private extension. For a call to Op (from outside the scope of the

--      full view) with an operand of type Priv_Ext, the formal parameter

--      names and default expression come from that of P.Op (the ancestor

--      type's version), but the body executed will be that of

--      Q.Op (the parent type's version)

--

--      One half of the test mirrors the above template, where an inherited

--      subprogram (Set_Display) is called using the formal parameter

--      name (C) and default parameter expression of the ancestor type's

--      version (type Clock), but the version of the body executed is from

--      the parent type.

--

--      The test also includes an examination of the dynamic evaluation

--      case, where correct body associations are required through dispatching

--      calls.  As described for the non-dispatching case above, the formal

--      parameter name and default values of the ancestor type's (Phone)

--      version of the inherited subprogram (Answer) are used in the

--      dispatching call, but the body executed is from the parent type.

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

package C730001_0 is

   type Display_Kind      is (None, Analog, Digital);

   type Illumination_Type is (None, Light, Phosphorescence);

   type Capability_Type   is (Available, In_Use, Call_Waiting, Conference);

   type Indicator_Type    is (None, Light, Bell, Buzzer, Click, Modem);

   type Clock is abstract tagged record           -- ancestor type associated

      Display      : Display_Kind      := None;   -- with non-dispatching case.

      Illumination : Illumination_Type := None;

   end record;

   type Phone is tagged record                    -- ancestor type associated

      Status    : Capability_Type := Available;   -- with dispatching case.

      Indicator : Indicator_Type  := None;

   end record;

   -- The Set_Display procedure for type Clock implements a basic, no-frills

   -- clock display.

   procedure Set_Display (C   : in out Clock;

                          Disp: in     Display_Kind := Digital);

   -- The Answer procedure for type Phone implements a phone status change

   -- operation.

   procedure Answer (The_Phone : in out Phone;

                     Ind       : in     Indicator_Type := Light);

   -- ...Other general clock and/or phone operations (not specified in this

   -- test scenario).

end C730001_0;

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

package body C730001_0 is

   procedure Set_Display (C   : in out Clock;

                          Disp: in     Display_Kind := Digital) is

   begin

      C.Display      := Disp;

      C.Illumination := Light;

   end Set_Display;

   procedure Answer (The_Phone : in out Phone;

                     Ind       : in     Indicator_Type := Light) is

   begin

      The_Phone.Status    := In_Use;

      The_Phone.Indicator := Ind;

   end Answer;

end C730001_0;

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

with C730001_0; use C730001_0;

package C730001_1 is

   type Power_Supply_Type is (Spring, Battery, AC_Current);

   type Speaker_Type      is (None, Present, Adjustable, Stereo);

   type Wall_Clock is new Clock with record

      Power_Source : Power_Supply_Type := Spring;

   end record;

   type Office_Phone is new Phone with record

      Speaker : Speaker_Type := Present;

   end record;

   -- Note: Both procedures below, parameter names and defaults differ from

   --       parent's version.

   -- The Set_Display procedure for type Wall_Clock improves upon the

   -- basic Set_Display procedure of type Clock.

   procedure Set_Display (WC: in out Wall_Clock;

                          D : in     Display_Kind := Analog);

   procedure Answer (OP : in out Office_Phone;

                     OI : in     Indicator_Type := Buzzer);

   -- ...Other wall clock and/or Office_Phone operations (not specified in

   -- this test scenario).

end C730001_1;

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

package body C730001_1 is

   -- Note: This body is the one that should be executed in the test block

   --       below, not the version of the body corresponding to type Clock.

   procedure Set_Display (WC: in out Wall_Clock;

                          D : in     Display_Kind := Analog) is

   begin

      WC.Display      := D;

      WC.Illumination := Phosphorescence;

   end Set_Display;

   procedure Answer (OP : in out Office_Phone;

                     OI : in     Indicator_Type := Buzzer) is

   begin

      OP.Status    := Call_Waiting;

      OP.Indicator := OI;

   end Answer;

end C730001_1;

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

with C730001_0; use C730001_0;

with C730001_1; use C730001_1;

package C730001_2 is

   type Alarm_Type  is (Buzzer, Radio, Both);

   type Video_Type  is (None, TV_Monitor, Wall_Projection);

   type Alarm_Clock is new Clock with private;

   -- Inherits proc Set_Display (C   : in out Clock;

   --                            Disp: in     Display_Kind := Digital); -- (A)

   --

   -- Would also inherit other general clock operations (if present).

   type Conference_Room_Phone is new Office_Phone with record

      Display : Video_Type := TV_Monitor;

   end record;

   procedure Answer (CP : in out Conference_Room_Phone;

                     CI : in     Indicator_Type := Modem);

   function TC_Get_Display              (C: Alarm_Clock) return Display_Kind;

   function TC_Get_Display_Illumination (C: Alarm_Clock)

     return Illumination_Type;

private

   -- ...however, certain of the wall clock's operations (Set_Display, in

   -- this example) improve on the implementations provided for the general

   -- clock. We want to call the improved implementations, so we

   -- derive from Wall_Clock in the private part.

   type Alarm_Clock is new Wall_Clock with record

      Alarm : Alarm_Type := Buzzer;

   end record;

   -- Inherits proc Set_Display (WC: in out Wall_Clock;

   --                            D : in     Display_Kind := Analog);    -- (B)

   -- The implicit Set_Display at (B) overrides the implicit Set_Display at

   -- (A), but only within the scope of the full view.

   --

   -- Outside the scope of the full view, only (A) is visible, so calls

   -- from outside the scope will get the formal parameter names and default

   -- from (A). Both inside and outside the scope, however, the body executed

   -- will be that corresponding to Set_Display of the parent type.

end C730001_2;

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

package body C730001_2 is

   procedure Answer (CP : in out Conference_Room_Phone;

                     CI : in     Indicator_Type := Modem)is

   begin

      CP.Status    := Conference;

      CP.Indicator := CI;

   end Answer;

   function TC_Get_Display (C: Alarm_Clock) return Display_Kind is

   begin

      return C.Display;

   end TC_Get_Display;

   function TC_Get_Display_Illumination (C: Alarm_Clock)

     return Illumination_Type is

   begin

      return C.Illumination;

   end TC_Get_Display_Illumination;

end C730001_2;

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

with C730001_0; use C730001_0;

with C730001_1; use C730001_1;

with C730001_2; use C730001_2;

package C730001_3 is

   -- Types extended from the ancestor (Phone) type in the specification.

   type Secure_Phone_Type     is new Phone with private;

   type Auditorium_Phone_Type is new Phone with private;

   -- Inherit versions of Answer from ancestor (Phone).

   function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type;

   function TC_Get_Indicator    (P : Phone'Class) return Indicator_Type;

private

   -- Types extended from descendents of Phone_Type in the private part.

   type Secure_Phone_Type is new Office_Phone with record

      Scrambled_Communication : Boolean := True;

   end record;

   type Auditorium_Phone_Type is new Conference_Room_Phone with record

      Volume_Control : Boolean := True;

   end record;

end C730001_3;

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

package body C730001_3 is

   function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is

   begin

      return P.Status;

   end TC_Get_Phone_Status;

   function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is

   begin

      return P.Indicator;

   end TC_Get_Indicator;

end C730001_3;

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

with C730001_0; use C730001_0;

with C730001_1; use C730001_1;

with C730001_2; use C730001_2;

with C730001_3; use C730001_3;

with Report;

procedure C730001 is

begin

   Report.Test ("C730001","Check that the full view of a private extension " &

                          "may be derived indirectly from the ancestor "     &

                          "type. Check that, for a primitive subprogram "    &

                          "of the private extension that is inherited from " &

                          "the ancestor type and not overridden, the "       &

                          "formal parameter names and default expressions "  &

                          "come from the corresponding primitive "           &

                          "subprogram of the ancestor type, while the body " &

                          "comes from that of the parent type");

   Test_Block:

   declare

      Alarm                : Alarm_Clock;

      Hot_Line             : Secure_Phone_Type;

      TeleConference_Phone : Auditorium_Phone_Type;

   begin

   -- Evaluate non-dispatching case:

      -- Call Set_Display using formal parameter name from

      -- C730001_0.Set_Display.

      -- Give no 2nd parameter so that default expression must be used.

      Set_Display (C => Alarm);

      -- The value of the Display component should equal Digital, which is

      -- the default value from the ancestor's version of Set_Display,

      -- and not the default value from the parent's version of Set_Display.

      if TC_Get_Display (Alarm) /= Digital then

         Report.Failed ("Default expression for ancestor op not used " &

                        "in non-dispatching case");

      end if;

      -- However, the value of the Illumination component should equal

      -- Phosphorescence, which is assigned in the parent type's version of

      -- the body of Set_Display.

      if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then

         Report.Failed ("Wrong body was executed in non-dispatching case");

      end if;

   -- Evaluate dispatching case:

      declare

         Hot_Line             : Secure_Phone_Type;

         TeleConference_Phone : Auditorium_Phone_Type;

         procedure Answer_The_Phone (P : in out Phone'Class) is

         begin

            -- Give no 2nd parameter so that default expression must be used.

            Answer (P);

         end Answer_The_Phone;

      begin

         Answer_The_Phone (Hot_Line);

         Answer_The_Phone (TeleConference_Phone);

         -- The value of the Indicator field shold equal "Light", the default

         -- value from the ancestor's version of Answer, and not the default

         -- from either of the parent versions of Answer.

         if TC_Get_Indicator(Hot_Line)             /= Light   or

            TC_Get_Indicator(TeleConference_Phone) /= Light

         then

            Report.Failed("Default expression from ancestor operation " &

                          "not used in dispatching case");

         end if;

         -- However, the value of the Status component should equal

         -- Call_Waiting or Conference respectively, based on the assignment

         -- in the parent type's version of the body of Answer.

         if TC_Get_Phone_Status(Hot_Line)  /=  Call_Waiting then

            Report.Failed("Wrong body executed in dispatching case - 1");

         end if;

         if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then

            Report.Failed("Wrong body executed in dispatching case - 2");

         end if;

      end;

   exception

      when others => Report.Failed ("Exception raised in Test_Block");

   end Test_Block;

   Report.Result;

end C730001;