1-- C393A05.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 for a nonabstract private extension, any inherited
28 --      abstract subprograms can be overridden in the private part of
29 --      the immediately enclosing package and that calls can be made to
30 --      private dispatching operations.
31 --
32 -- TEST DESCRIPTION:
33 --      This test builds an additional layer upon the foundation code to
34 --      provide the required "hidden" dispatching operation.  The procedure
35 --      Swap, a private subprogram, should be called by dispatch.
36 --
37 -- TEST FILES:
38 --      The following files comprise this test:
39 --
40 --         F393A00.A   (foundation code)
41 --         C393A05.A
42 --
43 --
44-- CHANGE HISTORY:
45--      06 Dec 94   SAIC    ACVC 2.0
46--
47 --!
48
49 with F393A00_4;
50 package C393A05_0 is
51   type Grinder is new F393A00_4.Mill with private;
52   type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso);
53
54   procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness );
55   function  Grind( It: Grinder ) return Coarseness;
56
57   function  Create return Grinder;
58 private
59   procedure Swap( A,B: in out Grinder );
60   type Grinder is new F393A00_4.Mill with
61     record
62       Grind : Coarseness := Whole_Bean;
63     end record;
64 end C393A05_0;
65
66 with F393A00_0;
67 package body C393A05_0 is
68   procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is
69   begin
70     F393A00_0.TC_Touch( 'A' );
71     It.Grind := The_Grind;
72   end Set_Grind;
73
74   function  Grind( It: Grinder ) return Coarseness is
75   begin
76     F393A00_0.TC_Touch( 'B' );
77     return It.Grind;
78   end Grind;
79
80   procedure Swap( A,B: in out Grinder ) is
81     T : constant Grinder := A;
82   begin
83     F393A00_0.TC_Touch( 'C' );
84     A := B;
85     B := T;
86   end Swap;
87
88   function  Create return Grinder is
89     One: Grinder;
90   begin
91     F393A00_0.TC_Touch( 'D' );
92     F393A00_4.Initialize( F393A00_4.Mill( One ) );
93     One.Grind := Fine;
94     return One;
95   end Create;
96 end C393A05_0;
97
98 with Report;
99 with F393A00_0;
100 with C393A05_0;
101 procedure C393A05 is
102
103   package Tracer renames F393A00_0;
104   package Coffee renames C393A05_0;
105   use type Coffee.Coarseness;
106
107   Morning   : Coffee.Grinder;
108   Afternoon : Coffee.Grinder;
109
110   Gritty    : Coffee.Coarseness;
111
112   procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is
113   begin
114     Coffee.Swap( A, B ); -- dispatch
115   end Class_Swap;
116
117 begin  -- Main test procedure.
118
119   Report.Test ("C393A05",  "Check that nonabstract private extensions, "
120                          & "inherited abstract subprograms overridden "
121                          & "in the private part can be dispatched from "
122                          & "outside the package" );
123
124   Tracer.TC_Validate( "hh", "Declarations" );
125
126   Morning := Coffee.Create;
127   Tracer.TC_Validate( "hDa", "Creating Morning Coffee" );
128   Gritty  := Coffee.Grind( Morning );
129   Tracer.TC_Validate( "B", "Finding Morning Grind" );
130
131   Afternoon := Coffee.Create;
132   Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" );
133   Coffee.Set_Grind( Afternoon, Coffee.Medium );
134   Tracer.TC_Validate( "A", "Setting Afternoon Grind" );
135
136   Coffee.Swap( Morning, Afternoon );
137   Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" );
138
139   if Gritty /= Coffee.Grind( Afternoon )
140      or Coffee.Grind ( Afternoon ) /= Coffee.Fine then
141     Report.Failed ("Result of Swap");
142   end if;
143   Tracer.TC_Validate( "BB", "Finding Afternoon Grind" );
144
145   Sunset: declare
146     Evening   : Coffee.Grinder'Class := Coffee.Create;
147   begin
148     Tracer.TC_Validate( "hDa", "Creating Evening Coffee" );
149
150     Coffee.Set_Grind( Evening, Coffee.Espresso );
151     Tracer.TC_Validate( "A", "Setting Evening Grind" );
152
153     Morning := Coffee.Grinder( Evening );
154     Class_Swap( Morning, Evening );
155     Tracer.TC_Validate( "C", "Swapping Coffees" );
156     if Coffee.Grind( Morning ) /= Coffee.Espresso then
157       Report.Failed ("Result of Assignment");
158     end if;
159   end Sunset;
160
161   Report.Result;
162
163 end C393A05;
164
165
166
167