summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c7/c730004.a
blob: c2a23230ad2e29afd7948c380dae5ca054c1545f (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
-- C730004.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 for a type declared in a package, descendants of the package
--      use the full view of type.  Specifically check that full view of the
--      limited type is visible only in private descendants (children) and in
--      the private parts and bodies of public descendants (children).
--      Check that a limited type may be used as an out parameter outside
--      the package that defines the type.
--
-- TEST DESCRIPTION:
--      This test defines a parent package containing limited private type 
--      definitions. Children packages are defined (one public, one private) 
--      that use the nonlimited full view of the types defined in the private 
--      part of the parent specification.
--      The main declares a procedure with an out parameter that was defined
--      as limited in the specification of the parent package.
--
--
-- CHANGE HISTORY:
--      15 Sep 95   SAIC    Initial prerelease version.
--      23 Apr 96   SAIC    Added prefix for parameter in Call_Modify_File.
--      02 Nov 96   SAIC    ACVC 2.1: Modified prologue and Test.Report. 
--
--!

package C730004_0 is 

   -- Full views of File_Descriptor, File_Mode, File_Name, and File_Type are
   -- are nonlimited.

   type File_Descriptor is limited private;

   type File_Mode is limited private;

   Active_Mode  : constant File_Mode;

   type File_Name is limited private;

   type File_Type is limited private;

   function Next_Available_File return File_Descriptor;

private

   type File_Descriptor is new Integer;

   Null_File    : constant File_Descriptor := 0;
   First_File   : constant File_Descriptor := 1;

   type File_Mode is 
     (Read_Only, Write_Only, Read_Write, Archived, Corrupt, Lost);

   Default_Mode : constant File_Mode       := Read_Only;
   Active_Mode  : constant File_Mode       := Read_Write;

   type File_Name is array (1 .. 6) of Character;

   Null_String : File_Name := "      ";
   String1     : File_Name := "ACVC  ";
   String2     : File_Name := "  1995";

   type File_Type is 
     record
        Descriptor : File_Descriptor := Null_File;
        Mode       : File_Mode       := Default_Mode;
        Name       : File_Name       := Null_String;
     end record;

end C730004_0;       

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

package body C730004_0 is     

   File_Count : Integer := 0;

   function Next_Available_File return File_Descriptor is
   begin
      File_Count := File_Count + 1;
      return (File_Descriptor(File_Count));    -- Type conversion.
   end Next_Available_File;

end C730004_0;     

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

private
package C730004_0.C730004_1 is                             -- private child

   -- Since full view of the nontagged File_Name is nonlimited in the parent 
   -- package, it is not limited in the private child, so concatenation is 
   -- available.

   System_File_Name :  constant File_Name
                    := String1(1..4) & String2(5..6);

   -- Since full view of the nontagged File_Type is nonlimited in the parent 
   -- package, it is not limited in the private child, so a default expression
   -- is available.

   function New_File_Validated (File :  File_Type 
                                     := (Descriptor => First_File,
                                         Mode       => Active_Mode,
                                         Name       => System_File_Name))
     return Boolean;

   -- Since full view of the nontagged File_Type is nonlimited in the parent 
   -- package, it is not limited in the private child, so initialization
   -- expression in an object declaration is available.

   System_File      :  File_Type 
                    := (Null_File, Read_Only, System_File_Name);


end C730004_0.C730004_1;    

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

package body C730004_0.C730004_1 is 

   function New_File_Validated (File :  File_Type 
                                     := (Descriptor => First_File,
                                         Mode       => Active_Mode,
                                         Name       => System_File_Name))
     return Boolean is                                   
      Result : Boolean := False;                         
   begin                                                 
      if (File.Descriptor > System_File.Descriptor) and  
         (File.Mode in Read_Only .. Read_Write) and (File.Name = "ACVC95")
      then
         Result := True;
      end if;

      return (Result);

   end New_File_Validated;

end C730004_0.C730004_1;       

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

package C730004_0.C730004_2 is                   -- public child

   -- File_Type is limited here.

   procedure Create_File (File : out File_Type);    
                          
   procedure Modify_File (File : out File_Type);

   type File_Dir is limited private;

   -- The following three validation functions provide the capability to 
   -- check the limited private types defined in the parent and the
   -- private child package from within the client program.
                                   
   function  Validate_Create (File : in File_Type) return Boolean;

   function  Validate_Modification (File : in File_Type) 
     return Boolean;

   function  Validate_Dir (Dir : in File_Dir) return Boolean;

private

   -- Since full view of the nontagged File_Type is nonlimited in the parent 
   -- package, it is not limited in the private part of the public child, so 
   -- aggregates are available.

   Child_File :  File_Type 
              := File_Type'(Descriptor => Null_File, 
                            Mode       => Write_Only,
                            Name       => String2);
                     
   -- Since full view of the nontagged component File_Type is nonlimited in 
   -- the parent package, it is not limited in the private part of the public 
   -- child, so default expressions are available.

   type File_Dir is 
     record
        Comp : File_Type := Child_File;
     end record;

