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/] [c392011.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C392011.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 if a function call with a controlling result is itself
28
--     a controlling operand of an enclosing call on a dispatching operation,
29
--     then its controlling tag value is determined by the controlling tag
30
--     value of the enclosing call.
31
--
32
-- TEST DESCRIPTION:
33
--      The test builds and traverses a "ragged" list; a linked list which
34
--      contains data elements of three different types (all rooted at
35
--      Level_0'Class).  The traversal of this list checks the objective
36
--      by calling the dispatching operation "Check" using an item from the
37
--      list, and calling the function create; thus causing the controlling
38
--      result of the function to be determined by evaluating the value of
39
--      the other controlling parameter to the two-parameter Check.
40
--
41
--
42
-- CHANGE HISTORY:
43
--      22 SEP 95   SAIC   Initial version
44
--      23 APR 96   SAIC   Corrected commentary, differentiated integer.
45
--
46
--!
47
 
48
----------------------------------------------------------------- C392011_0
49
 
50
package C392011_0 is
51
 
52
  type Level_0 is tagged record
53
    Ch_Item : Character;
54
  end record;
55
 
56
  function Create return Level_0;
57
    -- primitive dispatching function
58
 
59
  procedure Check( Left, Right: in Level_0 );
60
    -- has controlling parameters
61
 
62
end C392011_0;
63
 
64
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
65
 
66
with Report;
67
with TCTouch;
68
package body C392011_0 is
69
 
70
  The_Character : Character := 'A';
71
 
72
  function Create return Level_0 is
73
    Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character );
74
  begin
75
    The_Character := Character'Succ(The_Character);
76
    TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A
77
    return Created_Item_0;
78
  end Create;
79
 
80
  procedure Check( Left, Right: in Level_0 ) is
81
  begin
82
    TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B
83
  end Check;
84
 
85
end C392011_0;
86
 
87
----------------------------------------------------------------- C392011_1
88
 
89
with C392011_0;
90
package C392011_1 is
91
 
92
  type Level_1 is new C392011_0.Level_0 with record
93
    Int_Item : Integer;
94
  end record;
95
 
96
  -- note that Create becomes abstract upon this derivation hence:
97
 
98
  function Create return Level_1;
99
 
100
  procedure Check( Left, Right: in Level_1 );
101
 
102
end C392011_1;
103
 
104
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
105
 
106
with TCTouch;
107
package body C392011_1 is
108
 
109
  Integer_1 : Integer := 0;
110
 
111
  function Create return Level_1 is
112
    Created_Item_1 : constant Level_1
113
                   := ( C392011_0.Create with Int_Item => Integer_1 );
114
    -- note call to     ^--------------^   -- A
115
  begin
116
    Integer_1 := Integer'Succ(Integer_1);
117
    TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C
118
    return Created_Item_1;
119
  end Create;
120
 
121
  procedure Check( Left, Right: in Level_1 ) is
122
  begin
123
    TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D
124
  end Check;
125
 
126
end C392011_1;
127
 
128
----------------------------------------------------------------- C392011_2
129
 
130
with C392011_1;
131
package C392011_2 is
132
 
133
  type Level_2 is new C392011_1.Level_1 with record
134
    Another_Int_Item : Integer;
135
  end record;
136
 
137
  -- note that Create becomes abstract upon this derivation hence:
138
 
139
  function Create return Level_2;
140
 
141
  procedure Check( Left, Right: in Level_2 );
142
 
143
end C392011_2;
144
 
145
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
146
 
147
with TCTouch;
148
package body C392011_2 is
149
 
150
  Integer_2 : Integer := 100;
151
 
152
  function Create return Level_2 is
153
    Created_Item_2 : constant Level_2
154
                 := ( C392011_1.Create with Another_Int_Item => Integer_2 );
155
    -- note call to   ^--------------^   -- AC
156
  begin
157
    Integer_2 := Integer'Succ(Integer_2);
158
    TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E
159
    return Created_Item_2;
160
  end Create;
161
 
162
  procedure Check( Left, Right: in Level_2 ) is
163
  begin
164
    TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F
165
  end Check;
166
 
167
end C392011_2;
168
 
169
------------------------------------------------------- C392011_2.C392011_3
170
 
171
with C392011_0;
172
package C392011_2.C392011_3 is
173
 
174
  type Wide_Reference is access all C392011_0.Level_0'Class;
175
 
176
  type Ragged_Element;
177
 
178
  type List_Pointer is access Ragged_Element;
179
 
180
  type Ragged_Element is record
181
    Data : Wide_Reference;
182
    Next : List_Pointer;
183
  end record;
184
 
185
  procedure Build_List;
186
 
187
  procedure Traverse_List;
188
 
189
end C392011_2.C392011_3;
190
 
191
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
192
 
193
package body C392011_2.C392011_3 is
194
 
195
  The_List : List_Pointer;
196
 
197
  procedure Build_List is
198
  begin
199
 
200
    -- build a list that looks like:
201
    -- Level_2, Level_1, Level_2, Level_1, Level_0
202
    --
203
    -- the mechanism is to create each object, "pushing" the existing list
204
    -- onto the end: cons( new_item, car, cdr )
205
 
206
    The_List :=
207
        new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null );
