gcc/testsuite/ada/acats/tests/ca/ca11018.a

   1 -- CA11018.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that body of the parent package may depend on one of its own
  28 --      public generic children.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      A scenario is created that demonstrates the potential of adding a
  32 --      public generic child during code maintenance without distubing a large
  33 --      subsystem.  After child is added to the subsystem, a maintainer
  34 --      decides to take advantage of the new functionality and rewrites
  35 --      the parent's body.
  36 --
  37 --      Declare a message application in a package which highlights some
  38 --      key words.  Declare a public generic child of this package which adds
  39 --      functionality to the original subsystem.  In the parent body,
  40 --      instantiate the child.
  41 --
  42 --      In the main program, check that the operations in the parent,
  43 --      and instances of the public child package perform as expected.
  44 --
  45 --
  46 -- CHANGE HISTORY:
  47 --      06 Dec 94   SAIC    ACVC 2.0
  48 --      14 Dec 94   SAIC    Modified Copy_Particularly_Designated_Pkg inst.
  49 --      17 Nov 95   SAIC    Update and repair for ACVC 2.0.1
  50 --
  51 --!
  52
  53 -- Simulates application which displays messages.
  54
  55 package CA11018_0 is
  56
  57    type Designated_Num is new Integer range 0 .. 100;
  58
  59    type Particularly_Designated_Num is new Integer range 0 .. 100;
  60
  61    type Message is new String;
  62
  63    type Message_Rec is tagged private;
  64
  65    type Designated_Msg is new Message_Rec with private;
  66
  67    type Particularly_Designated_Msg is new Message_Rec with private;
  68
  69    -- Analyzes message for presence of word in the secret message. If found,
  70    -- word is highlighted.
  71
  72    procedure Highlight_Designated (The_Word       : in     Message;
  73                                    In_The_Message : in out Designated_Msg);
  74
  75
  76    -- Analyzes message for presence of word in the secret message. If found,
  77    -- word is highlighted and do other actions.
  78
  79    procedure Highlight_Particularly_Designated
  80      (The_Word       : in     Message;
  81       In_The_Message : in out Particularly_Designated_Msg);
  82
  83
  84    -- Begin test code declarations: -----------------------
  85
  86    TC_Designated_Not_Zero : Boolean := false;
  87
  88    TC_Particularly_Designated_Not_Zero : Boolean := false;
  89
  90    -- The following two functions are used to check for function
  91    -- calls from the public generic child.
  92
  93    function TC_Designated_Success return Boolean;
  94
  95    function TC_Particularly_Designated_Success return Boolean;
  96
  97    -- End test code declarations. -------------------------
  98
  99 private
 100    type Message_Rec is tagged
 101       record
 102          The_Length  : natural := 0;
 103          The_Content : Message (1 .. 60);
 104       end record;
 105
 106    type Designated_Msg is new Message_Rec with null record;
 107    -- ... More components in real application.
 108
 109    type Particularly_Designated_Msg is new Message_Rec with null record;
 110    -- ... More components in real application.
 111
 112 end CA11018_0;
 113
 114      --=================================================================--
 115
 116
 117 -- Public generic child package of message display application.  Imagine that
 118 -- messages of one security level are associated with a type derived from
 119 -- integer.  For overall system security, messages of a different security
 120 -- level are associated with a different type derived from integer.  By
 121 -- instantiating this package for each security level, the results of Count
 122 -- applied to one kind of message cannot inadvertently be compared with the
 123 -- results applied to a different kind.
 124
 125 generic
 126    type Msg_Type is new Message_Rec with private;
 127                                               -- Derived from parent's type.
 128    type Count is range <>;
 129
 130 package CA11018_0.CA11018_1 is
 131
 132    TC_Function_Called : Boolean := false;
 133
 134    function Find_Word (Wrd : in Message;
 135                        Msg : in Msg_Type) return Count;
 136
 137 end CA11018_0.CA11018_1;
 138
 139      --=================================================================--
 140
 141 package body CA11018_0.CA11018_1 is
 142
 143    function Find_Word (Wrd : in Message;
 144                        Msg : in Msg_Type) return Count is
 145
 146       Num  : Count   := Count'first;
 147
 148    -- Count how many time the word appears within the given message.
 149
 150    begin
 151       -- ... Error-checking code omitted for brevity.
 152
 153       for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop
 154                                                  -- Parent's private type
 155          if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd
 156                                                  -- Parent's private type
 157            then
 158               Num := Num + 1;
 159          end if;
 160
 161       end loop;
 162
 163       TC_Function_Called := true;
 164
 165       return (Num);
 166
 167    end Find_Word;
 168
 169 end CA11018_0.CA11018_1;
 170
 171      --=================================================================--
 172
 173 with CA11018_0.CA11018_1;   -- Public generic child.
 174
 175 pragma Elaborate (CA11018_0.CA11018_1);
 176 package body CA11018_0 is
 177
 178    ----------------------------------------------------
 179    -- Parent's body depends on public generic child. --
 180    ----------------------------------------------------
 181
 182    -- Instantiate the public child for the secret message.
 183
 184    package Designated_Pkg is new CA11018_0.CA11018_1
 185      (Msg_Type => Designated_Msg, Count => Designated_Num);
 186
 187    -- Instantiate the public child for the top secret message.
 188
 189    package Particularly_Designated_Pkg is new CA11018_0.CA11018_1
 190      (Particularly_Designated_Msg, Particularly_Designated_Num);
 191
 192    -- End instantiations. -----------------------------
 193
 194
 195    function TC_Designated_Success return Boolean is
 196    -- Check to see if the function in the public generic child is called.
 197
 198    begin
 199       return Designated_Pkg.TC_Function_Called;
 200    end TC_Designated_Success;
 201    --------------------------------------------------------------
 202    function TC_Particularly_Designated_Success return Boolean is
 203    -- Check to see if the function in the public generic child is called.
 204
 205    begin
 206       return Particularly_Designated_Pkg.TC_Function_Called;
 207    end TC_Particularly_Designated_Success;
 208    --------------------------------------------------------------
 209    -- Calls functions from public child to search for a key word.
 210    -- If the word appears more than once in each message,
 211    -- highlight all of them.
 212
 213    procedure Highlight_Designated (The_Word       : in     Message;
 214                                    In_The_Message : in out Designated_Msg) is
 215
 216    -- Not a real highlight procedure.  Real application can use graphic
 217    -- device to highlight all occurrences of words.
 218
 219    begin
 220       --------------------------------------------------------------
 221       -- Parent's body uses function from instantiation of public --
 222       -- generic child.                                           --
 223       --------------------------------------------------------------
 224
 225       if Designated_Pkg.Find_Word          -- Child's operation.
 226         (The_Word, In_The_Message) > 0 then
 227
 228           -- Highlight all occurrences in lavender.
 229
 230           TC_Designated_Not_Zero := true;
 231       end if;
 232
 233    end Highlight_Designated;
 234    --------------------------------------------------------------
 235    procedure Highlight_Particularly_Designated
 236      (The_Word       : in     Message;
 237       In_The_Message : in out Particularly_Designated_Msg) is
 238
 239    -- Not a real highlight procedure.  Real application can use graphic
 240    -- device to highlight all occurrences of words.
 241
 242    begin
 243       --------------------------------------------------------------
 244       -- Parent's body uses function from instantiation of public --
 245       -- generic child.                                           --
 246       --------------------------------------------------------------
 247
 248       if Particularly_Designated_Pkg.Find_Word     -- Child's operation.
 249         (The_Word, In_The_Message) > 0 then
 250
 251           -- Highlight all occurrences in chartreuse.
 252           -- Do other more secret stuff.
 253
 254           TC_Particularly_Designated_Not_Zero := true;
 255       end if;
 256
 257    end Highlight_Particularly_Designated;
 258
 259 end CA11018_0;
 260
 261      --=================================================================--
 262
 263 -- Public generic child to copy words to the messages.
 264
 265 generic
 266    type Message_Type is new Message_Rec with private;
 267                         -- Derived from parent's type.
 268
 269 package CA11018_0.CA11018_2 is
 270
 271    procedure Copy (From_The_Word  : in     Message;
 272                    To_The_Message : in out Message_Type);
 273
 274 end CA11018_0.CA11018_2;
 275
 276      --=================================================================--
 277
 278 package body CA11018_0.CA11018_2 is
 279
 280    procedure Copy (From_The_Word  : in     Message;
 281                    To_The_Message : in out Message_Type) is
 282
 283    -- Copy words to the appropriate messages.
 284
 285    begin
 286       To_The_Message.The_Content        -- Parent's private type.
 287         (1 .. From_The_Word'length) := From_The_Word;
 288
 289       To_The_Message.The_Length         -- Parent's private type.
 290                                     := From_The_Word'length;
 291    end Copy;
 292
 293 end CA11018_0.CA11018_2;
 294
 295      --=================================================================--
 296
 297 with Report;
 298
 299 with CA11018_0.CA11018_2;   -- Public generic child package, copy words
 300                             -- to the message.
 301                             -- Implicit with parent package (CA11018_0).
 302
 303 procedure CA11018 is
 304
 305    package Message_Pkg renames CA11018_0;
 306
 307 begin
 308
 309    Report.Test ("CA11018", "Check that body of the parent package can " &
 310                 "depend on one of its own public generic children");
 311
 312 -- Highlight the word "Alert" from the secret message.
 313
 314        Designated_Subtest:
 315        declare
 316           The_Message : Message_Pkg.Designated_Msg;  -- Parent's private type.
 317
 318           -- Instantiate the public child to copy words to the secret message.
 319
 320           package Copy_Designated_Pkg is new CA11018_0.CA11018_2
 321             (Message_Pkg.Designated_Msg);
 322
 323        begin
 324           Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard",
 325                                 To_The_Message => The_Message);
 326
 327           Message_Pkg.Highlight_Designated ("Alert", The_Message);
 328
 329           if not Message_Pkg.TC_Designated_Not_Zero and
 330             Message_Pkg.TC_Designated_Success then
 331                Report.Failed ("Alert should have been highlighted");
 332           end if;
 333
 334        end Designated_Subtest;
 335
 336 -- Highlight the word "Push The Alarm" from the top secret message.
 337
 338        Particularly_Designated_Subtest:
 339        declare
 340           The_Message : Message_Pkg.Particularly_Designated_Msg ;
 341                                          -- Parent's private type.
 342
 343           -- Instantiate the public child to copy words to the top secret
 344           -- message.
 345
 346           package Copy_Particularly_Designated_Pkg is new
 347             CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg);
 348
 349        begin
 350           Copy_Particularly_Designated_Pkg.Copy
 351             ("Alert Level 10 : Alert The Guard and Push The Alarm",
 352              The_Message);
 353
 354           Message_Pkg.Highlight_Particularly_Designated
 355             ("Push The Alarm", The_Message);
 356
 357           if not Message_Pkg.TC_Particularly_Designated_Not_Zero and
 358             Message_Pkg.TC_Particularly_Designated_Success then
 359                Report.Failed ("Key words should have been highlighted");
 360           end if;
 361
 362        end Particularly_Designated_Subtest;
 363
 364    Report.Result;
 365
 366 end CA11018;