OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c393a03.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- 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
 
56
with F393A00_1;
57
package 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
 
67
private
68
 
69
  type Counting_Object is abstract new F393A00_1.Object with
70
    record
71
      Tally : Natural :=0;
72
    end record;
73
 
74
end C393A03_0;
75
 
76
-----------------------------------------------------------------------------
77
 
78
with F393A00_0;
79
package 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
 
104
end C393A03_0;
105
 
106
------------------------------------------------------------------- C393A03_1
107
 
108
with C393A03_0;
109
package 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
 
120
private
121
 
122
  type Modular_Object is new C393A03_0.Counting_Object with
123
    record
124
      Max_Value : Natural;
125
    end record;
126
 
127
end C393A03_1;
128
 
129
-----------------------------------------------------------------------------
130
 
131
with F393A00_0;
132
package 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
 
162
end C393A03_1;
163
 
164
--------------------------------------------------------------------- C393A03
165
 
166
with Report;
167
with F393A00_0;
168
with F393A00_1;
169
with C393A03_0;
170
with C393A03_1;
171
procedure 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
 
202
begin  -- 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
 
242
end C393A03;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.