208
    -- Level_0                                                            >> A
209
 
210
    The_List :=
211
    new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
212
    -- Level_1 -> Level_0                                                >> AC
213
 
214
    The_List :=
215
    new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
216
    -- Level_2 -> Level_1 -> Level_0                                    >> ACE
217
 
218
    The_List :=
219
    new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
220
    -- Level_1 -> Level_2 -> Level_1 -> Level_0                          >> AC
221
 
222
    The_List :=
223
    new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
224
    -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0              >> ACE
225
 
226
  end Build_List;
227
 
228
  procedure Traverse_List is
229
 
230
    Next_Item : List_Pointer := The_List;
231
 
232
  -- Check that if a function call with a controlling result is itself
233
  -- a controlling operand of an enclosing call on a dispatching operation,
234
  -- then its controlling tag value is determined by the controlling tag
235
  -- value of the enclosing call.
236
 
237
  -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0
238
 
239
  begin
240
 
241
    while Next_Item /= null loop  -- here we go!
242
      -- these calls better dispatch according to the value in the particular
243
      -- list item; causing the call to create to dispatch accordingly.
244
      -- why do it twice?  To make sure order makes no difference
245
 
246
      C392011_0.Check(Next_Item.Data.all, C392011_0.Create);
247
      -- Create will touch first, then Check touches
248
 
249
      C392011_0.Check(C392011_0.Create, Next_Item.Data.all);
250
 
251
      -- Here's what's s'pos'd to 'appen:
252
      -- Check( Lev_2, Create ) >> ACEF
253
      -- Check( Create, Lev_2 ) >> ACEF
254
      -- Check( Lev_1, Create ) >> ACD
255
      -- Check( Create, Lev_1 ) >> ACD
256
      -- Check( Lev_2, Create ) >> ACEF
257
      -- Check( Create, Lev_2 ) >> ACEF
258
      -- Check( Lev_1, Create ) >> ACD
259
      -- Check( Create, Lev_1 ) >> ACD
260
      -- Check( Lev_0, Create ) >> AB
261
      -- Check( Create, Lev_0 ) >> AB
262
 
263
      Next_Item := Next_Item.Next;
264
    end loop;
265
  end Traverse_List;
266
 
267
end C392011_2.C392011_3;
268
 
269
------------------------------------------------------------------- C392011
270
 
271
with Report;
272
with TCTouch;
273
with C392011_2.C392011_3;
274
 
275
procedure C392011 is
276
 
277
begin  -- Main test procedure.
278
 
279
  Report.Test ("C392011", "Check that if a function call with a " &
280
                          "controlling result is itself a controlling " &
281
                          "operand of an enclosing call on a dispatching " &
282
                          "operation, then its controlling tag value is " &
283
                          "determined by the controlling tag value of " &
284
                          "the enclosing call" );
285
 
286
  C392011_2.C392011_3.Build_List;
287
  TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" );
288
 
289
  C392011_2.C392011_3.Traverse_List;
290
  TCTouch.Validate( "ACEFACEF" &
291
                    "ACDACD" &
292
                    "ACEFACEF" &
293
                    "ACDACD" &
294
                    "ABAB",
295
                    "Traverse List" );
296
 
297
  Report.Result;
298
 
299
end C392011;

powered by: WebSVN 2.1.0

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