summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/ca/ca13001.a
blob: 094bd7a88e0a2a5a49d4880c1c24f3c0ed21adf6 (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
367
368
369
370
-- CA13001.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 a separate protected unit declared in a non-generic child 
--      unit of a private parent have the same visibility into its parent, 
--      its siblings, and packages on which its parent depends as is available 
--      at the point of their declaration.
--
-- TEST DESCRIPTION:
--      A scenario is created that demonstrates the potential of having all
--      members of one family to take out a transportation.  The restriction
--      is depend on each member to determine who can get a car, a clunker, 
--      or a bicycle.  If no transportation is available, that member has to
--      walk.  
--      
--      Declare a package with location for each family member.  Declare
--      a public parent package.  Declare a private child package. Declare a 
--      public grandchild of this private package.  Declare a protected unit 
--      as a subunit in a public grandchild package.  This subunit has 
--      visibility into it's parent body ancestor and its sibling.
--
--      Declare another public parent package.  The body of this package has
--      visibility into its private sibling's descendants.
--
--      In the main program, "with"s the parent package.  Check that the
--      protected subunit performs as expected.  
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      16 Nov 95   SAIC    Update and repair for ACVC 2.0.1
--
--!

package CA13001_0 is                    

   type Location is (School, Work, Beach, Home);
   type Family is (Father, Mother, Teen);
   Destination : array (Family) of Location;

   -- Other type definitions and procedure declarations in real application.

end CA13001_0;

-- No bodies required for CA13001_0.

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

-- Public parent.

package CA13001_1 is                     

   type Transportation is (Bicycle, Clunker, New_Car);
   type Key_Type is private;
   Walking : boolean := false;

   -- Other type definitions and procedure declarations in real application.

private
   type Key_Type 
     is range Transportation'pos(Bicycle) .. Transportation'pos(New_Car);

end CA13001_1;

-- No bodies required for CA13001_1.

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

-- Private child. 

private package CA13001_1.CA13001_2 is       

   type Transport is
      record
         In_Use : boolean := false;
      end record;
   Vehicles : array (Transportation) of Transport;

   -- Other type definitions and procedure declarations in real application.

end CA13001_1.CA13001_2;

-- No bodies required for CA13001_1.CA13001_2.

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

-- Public grandchild of a private parent.

package CA13001_1.CA13001_2.CA13001_3 is

   Flat_Tire : array (Transportation) of boolean := (others => false);

   -- Other type definitions and procedure declarations in real application.

end CA13001_1.CA13001_2.CA13001_3;

-- No bodies required for CA13001_1.CA13001_2.CA13001_3.

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

-- Context clauses required for visibility needed by a separate subunit.

with CA13001_0;                           
use  CA13001_0;

-- Public grandchild of a private parent.

package CA13001_1.CA13001_2.CA13001_4 is

   type Transit is
      record
         Available : boolean := false;
      end record;
   type Keys_Array is array (Transportation) of Transit;
   Fuel : array (Transportation) of boolean := (others => true);

   protected Family_Transportation is

      procedure Get_Vehicle (Who : in     Family;
                             Key :    out Key_Type);
      procedure Return_Vehicle (Tr : in Transportation);
      function TC_Verify (What : Transportation) return boolean;

   private
      Keys : Keys_Array;

   end Family_Transportation;

end CA13001_1.CA13001_2.CA13001_4;

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

-- Context clause required for visibility needed by a separate subunit.

with CA13001_1.CA13001_2.CA13001_3;    -- Public sibling.

package body CA13001_1.CA13001_2.CA13001_4 is

   protected body Family_Transportation is separate;

end CA13001_1.CA13001_2.CA13001_4;

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

separate (CA13001_1.CA13001_2.CA13001_4)
protected body Family_Transportation is

   procedure Get_Vehicle (Who : in     Family;
                          Key :    out Key_Type) is
   begin
      case Who is
         when Father|Mother => 
            -- Drive new car to work

            -- Reference package with'ed by the subunit parent's body.
            if Destination(Who) = Work then

               -- Reference type declared in the private parent of the subunit
               -- parent's body.
               -- Reference type declared in the visible part of the 
               -- subunit parent's body.
               if not Vehicles(New_Car).In_Use and Fuel(New_Car) 

                 -- Reference type declared in the public sibling of the 
                 -- subunit parent's body.
                 and not CA13001_1.CA13001_2.CA13001_3.Flat_Tire(New_Car) then
                    Vehicles(New_Car).In_Use := true;

                    -- Reference type declared in the private part of the 
                    -- protected subunit.
                    Keys(New_Car).Available := false;
                    Key                     := Transportation'pos(New_Car);
               else
                 -- Reference type declared in the grandparent of the subunit
                 -- parent's body.
                 Walking := true;
               end if;

            -- Drive clunker to other destinations.
            else
               if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not 
                 CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
                    Vehicles(Clunker).In_Use := true;
                    Keys(Clunker).Available  := false;
                    Key                      := Transportation'pos(Clunker);
               else
                 Walking := true;
                 Key     := Transportation'pos(Bicycle);
               end if;
            end if;
    
         -- Similar for Teen.
         when Teen => 
            if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not 
              CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then
                 Vehicles(Clunker).In_Use := true;
                 Keys(Clunker).Available  := false;
                 Key                      := Transportation'pos(Clunker);
            else
               Walking := true;
               Key     := Transportation'pos(Bicycle);
            end if;
      end case;

   end Get_Vehicle;

   ----------------------------------------------------------------

   -- Any family member can bring back the transportation with the key.

   procedure Return_Vehicle (Tr : in Transportation) is
   begin
      Vehicles(Tr).In_Use := false;
      Keys(Tr).Available  := true;
   end Return_Vehicle;

   ----------------------------------------------------------------

   function TC_Verify (What : Transportation) return boolean is
   begin
      return Keys(What).Available;
   end TC_Verify;
   
end Family_Transportation;

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

with CA13001_0;
use  CA13001_0;

-- Public child.

package CA13001_1.CA13001_5 is

   -- In a real application, tasks could be used to demonstrate 
   -- a family transportation scenario, i.e., each member of
   -- a family can take a vehicle out concurrently, then return
   -- them at the same time. For the purposes of the test, family
   -- transportation happens sequentially.

   procedure Provide_Transportation (Who     : in     Family;
                                     Get_Key :    out Key_Type;
                                     Get_Veh :    out boolean);
   procedure Return_Transportation (What   : in     Transportation;
                                    Rt_Veh :    out boolean);

end CA13001_1.CA13001_5;

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

with CA13001_1.CA13001_2.CA13001_4;   -- Public grandchild of a private parent,
                                      -- implicitly with CA13001_1.CA13001_2.
package body CA13001_1.CA13001_5 is

   package Transportation_Pkg renames CA13001_1.CA13001_2.CA13001_4;
   use Transportation_Pkg;

   -- These two validation subprograms provide the capability to check the 
   -- components defined in the private packages from within the client 
   -- program.

   procedure Provide_Transportation (Who     : in     Family;
                                     Get_Key :    out Key_Type;
                                     Get_Veh :    out boolean) is
   begin
      -- Goto work, school, or to the beach.
      Family_Transportation.Get_Vehicle (Who, Get_Key);
      if not Family_Transportation.TC_Verify 
        (Transportation'Val(Get_Key)) then
           Get_Veh := true;
      else
         Get_Veh := false;
      end if;

   end Provide_Transportation;

   ----------------------------------------------------------------

   procedure Return_Transportation (What   : in     Transportation;
                                    Rt_Veh :    out boolean) is
   begin
      Family_Transportation.Return_Vehicle (What);
      if Family_Transportation.TC_Verify(What) and 
        not CA13001_1.CA13001_2.Vehicles(What).In_Use then
           Rt_Veh := true;
      else
         Rt_Veh := false;
      end if;

   end Return_Transportation;

end CA13001_1.CA13001_5;

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

with CA13001_0;
with CA13001_1.CA13001_5;        -- Implicitly with parent, CA13001_1.
with Report;

procedure CA13001 is

   Mommy           : CA13001_0.Family := CA13001_0.Mother;
   Daddy           : CA13001_0.Family := CA13001_0.Father;
   BG              : CA13001_0.Family := CA13001_0.Teen;
   BG_Clunker      : CA13001_1.Transportation := CA13001_1.Clunker;
   Get_Key         : CA13001_1.Key_Type;
   Get_Transit     : boolean := false;
   Return_Transit  : boolean := false;

begin 
   Report.Test ("CA13001", "Check that a protected subunit declared in " & 
                "a child unit of a private parent have the same visibility " &
                "into its parent, its parent's siblings, and packages on " &
                "which its parent depends");

   -- Get transportation for mother to go to work.
   CA13001_0.Destination(CA13001_0.Mother) := CA13001_0.Work;
   CA13001_1.CA13001_5.Provide_Transportation (Mommy, Get_Key, Get_Transit);
   if not Get_Transit then
      Report.Failed ("Failed to get mother transportation");
   end if;

   -- Get transportation for teen to go to school.
   CA13001_0.Destination(CA13001_0.Teen) := CA13001_0.School;
   Get_Transit := false;
   CA13001_1.CA13001_5.Provide_Transportation (BG, Get_Key, Get_Transit);
   if not Get_Transit then
      Report.Failed ("Failed to get teen transportation");
   end if;

   -- Get transportation for father to go to the beach.
   CA13001_0.Destination(CA13001_0.Father) := CA13001_0.Beach;
   Get_Transit := false;
   CA13001_1.CA13001_5.Provide_Transportation (Daddy, Get_Key, Get_Transit);
   if Get_Transit and not CA13001_1.Walking then
      Report.Failed ("Failed to make daddy to walk to the beach");
   end if;

   -- Return the clunker.
   CA13001_1.CA13001_5.Return_Transportation (BG_Clunker, Return_Transit);
   if not Return_Transit then
      Report.Failed ("Failed to get back the clunker");
   end if;

   Report.Result;

end CA13001;