Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/ca/ca11017.a @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 -- CA11017.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 children.
29 --
30 -- TEST DESCRIPTION:
31 -- A scenario is created that demonstrates the potential of adding a
32 -- public 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 string abstraction in a package which manipulates string
38 -- replacement. Define a parent package which provides operations for
39 -- a record type with discriminant. Declare a public child of this
40 -- package which adds functionality to the original subsystem. In the
41 -- parent body, call operations from the public child.
42 --
43 -- In the main program, check that operations in the parent and public
44 -- child perform as expected.
45 --
46 --
47 -- CHANGE HISTORY:
48 -- 06 Dec 94 SAIC ACVC 2.0
49 --
50 --!
51
52 -- Simulates application which manipulates strings.
53
54 package CA11017_0 is
55
56 type String_Rec (The_Size : positive) is private;
57
58 type Substring is new string;
59
60 -- ... Various other types used by the application.
61
62 procedure Replace (In_The_String : in out String_Rec;
63 At_The_Position : in positive;
64 With_The_String : in String_Rec);
65
66 -- ... Various other operations used by the application.
67
68 private
69 -- Different size for each individual record.
70
71 type String_Rec (The_Size : positive) is
72 record
73 The_Length : natural := 0;
74 The_Content : Substring (1 .. The_Size);
75 end record;
76
77 end CA11017_0;
78
79 --=================================================================--
80
81 -- Public child added during code maintenance without disturbing a
82 -- large system. This public child would add functionality to the
83 -- original system.
84
85 package CA11017_0.CA11017_1 is
86
87 Position_Error : exception;
88
89 function Equal_Length (Left : in String_Rec;
90 Right : in String_Rec) return boolean;
91
92 function Same_Content (Left : in String_Rec;
93 Right : in String_Rec) return boolean;
94
95 procedure Copy (From_The_Substring : in Substring;
96 To_The_String : in out String_Rec);
97
98 -- ... Various other operations used by the application.
99
100 end CA11017_0.CA11017_1;
101
102 --=================================================================--
103
104 package body CA11017_0.CA11017_1 is
105
106 function Equal_Length (Left : in String_Rec;
107 Right : in String_Rec) return boolean is
108 -- Quick comparison between the lengths of the input strings.
109
110 begin
111 return (Left.The_Length = Right.The_Length); -- Parent's private
112 -- type.
113 end Equal_Length;
114 --------------------------------------------------------------------
115 function Same_Content (Left : in String_Rec;
116 Right : in String_Rec) return boolean is
117
118 begin
119 for I in 1 .. Left.The_Length loop
120 if Left.The_Content (I) = Right.The_Content (I) then
121 return true;
122 else
123 return false;
124 end if;
125 end loop;
126
127 end Same_Content;
128 --------------------------------------------------------------------
129 procedure Copy (From_The_Substring : in Substring;
130 To_The_String : in out String_Rec) is
131 begin
132 To_The_String.The_Content -- Parent's private type.
133 (1 .. From_The_Substring'length) := From_The_Substring;
134
135 To_The_String.The_Length -- Parent's private type.
136 := From_The_Substring'length;
137 end Copy;
138
139 end CA11017_0.CA11017_1;
140
141 --=================================================================--
142
143 -- After child is added to the subsystem, a maintainer decides
144 -- to take advantage of the new functionality and rewrites the
145 -- parent's body.
146
147 with CA11017_0.CA11017_1;
148
149 package body CA11017_0 is
150
151 -- Calls functions from public child for a quick comparison of the
152 -- input strings. If their lengths are the same, do the replacement.
153
154 procedure Replace (In_The_String : in out String_Rec;
155 At_The_Position : in positive;
156 With_The_String : in String_Rec) is
157 End_Position : natural := At_The_Position +
158 With_The_String.The_Length - 1;
159
160 begin
161 if not CA11017_0.CA11017_1.Equal_Length -- Public child's operation.
162 (With_The_String, In_The_String) then
163 raise CA11017_0.CA11017_1.Position_Error;
164 -- Public child's exception.
165 else
166 In_The_String.The_Content (At_The_Position .. End_Position) :=
167 With_The_String.The_Content (1 .. With_The_String.The_Length);
168 end if;
169
170 end Replace;
171
172 end CA11017_0;
173
174 --=================================================================--
175
176 with Report;
177
178 with CA11017_0.CA11017_1; -- Explicit with public child package,
179 -- implicit with parent package (CA11017_0).
180
181 procedure CA11017 is
182
183 package String_Pkg renames CA11017_0;
184 use String_Pkg;
185
186 begin
187
188 Report.Test ("CA11017", "Check that body of the parent package can " &
189 "depend on one of its own public children");
190
191 -- Both input strings have the same size. Replace the first string by the
192 -- second string.
193
194 Replace_Subtest:
195 declare
196 The_First_String, The_Second_String : String_Rec (16);
197 -- Parent's private type.
198 The_Position : positive := 1;
199 begin
200 CA11017_1.Copy ("This is the time",
201 To_The_String => The_First_String);
202
203 CA11017_1.Copy ("For all good men", The_Second_String);
204
205 Replace (The_First_String, The_Position, The_Second_String);
206
207 -- Compare results using function from public child since
208 -- the type is private.
209
210 if not CA11017_1.Same_Content
211 (The_First_String, The_Second_String) then
212 Report.Failed ("Incorrect results");
213 end if;
214
215 end Replace_Subtest;
216
217 -- During processing, the application may erroneously attempt to replace
218 -- strings of different size. This would result in the raising of an
219 -- exception.
220
221 Exception_Subtest:
222 declare
223 The_First_String : String_Rec (17);
224 -- Parent's private type.
225 The_Second_String : String_Rec (13);
226 -- Parent's private type.
227 The_Position : positive := 2;
228 begin
229 CA11017_1.Copy (" ACVC Version 2.0", The_First_String);
230
231 CA11017_1.Copy (From_The_Substring => "ACVC 9X Basic",
232 To_The_String => The_Second_String);
233
234 Replace (The_First_String, The_Position, The_Second_String);
235
236 Report.Failed ("Exception was not raised");
237
238 exception
239 when CA11017_1.Position_Error =>
240 Report.Comment ("Exception is raised as expected");
241
242 end Exception_Subtest;
243
244 Report.Result;
245
246 end CA11017;