path: root/gcc/testsuite/ada/acats/tests/ca/ca11018.a

-- CA11018.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 body of the parent package may depend on one of its own 
--      public generic children.
--
-- TEST DESCRIPTION:
--      A scenario is created that demonstrates the potential of adding a
--      public generic child during code maintenance without distubing a large 
--      subsystem.  After child is added to the subsystem, a maintainer
--      decides to take advantage of the new functionality and rewrites
--      the parent's body.
--
--      Declare a message application in a package which highlights some
--      key words.  Declare a public generic child of this package which adds 
--      functionality to the original subsystem.  In the parent body, 
--      instantiate the child.
--
--      In the main program, check that the operations in the parent, 
--      and instances of the public child package perform as expected.  
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      14 Dec 94   SAIC    Modified Copy_Particularly_Designated_Pkg inst.
--      17 Nov 95   SAIC    Update and repair for ACVC 2.0.1
--
--!
  
-- Simulates application which displays messages.

package CA11018_0 is               

   type Designated_Num is new Integer range 0 .. 100;

   type Particularly_Designated_Num is new Integer range 0 .. 100;

   type Message is new String;

   type Message_Rec is tagged private;

   type Designated_Msg is new Message_Rec with private;

   type Particularly_Designated_Msg is new Message_Rec with private;

   -- Analyzes message for presence of word in the secret message. If found, 
   -- word is highlighted.

   procedure Highlight_Designated (The_Word       : in     Message;
                                   In_The_Message : in out Designated_Msg);
                               

   -- Analyzes message for presence of word in the secret message. If found, 
   -- word is highlighted and do other actions.

   procedure Highlight_Particularly_Designated 
     (The_Word       : in     Message;
      In_The_Message : in out Particularly_Designated_Msg);
 

   -- Begin test code declarations: -----------------------

   TC_Designated_Not_Zero : Boolean := false;

   TC_Particularly_Designated_Not_Zero : Boolean := false;

   -- The following two functions are used to check for function
   -- calls from the public generic child.

   function TC_Designated_Success return Boolean;

   function TC_Particularly_Designated_Success return Boolean;

   -- End test code declarations. -------------------------

private
   type Message_Rec is tagged
      record
         The_Length  : natural := 0;
         The_Content : Message (1 .. 60);
      end record;

   type Designated_Msg is new Message_Rec with null record;
   -- ... More components in real application.

   type Particularly_Designated_Msg is new Message_Rec with null record;
   -- ... More components in real application.

end CA11018_0;

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


-- Public generic child package of message display application.  Imagine that 
-- messages of one security level are associated with a type derived from 
-- integer.  For overall system security, messages of a different security
-- level are associated with a different type derived from integer.  By 
-- instantiating this package for each security level, the results of Count 
-- applied to one kind of message cannot inadvertently be compared with the 
-- results applied to a different kind.

generic
   type Msg_Type is new Message_Rec with private; 
                                              -- Derived from parent's type.
   type Count is range <>;

package CA11018_0.CA11018_1 is    

   TC_Function_Called : Boolean := false;

   function Find_Word (Wrd : in Message;
                       Msg : in Msg_Type) return Count;

end CA11018_0.CA11018_1;

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

package body CA11018_0.CA11018_1 is    

   function Find_Word (Wrd : in Message;
                       Msg : in Msg_Type) return Count is

      Num  : Count   := Count'first;

   -- Count how many time the word appears within the given message.

   begin
      -- ... Error-checking code omitted for brevity.

      for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop
                                                 -- Parent's private type
         if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd
                                                 -- Parent's private type
           then
              Num := Num + 1;
         end if;

      end loop;

      TC_Function_Called := true;

      return (Num);

   end Find_Word;

end CA11018_0.CA11018_1;

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

with CA11018_0.CA11018_1;   -- Public generic child.

