1-- C393A02.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 dispatching call to an abstract subprogram invokes
28--     the correct subprogram body of a descendant type according to
29--     the controlling tag.
30--     Check that a subprogram can be declared with formal parameters
31--     and result that are of an abstract type's associated class-wide
32--     type and that such subprograms can be called. 3.4.1(4)
33--
34-- TEST DESCRIPTION:
35--     This test declares several objects of types derived from the
36--     abstract type as defined in the foundation F393A00.  It then calls
37--     various dispatching and class-wide subprograms using those objects.
38--     The packages in F393A00 are instrumented to trace the flow of
39--     execution.
40--     The test checks for the correct order of execution, as expected
41--     by the various calls.
42--
43-- TEST FILES:
44--     The following files comprise this test:
45--
46--        F393A00.A   (foundation code)
47--        C393A02.A
48--
49--
50-- CHANGE HISTORY:
51--      06 Dec 94   SAIC    ACVC 2.0
52--      19 Dec 94   SAIC    Removed RM references from objective text.
53--      05 APR 96   SAIC    Update RM references for 2.1
54--
55--!
56
57with Report;
58with F393A00_0;
59with F393A00_1;
60with F393A00_2;
61with F393A00_3;
62with F393A00_4;
63procedure C393A02 is
64
65  A_Windmill : F393A00_2.Windmill;
66  A_Pump     : F393A00_3.Pump;
67  A_Mill     : F393A00_4.Mill;
68
69  A_Windmill_2 : F393A00_2.Windmill;
70  A_Pump_2     : F393A00_3.Pump;
71  A_Mill_2     : F393A00_4.Mill;
72
73  B_Windmill : F393A00_2.Windmill;
74  B_Pump     : F393A00_3.Pump;
75  B_Mill     : F393A00_4.Mill;
76
77  procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is
78  begin
79   F393A00_0.TC_Touch('x');
80   F393A00_2.Swap( A,B );
81  end Swapem;
82
83  function Zephyr( A: F393A00_2.Windmill'Class )
84           return F393A00_2.Windmill'Class is
85    Item : F393A00_2.Windmill'Class := A;
86  begin
87    F393A00_0.TC_Touch('y');
88    if not F393A00_1.Initialized( Item ) then  -- b
89      F393A00_2.Initialize( Item );            -- a
90    end if;
91    F393A00_2.Stop( Item );                    -- f / mff
92    F393A00_2.Add_Spin( Item, 10 );            -- e
93    return Item;
94  end Zephyr;
95
96  function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is
97    Item : F393A00_2.Windmill'Class := It;
98  begin
99    F393A00_2.Stop( Item );                   -- f
100    F393A00_2.Add_Spin( Item, 40 );           -- e
101    return Item;
102  end Gale;
103
104  function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is
105    Item : F393A00_2.Windmill'Class := It;
106  begin
107    F393A00_2.Stop( Item );                   -- f
108    F393A00_2.Add_Spin( Item, 50 );           -- e
109    return Item;
110  end Gale;
111
112  function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is
113    Item : F393A00_2.Windmill'Class := It;
114  begin
115    F393A00_2.Stop( Item );                   -- mff
116    F393A00_2.Add_Spin( Item, 60 );           -- e
117    return Item;
118  end Gale;
119
120begin  -- Main test procedure.
121
122  Report.Test ("C393A02", "Check that a dispatching call to an abstract "
123                         & "subprogram invokes the correct subprogram body. "
124                         & "Check that a subprogram declared with formal "
125                         & "parameters/result of an abstract type's "
126                         & "associated class-wide can be called" );
127
128  F393A00_0.TC_Validate( "hhh", "Mill declarations" );
129  A_Windmill := F393A00_2.Create;
130  F393A00_0.TC_Validate( "d", "Create A_Windmill" );
131
132  A_Pump     := F393A00_3.Create;
133  F393A00_0.TC_Validate( "h", "Create A_Pump" );
134
135  A_Mill     := F393A00_4.Create;
136  F393A00_0.TC_Validate( "hl", "Create A_Mill" );
137
138  --------------
139
140  Swapem( A_Windmill, A_Windmill_2 );
141  F393A00_0.TC_Validate( "xc", "Windmill Swap" );
142
143  Swapem( A_Pump, A_Pump_2 );
144  F393A00_0.TC_Validate( "xc", "Pump Swap" );
145
146  Swapem( A_Mill, A_Mill_2 );
147  F393A00_0.TC_Validate( "xk", "Pump Swap" );
148
149  F393A00_2.Initialize( A_Windmill_2 );
150  F393A00_3.Initialize( A_Pump_2 );
151  F393A00_4.Initialize( A_Mill_2 );
152  B_Windmill := A_Windmill_2;
153  B_Pump     := A_Pump_2;
154  B_Mill     := A_Mill_2;
155  F393A00_2.Add_Spin( B_Windmill, 123 );
156  F393A00_3.Set_Rate( B_Pump, 12.34 );
157  F393A00_4.Add_Spin( B_Mill, 321 );
158  F393A00_0.TC_Validate( "aaaeie", "Setting Values" );
159
160  declare
161    It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe
162    XX : F393A00_2.Windmill'Class := Gale( B_Windmill );   -- fe
163    use type F393A00_2.Rotational_Measurement;
164  begin
165    if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
166then
167      Report.Failed( "Copy to class-wide variable" );
168    end if;                                                -- bb
169    if F393A00_2.Spin( It ) /= 10                          -- g
170       or F393A00_2.Spin( XX ) /= 40 then                  -- g
171      Report.Failed( "Call to class-wide operation" );
172    end if;
173
174    F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" );
175  end;
176
177  declare
178    It : F393A00_2.Windmill'Class := Zephyr( B_Pump );     -- ybfe
179    XX : F393A00_2.Windmill'Class := Gale( B_Pump );       -- fe
180    use type F393A00_2.Rotational_Measurement;
181  begin
182    if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
183then
184      Report.Failed( "Bad copy to class-wide variable" );
185    end if;                                                -- bb
186    if F393A00_2.Spin( It ) /= 10                          -- g
187       or F393A00_2.Spin( XX ) /= 50 then                  -- g
188      Report.Failed( "Call to class-wide operation" );
189    end if;
190
191    F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" );
192  end;
193
194  declare
195    It : F393A00_2.Windmill'Class := Zephyr( B_Mill );     -- ybmffe
196    XX : F393A00_2.Windmill'Class := Gale( B_Mill );       -- mffe
197    use type F393A00_2.Rotational_Measurement;
198  begin
199    if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX )
200then
201      Report.Failed( "Bad copy to class-wide variable" );
202    end if;                                                -- bb
203    if F393A00_2.Spin( It ) /= 10                          -- g
204       or F393A00_2.Spin( XX ) /= 60 then                  -- g
205      Report.Failed( "Call to class-wide operation" );
206    end if;
207
208    F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" );
209  end;
210
211  Report.Result;
212
213end C393A02;
214