path: root/gcc/testsuite/ada/acats/tests/c7/c730001.a

-- 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;