Mercurial > hg > CbC > CbC_gcc
comparison gcc/testsuite/ada/acats/tests/ca/ca11009.a @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 -- CA11009.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 a private child package can use entities declared in the | |
28 -- visible part of the parent unit of its parent unit. | |
29 -- | |
30 -- TEST DESCRIPTION: | |
31 -- Declare a parent package containing types and objects used by the | |
32 -- system. Declare a public child package that provides a visible | |
33 -- interface to the system functionality. | |
34 -- Declare a private grandchild package that uses the visible grandparent | |
35 -- components to provide the actual functionality to the system. | |
36 -- | |
37 -- The public child (parent of the private grandchild) uses the | |
38 -- functionality of its private child (grandchild package) to provide | |
39 -- the visible interface to operations of the system. | |
40 -- | |
41 -- The test itself will utilize the visible interface provided in the | |
42 -- public child package to demonstrate a possible structure for | |
43 -- file management. | |
44 -- | |
45 -- | |
46 -- CHANGE HISTORY: | |
47 -- 06 Dec 94 SAIC ACVC 2.0 | |
48 -- 15 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate_body. | |
49 -- | |
50 --! | |
51 | |
52 package CA11009_0 is -- Package OS. | |
53 pragma Elaborate_Body (CA11009_0); | |
54 | |
55 type File_Descriptor_Type is new Integer; | |
56 type File_Name_Type is new String (1 .. 11); | |
57 type Permission_Type is (None, User, System, Bypass); | |
58 type File_Mode_Type is (Read_Only, Write_Only, Read_Write); | |
59 type File_Status_Type is (Open, Closed); | |
60 | |
61 Default_Descriptor : constant File_Descriptor_Type := 0; | |
62 Default_Permission : constant Permission_Type := None; | |
63 Default_Mode : constant File_Mode_Type := Read_Only; | |
64 Default_Status : constant File_Status_Type := Closed; | |
65 Default_Filename : constant File_Name_Type := " "; | |
66 | |
67 Max_Files : constant File_Descriptor_Type := 10; | |
68 An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; | |
69 File_Counter : Integer := 0; | |
70 | |
71 type File_Type is tagged | |
72 record | |
73 Descriptor : File_Descriptor_Type := Default_Descriptor; | |
74 Name : File_Name_Type := Default_Filename; | |
75 Acct_Access : Permission_Type := Default_Permission; | |
76 Mode : File_Mode_Type := Default_Mode; | |
77 Current_Status : File_Status_Type := Default_Status; | |
78 end record; | |
79 | |
80 type File_Array_Type is array (1 .. Max_Files) of File_Type; | |
81 | |
82 File_Table : File_Array_Type; | |
83 | |
84 -- | |
85 | |
86 function Get_File_Name return File_Name_Type; | |
87 | |
88 end CA11009_0; -- Package OS. | |
89 | |
90 --=================================================================-- | |
91 | |
92 package body CA11009_0 is -- Package body OS. | |
93 | |
94 function Get_File_Name return File_Name_Type is | |
95 begin | |
96 return (An_Ada_File_Name); -- Processing would be replace by a user | |
97 -- prompt in a functioning system. | |
98 end Get_File_Name; | |
99 | |
100 end CA11009_0; -- Package body OS. | |
101 | |
102 --=================================================================-- | |
103 | |
104 package CA11009_0.CA11009_1 is -- Child Package OS.File_Manager | |
105 | |
106 -- This package simulates a visible interface for the Operating System. | |
107 -- The actual processing performed by this routine is encapsulated | |
108 -- in the routines of private child package Internals, which is "withed" | |
109 -- by the body of this package. | |
110 | |
111 procedure Create_File (Mode : in File_Mode_Type; | |
112 File_Key : out File_Descriptor_Type); | |
113 | |
114 end CA11009_0.CA11009_1; -- Child Package OS.File_Manager | |
115 | |
116 --=================================================================-- | |
117 | |
118 -- Subprogram that performs the actual file operation is contained in a | |
119 -- private package so that it is not accessible to any client, and can be | |
120 -- modified/extended without requiring recompilation of the clients of the | |
121 -- parent (since this package is "withed" by the parent body only.) | |
122 | |
123 | |
124 -- Grandchild Package OS.File_Manager.Internals | |
125 private package CA11009_0.CA11009_1.CA11009_2 is | |
126 | |
127 Initial_Permission : constant Permission_Type := User; -- Grandparent | |
128 Initial_Status : constant File_Status_Type := Open; -- literals. | |
129 Initial_Filename : constant File_Name_Type := -- Grandparent type. | |
130 Get_File_Name; -- Grandparent function. | |
131 | |
132 function Create (Mode : File_Mode_Type) | |
133 return File_Descriptor_Type; -- Grandparent type. | |
134 | |
135 end CA11009_0.CA11009_1.CA11009_2; | |
136 -- Grandchild Package OS.File_Manager.Internals | |
137 | |
138 --=================================================================-- | |
139 | |
140 -- Grandchild Package body OS.File_Manager.Internals | |
141 package body CA11009_0.CA11009_1.CA11009_2 is | |
142 | |
143 function Next_Available_File return File_Descriptor_Type is | |
144 begin | |
145 File_Counter := File_Counter + 1; -- Grandparent object. | |
146 return (File_Descriptor_Type(File_Counter)); | |
147 end Next_Available_File; | |
148 ------------------------------------------------------------------------- | |
149 function Create (Mode : File_Mode_Type) -- Grandparent literal. | |
150 return File_Descriptor_Type is | |
151 Number : File_Descriptor_Type; -- Grandparent type. | |
152 begin | |
153 Number := Next_Available_File; | |
154 File_Table(Number).Descriptor := Number; -- Grandparent object. | |
155 File_Table(Number).Name := Initial_Filename; | |
156 File_Table(Number).Mode := Mode; -- Parameter. | |
157 File_Table(Number).Acct_Access := Initial_Permission; | |
158 File_Table(Number).Current_Status := Initial_Status; | |
159 return (Number); | |
160 end Create; | |
161 | |
162 end CA11009_0.CA11009_1.CA11009_2; | |
163 -- Grandchild Package body OS.File_Manager.Internals | |
164 | |
165 --=================================================================-- | |
166 | |
167 -- "With" of a child package | |
168 -- by the parent body. | |
169 with CA11009_0.CA11009_1.CA11009_2; -- Grandchild OS.File_Manager.Internals | |
170 | |
171 package body CA11009_0.CA11009_1 is -- Child Package body OS.File_Manager | |
172 | |
173 package Internal renames CA11009_0.CA11009_1.CA11009_2; | |
174 | |
175 -- These subprograms utilize calls to subprograms contained in a private | |
176 -- sibling to perform the actual processing. | |
177 | |
178 procedure Create_File (Mode : in File_Mode_Type; | |
179 File_Key : out File_Descriptor_Type) is | |
180 begin | |
181 File_Key := Internal.Create (Mode); | |
182 end Create_File; | |
183 | |
184 end CA11009_0.CA11009_1; -- Child Package body OS.File_Manager | |
185 | |
186 --=================================================================-- | |
187 | |
188 with CA11009_0.CA11009_1; -- with Child Package OS.File_Manager | |
189 with Report; | |
190 | |
191 procedure CA11009 is | |
192 | |
193 package OS renames CA11009_0; | |
194 use OS; | |
195 package File_Manager renames CA11009_0.CA11009_1; | |
196 | |
197 Data_Base_File_Key : File_Descriptor_Type := Default_Descriptor; | |
198 New_Mode : File_Mode_Type := Read_Write; | |
199 | |
200 begin | |
201 | |
202 -- This test indicates one approach to file management. | |
203 -- It is not intended to demonstrate full functionality, but rather | |
204 -- that the use of a private child package could provide a solution | |
205 -- to this type of situation. | |
206 | |
207 Report.Test ("CA11009", "Check that a private child package can use " & | |
208 "entities declared in the visible part of the " & | |
209 "parent unit of its parent unit"); | |
210 | |
211 -- Check initial conditions of the first entry in the file table. | |
212 -- These are all default values provided in the declaration of the | |
213 -- type File_Type. | |
214 | |
215 if (not (Data_Base_File_Key = Default_Descriptor)) and then | |
216 (((not (File_Table(1).Name = Default_Filename)) or | |
217 (File_Table(1).Descriptor /= Default_Descriptor)) or else | |
218 ((File_Table(1).Acct_Access /= Default_Permission) or | |
219 (not (File_Table(1).Mode = Default_Mode)) or | |
220 (File_Table(1).Current_Status /= Default_Status))) | |
221 then | |
222 Report.Failed ("Initial condition failure"); | |
223 end if; | |
224 | |
225 -- Create/initialize file using the capability provided by the visible | |
226 -- interface to the operating system, OS.File_Manager. The actual | |
227 -- processing routine is contained in the private grandchild package | |
228 -- Internals, which utilize the components from the grandparent package. | |
229 | |
230 File_Manager.Create_File (New_Mode, Data_Base_File_Key); | |
231 | |
232 -- Verify that the initial conditions of the file table component have | |
233 -- been properly modified by the initialization function. | |
234 | |
235 if not ((File_Table(1).Descriptor = Data_Base_File_Key) and then | |
236 (File_Table(1).Name = An_Ada_File_Name) and then | |
237 (File_Table(1).Acct_Access = User) and then | |
238 not ((File_Table(1).Mode = Default_Mode) or else | |
239 (File_Table(1).Current_Status = Default_Status))) | |
240 then | |
241 Report.Failed ("File creation failure"); | |
242 end if; | |
243 | |
244 Report.Result; | |
245 | |
246 end CA11009; |