summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/ca/ca11018.a
blob: a01ebfc32a4e96a9700e2b2d9f0a42e1c2b5c4d1 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
-- 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;