1-- C393A03.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 non-abstract primitive subprogram of an abstract
28--      type can be called as a dispatching operation and that the body
29--      of this subprogram can make a dispatching call to an abstract
30--      operation of the corresponding abstract type.
31--
32-- TEST DESCRIPTION:
33--      This test expands on the class family defined in foundation F393A00
34--      by deriving a new abstract type from the root abstract type "Object".
35--      The subprograms defined for the new abstract type are then
36--      appropriately overridden, and the test ultimately calls various
37--      mixtures of these subprograms to check that the dispatching occurs
38--      correctly.
39--
40-- TEST FILES:
41--      The following files comprise this test:
42--
43--         F393A00.A   (foundation code)
44--         C393A03.A
45--
46--
47-- CHANGE HISTORY:
48--      06 Dec 94   SAIC    ACVC 2.0
49--      19 Dec 94   SAIC    Removed ARM references from objective text.
50--      23 Oct 95   SAIC    Fixed bugs for ACVC 2.0.1
51--
52--!
53
54------------------------------------------------------------------- C393A03_0
55
56with F393A00_1;
57package C393A03_0 is
58
59  type Counting_Object is abstract new F393A00_1.Object with private;
60  -- inherits Initialize, Swap (abstract) and Create (abstract)
61
62  procedure Bump ( A_Counter: in out Counting_Object );
63  procedure Clear( A_Counter: in out Counting_Object ) is abstract;
64  procedure Zero ( A_Counter: in out Counting_Object );
65  function  Value( A_Counter: Counting_Object'Class ) return Natural;
66
67private
68
69  type Counting_Object is abstract new F393A00_1.Object with
70    record
71      Tally : Natural :=0;
72    end record;
73
74end C393A03_0;
75
76-----------------------------------------------------------------------------
77
78with F393A00_0;
79package body C393A03_0 is
80
81  procedure Bump ( A_Counter: in out Counting_Object ) is
82  begin
83    F393A00_0.TC_Touch('A');
84    A_Counter.Tally := A_Counter.Tally +1;
85  end Bump;
86
87  procedure Zero ( A_Counter: in out Counting_Object ) is
88  begin
89    F393A00_0.TC_Touch('B');
90
91 -- dispatching call to abstract operation of Counting_Object
92    Clear( Counting_Object'Class(A_Counter) );
93
94    A_Counter.Tally := 0;
95
96  end Zero;
97
98  function  Value( A_Counter: Counting_Object'Class ) return Natural is
99  begin
100    F393A00_0.TC_Touch('C');
101    return A_Counter.Tally;
102  end Value;
103
104end C393A03_0;
105
106------------------------------------------------------------------- C393A03_1
107
108with C393A03_0;
109package C393A03_1 is
110
111  type Modular_Object is new C393A03_0.Counting_Object with private;
112  -- inherits Initialize, Bump, Zero and Value,
113  -- inherits abstract Swap, Create and Clear
114
115  procedure Swap( A,B: in out Modular_Object );
116  procedure Clear( It: in out Modular_Object );
117  procedure Set_Max( It : in out Modular_Object; Value : Natural );
118  function  Create return Modular_Object;
119
120private
121
122  type Modular_Object is new C393A03_0.Counting_Object with
123    record
124      Max_Value : Natural;
125    end record;
126
127end C393A03_1;
128
129-----------------------------------------------------------------------------
130
131with F393A00_0;
132package body C393A03_1 is
133
134  procedure Swap( A,B: in out Modular_Object ) is
135    T : constant Modular_Object := B;
136  begin
137    F393A00_0.TC_Touch('1');
138    B := A;
139    A := T;
140  end Swap;
141
142  procedure Clear( It: in out Modular_Object ) is
143  begin
144    F393A00_0.TC_Touch('2');
145    null;
146  end Clear;
147
148  procedure Set_Max( It : in out Modular_Object; Value : Natural ) is
149  begin
150    F393A00_0.TC_Touch('3');
151    It.Max_Value := Value;
152  end Set_Max;
153
154  function  Create return Modular_Object is
155    AMO : Modular_Object;
156  begin
157    F393A00_0.TC_Touch('4');
158    AMO.Max_Value := Natural'Last;
159    return AMO;
160  end Create;
161
162end C393A03_1;
163
164--------------------------------------------------------------------- C393A03
165
166with Report;
167with F393A00_0;
168with F393A00_1;
169with C393A03_0;
170with C393A03_1;
171procedure C393A03 is
172
173  A_Thing       : C393A03_1.Modular_Object;
174  Another_Thing : C393A03_1.Modular_Object;
175
176  procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is
177  begin
178    C393A03_0.Initialize( It );  -- dispatch to inherited procedure
179  end Initialize;
180
181  procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is
182  begin
183    C393A03_0.Bump( It ); -- dispatch to non-abstract procedure
184  end Bump;
185
186  procedure Set_Max( It  : in out C393A03_1.Modular_Object'Class;
187                     Val : Natural) is
188  begin
189    C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure
190  end Set_Max;
191
192  procedure Swap( A, B  : in out C393A03_0.Counting_Object'Class ) is
193  begin
194    C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure
195  end Swap;
196
197  procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is
198  begin
199    C393A03_0.Zero( It ); -- dispatch to non-abstract procedure
200  end Zero;
201
202begin  -- Main test procedure.
203
204   Report.Test ("C393A03", "Check that a non-abstract primitive subprogram "
205			 & "of an abstract type can be called as a "
206			 & "dispatching operation and that the body of this "
207			 & "subprogram can make a dispatching call to an "
208			 & "abstract operation of the corresponding "
209			 & "abstract type" );
210
211   A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last
212   F393A00_0.TC_Validate( "4", "Overridden primitive layer 2");
213
214   Initialize( A_Thing );
215   Initialize( Another_Thing );
216   F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0");
217
218   Bump( A_Thing ); -- Tally = 1
219   F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1");
220
221   Set_Max( A_Thing, 42 ); -- Max_Value = 42
222   F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2");
223
224   if not F393A00_1.Initialized( A_Thing ) then
225     Report.Failed("Initialize didn't");
226   end if;
227   F393A00_0.TC_Validate( "b", "Class-wide layer 0");
228
229   Swap( A_Thing, Another_Thing );
230   F393A00_0.TC_Validate( "1", "Overridden abstract layer 2");
231
232   Zero( A_Thing );
233   F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch");
234
235   if C393A03_0.Value( A_Thing ) /= 0 then
236     Report.Failed("Zero didn't");
237   end if;
238   F393A00_0.TC_Validate( "C", "Class-wide normal layer 2");
239
240   Report.Result;
241
242end C393A03;
243