end C730004_0.C730004_2;             

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

with C730004_0.C730004_1;

package body C730004_0.C730004_2 is  

   procedure Create_File (File : out File_Type) is
      New_File : File_Type;

   begin
      New_File.Descriptor := Next_Available_File;       
      New_File.Mode       := Default_Mode;
      New_File.Name       := C730004_0.C730004_1.System_File_Name;

      if C730004_0.C730004_1.New_File_Validated (New_File) then
         File := New_File;
      else 
         File := (Null_File, Lost, "MISSED");
      end if;

   end Create_File;

   --------------------------------------------------------------
   procedure Modify_File (File : out File_Type) is
   begin
      File.Descriptor := Next_Available_File;      
      File.Mode       := Active_Mode;
      File.Name       := String1;
   end Modify_File;     

   --------------------------------------------------------------
   function  Validate_Create (File : in File_Type) return Boolean is
   begin
      if ((File.Descriptor /= Child_File.Descriptor) and
          (File.Mode = Read_Only) and (File.Name = "ACVC95"))
      then
         return True;
      else
         return False;
      end if;
   end Validate_Create;
  
   ------------------------------------------------------------------------
   function  Validate_Modification (File : in File_Type) 
      return Boolean is      
   begin
      if ((File.Descriptor /= C730004_0.C730004_1.System_File.Descriptor) and 
          (File.Mode = Read_Write) and (File.Name = "ACVC  "))
      then
         return True;
      else
         return False;
      end if;
   end Validate_Modification;

   ------------------------------------------------------------------------
   function  Validate_Dir (Dir : in File_Dir) return Boolean is      
   begin
      if ((Dir.Comp.Descriptor = C730004_0.C730004_1.System_File.Descriptor) 
        and (Dir.Comp.Mode = Write_Only) and (Dir.Comp.Name = String2))
      then
         return True;
      else
         return False;
      end if;
   end Validate_Dir;

end C730004_0.C730004_2;

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

with C730004_0.C730004_2; 
with Report;

procedure C730004 is

   package File      renames C730004_0;
   package File_Ops  renames C730004_0.C730004_2;            

   Validation_File : File.File_Type;     

   Validation_Dir  : File_Ops.File_Dir;

   ------------------------------------------------------------------------ 
   -- Limited File_Type is allowed as an out parameter outside package File.

   procedure Call_Modify_File (Modified_File : out File.File_Type) is
   begin
      File_Ops.Modify_File (Modified_File);
   end Call_Modify_File;     
  
begin

   Report.Test ("C730004", "Check that for a type declared in a package, "   &
                           "descendants of the package use the full view "   &
                           "of the type.  Specifically check that full "     &
                           "view of the limited type is visible only in "    &
                           "private children and in the private parts and "  &
                           "bodies of public children");

   File_Ops.Create_File (Validation_File);

   if not File_Ops.Validate_Create (Validation_File) then
      Report.Failed ("Incorrect creation of file");
   end if;

   Call_Modify_File (Validation_File);

   if not File_Ops.Validate_Modification (Validation_File) then 
      Report.Failed ("Incorrect modification of file");
   end if;

   if not File_Ops.Validate_Dir (Validation_Dir) then
      Report.Failed ("Incorrect creation of directory");
   end if;

   Report.Result;

end C730004;