1-- CA11020.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 generic parent package can depend on one of
28--      its own public generic children.
29--
30-- TEST DESCRIPTION:
31--      A scenario is created that demonstrates the potential of adding a
32--      public generic 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 bag abstraction in a generic package. Declare a public
38--      generic child of this package which adds a generic procedure to the
39--      original subsystem.  In the parent body, instantiate the public
40--      child.  Then instantiate the procedure as a child instance of the
41--      public child instance.
42--
43--      In the main program, declare an instance of parent.  Check that the
44--      operations in both parent and child packages perform as expected.
45--
46--
47-- CHANGE HISTORY:
48--      06 Dec 94   SAIC    ACVC 2.0
49--
50--!
51
52-- Simulates bag application.
53
54generic
55   type Element is private;
56   with function Image (E : Element) return String;
57
58package CA11020_0 is
59
60   type Bag is limited private;
61
62   procedure Add (E : in Element; To_The_Bag : in out Bag);
63
64   function Bag_Image (B : Bag) return string;
65
66private
67   type Node_Type;
68   type Bag is access Node_Type;
69
70   type Node_Type is
71      record
72         The_Element : Element;
73
74         -- Other components in real application, i.e.,
75         -- The_Count   : positive;
76
77         Next        : Bag;
78      end record;
79
80end CA11020_0;
81
82     --==================================================================--
83
84-- More operations on Bag.
85
86generic
87
88-- Parameters go here.
89
90package CA11020_0.CA11020_1 is
91
92   -- ... Other declarations.
93
94   generic                            -- Generic iterator procedure.
95      with procedure Use_Element (E : in Element);
96
97   procedure Iterate (B : in Bag);    -- Called once per element in the bag.
98
99   -- ... Various other operations.
100
101end CA11020_0.CA11020_1;
102
103     --==================================================================--
104
105package body CA11020_0.CA11020_1 is
106
107   procedure Iterate (B : in Bag) is
108
109   -- Traverse each element in the bag.
110
111      Elem : Bag := B;
112
113   begin
114      while Elem /= null loop
115         Use_Element (Elem.The_Element);
116         Elem := Elem.Next;
117      end loop;
118
119   end Iterate;
120
121end CA11020_0.CA11020_1;
122
123     --==================================================================--
124
125with CA11020_0.CA11020_1;    -- Public generic child package.
126
127package body CA11020_0 is
128
129   ----------------------------------------------------
130   -- Parent's body depends on public generic child. --
131   ----------------------------------------------------
132
133   -- Instantiate the public child.
134
135   package MS is new CA11020_1;
136
137   function Bag_Image (B : Bag) return string is
138
139      Buffer : String (1 .. 10_000);
140      Last   : Integer := 0;
141
142      -----------------------------------------------------
143
144      -- Will be called by the iterator.
145
146      procedure Append_Image (E : in Element) is
147         Im : constant String := Image (E);
148
149      begin  -- Append_Image
150         if Last /= 0 then        -- Insert a comma.
151            Last := Last + 1;
152            Buffer (Last) := ',';
153         end if;
154
155         Buffer (Last + 1 .. Last + Im'Length) := Im;
156         Last := Last + Im'Length;
157
158      end Append_Image;
159
160      -----------------------------------------------------
161
162      -- Instantiate procedure Iterate as a child of instance MS.
163
164      procedure Append_All is new MS.Iterate (Use_Element => Append_Image);
165
166   begin  -- Bag_Image
167
168      Append_All (B);
169
170      return Buffer (1 .. Last);
171
172   end Bag_Image;
173
174           -----------------------------------------------------
175
176   procedure Add (E : in Element; To_The_Bag : in out Bag) is
177
178      -- Not a real bag addition.
179
180      Index : Bag := To_The_Bag;
181
182   begin
183      -- ... Error-checking code omitted for brevity.
184
185      if Index = null then
186         To_The_Bag := new Node_Type' (The_Element => E,
187                                       Next        => null);
188      else
189         -- Goto the end of the list.
190
191         while Index.Next /= null loop
192            Index := Index.Next;
193         end loop;
194
195         -- Add element to the end of the list.
196
197         Index.Next := new Node_Type' (The_Element => E,
198                                       Next        => null);
199      end if;
200
201   end Add;
202
203end CA11020_0;
204
205     --==================================================================--
206
207with CA11020_0;               -- Bag application.
208
209with Report;
210
211procedure CA11020 is
212
213    -- Instantiate the bag application for integer type and attribute
214    -- Image.
215
216    package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image);
217
218    My_Bag : Bag_Of_Integers.Bag;
219
220begin
221
222   Report.Test ("CA11020", "Check that body of the generic parent package " &
223                "can depend on one of its own public generic children");
224
225   -- Add 10 consecutive integers to the bag.
226
227   for I in 1 .. 10 loop
228      Bag_Of_Integers.Add (I, My_Bag);
229   end loop;
230
231   if Bag_Of_Integers.Bag_Image (My_Bag)
232      /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then
233         Report.Failed ("Incorrect results");
234   end if;
235
236   Report.Result;
237
238end CA11020;
239