pragma Elaborate (CA11018_0.CA11018_1);
package body CA11018_0 is

   ----------------------------------------------------
   -- Parent's body depends on public generic child. --
   ----------------------------------------------------

   -- Instantiate the public child for the secret message.

   package Designated_Pkg is new CA11018_0.CA11018_1 
     (Msg_Type => Designated_Msg, Count => Designated_Num);

   -- Instantiate the public child for the top secret message.

   package Particularly_Designated_Pkg is new CA11018_0.CA11018_1 
     (Particularly_Designated_Msg, Particularly_Designated_Num);

   -- End instantiations. -----------------------------

   
   function TC_Designated_Success return Boolean is
   -- Check to see if the function in the public generic child is called.

   begin
      return Designated_Pkg.TC_Function_Called;
   end TC_Designated_Success;
   --------------------------------------------------------------
   function TC_Particularly_Designated_Success return Boolean is
   -- Check to see if the function in the public generic child is called.

   begin
      return Particularly_Designated_Pkg.TC_Function_Called;
   end TC_Particularly_Designated_Success;
   --------------------------------------------------------------
   -- Calls functions from public child to search for a key word.  
   -- If the word appears more than once in each message, 
   -- highlight all of them.

   procedure Highlight_Designated (The_Word       : in     Message;
                                   In_The_Message : in out Designated_Msg) is

   -- Not a real highlight procedure.  Real application can use graphic
   -- device to highlight all occurrences of words.

   begin
      --------------------------------------------------------------
      -- Parent's body uses function from instantiation of public --
      -- generic child.                                           --
      --------------------------------------------------------------

      if Designated_Pkg.Find_Word          -- Child's operation.   
        (The_Word, In_The_Message) > 0 then

          -- Highlight all occurrences in lavender.

          TC_Designated_Not_Zero := true;       
      end if;

   end Highlight_Designated;
   --------------------------------------------------------------
   procedure Highlight_Particularly_Designated 
     (The_Word       : in     Message;
      In_The_Message : in out Particularly_Designated_Msg) is

   -- Not a real highlight procedure.  Real application can use graphic
   -- device to highlight all occurrences of words.

   begin
      --------------------------------------------------------------
      -- Parent's body uses function from instantiation of public --
      -- generic child.                                           --
      --------------------------------------------------------------

      if Particularly_Designated_Pkg.Find_Word     -- Child's operation.   
        (The_Word, In_The_Message) > 0 then

          -- Highlight all occurrences in chartreuse.
          -- Do other more secret stuff.

          TC_Particularly_Designated_Not_Zero := true;       
      end if;

   end Highlight_Particularly_Designated;

end CA11018_0;

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

-- Public generic child to copy words to the messages.

generic
   type Message_Type is new Message_Rec with private; 
                        -- Derived from parent's type.

package CA11018_0.CA11018_2 is    

   procedure Copy (From_The_Word  : in     Message;
                   To_The_Message : in out Message_Type);

end CA11018_0.CA11018_2;

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

package body CA11018_0.CA11018_2 is    

   procedure Copy (From_The_Word  : in     Message;
                   To_The_Message : in out Message_Type) is

   -- Copy words to the appropriate messages.

   begin
      To_The_Message.The_Content        -- Parent's private type.
        (1 .. From_The_Word'length) := From_The_Word;

      To_The_Message.The_Length         -- Parent's private type.
                                    := From_The_Word'length;
   end Copy;

end CA11018_0.CA11018_2;

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

with Report;

with CA11018_0.CA11018_2;   -- Public generic child package, copy words
                            -- to the message.
                            -- Implicit with parent package (CA11018_0).

procedure CA11018 is

   package Message_Pkg renames CA11018_0;

begin

   Report.Test ("CA11018", "Check that body of the parent package can " &
                "depend on one of its own public generic children");

-- Highlight the word "Alert" from the secret message.
 
       Designated_Subtest:
       declare
          The_Message : Message_Pkg.Designated_Msg;  -- Parent's private type.

          -- Instantiate the public child to copy words to the secret message.

          package Copy_Designated_Pkg is new CA11018_0.CA11018_2 
            (Message_Pkg.Designated_Msg);

       begin
          Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard", 
                                To_The_Message => The_Message);

          Message_Pkg.Highlight_Designated ("Alert", The_Message);

          if not Message_Pkg.TC_Designated_Not_Zero and 
            Message_Pkg.TC_Designated_Success then
               Report.Failed ("Alert should have been highlighted");
          end if;

       end Designated_Subtest;

-- Highlight the word "Push The Alarm" from the top secret message.

       Particularly_Designated_Subtest:
       declare
          The_Message : Message_Pkg.Particularly_Designated_Msg ;  
                                         -- Parent's private type.

          -- Instantiate the public child to copy words to the top secret
          -- message.

          package Copy_Particularly_Designated_Pkg is new 
            CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg);

       begin
          Copy_Particularly_Designated_Pkg.Copy 
            ("Alert Level 10 : Alert The Guard and Push The Alarm", 
             The_Message);

          Message_Pkg.Highlight_Particularly_Designated 
            ("Push The Alarm", The_Message);

          if not Message_Pkg.TC_Particularly_Designated_Not_Zero and 
            Message_Pkg.TC_Particularly_Designated_Success then
               Report.Failed ("Key words should have been highlighted");
          end if;

       end Particularly_Designated_Subtest;

   Report.Result;

end CA11018;