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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c6/] [c640001.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C640001.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 the prefix of a subprogram call with an actual parameter
28
--      part may be an implicit dereference of an access-to-subprogram value.
29
--      Check that, for an access-to-subprogram type whose designated profile
30
--      contains parameters of a tagged generic formal type, an access-to-
31
--      subprogram value may designate dispatching and non-dispatching
32
--      operations, and that dereferences of such a value call the appropriate
33
--      subprogram.
34
--
35
-- TEST DESCRIPTION:
36
--      The test declares a tagged type (Table) with a dispatching operation
37
--      (Clear), as well as a derivative (Table2) which overrides that
38
--      operation. A subprogram with the same name and profile as Clear is
39
--      declared in a separate package -- it is therefore not a dispatching
40
--      operation of Table. For the purposes of the test, each version of Clear
41
--      modifies the components of its parameter in a unique way.
42
--
43
--      Additionally, an operation (Reset) of type Table is declared which
44
--      makes a re-dispatching call to Clear, i.e.,
45
--
46
--         procedure Reset (A: in out Table) is
47
--         begin
48
--            ...
49
--            Clear (Table'Class(A));  -- Re-dispatch based on tag of actual.
50
--            ...
51
--         end Reset;
52
--
53
--      An access-to-subprogram type is declared within a generic package,
54
--      with a designated profile which declares a parameter of a generic
55
--      formal tagged private type.
56
--
57
--      The generic is instantiated with type Table. The instance defines an
58
--      array of access-to-subprogram values (which represents a table of
59
--      operations to be performed sequentially on a single operand).
60
--      Access values designating the dispatching version of Clear, the
61
--      non-dispatching version of Clear, and Reset (which re-dispatches to
62
--      Clear) are placed in this array.
63
--
64
--      In the instance, each subprogram in the array is called by implicitly
65
--      dereferencing the corresponding access value. For the dispatching and
66
--      non-dispatching versions of Clear, the actual parameter passed is of
67
--      type Table. For Reset, the actual parameter passed is a view conversion
68
--      of an object of type Table2 to type Table, i.e., Table(Table2_Obj).
69
--      Since the tag of the operand never changes, the call to Clear within
70
--      Reset should execute Table2's version of Clear.
71
--
72
--      The main program verifies that the appropriate version of Clear is
73
--      called in each case, by checking that the components of the actual are
74
--      updated as expected.
75
--
76
--
77
-- CHANGE HISTORY:
78
--      06 Dec 94   SAIC    ACVC 2.0
79
--
80
--!
81
 
82
package C640001_0 is
83
 
84
   -- Data type artificial for testing purposes.
85
 
86
   Row_Len : constant := 10;
87
 
88
   T : constant Boolean := True;
89
   F : constant Boolean := False;
90
 
91
   type Row_Type is array (1 .. Row_Len) of Boolean;
92
 
93
   function Is_True  (A : in Row_Type) return Boolean;
94
   function Is_False (A : in Row_Type) return Boolean;
95
 
96
 
97
   Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F);
98
 
99
   type Table is tagged record                  -- Tagged type.
100
      Row1 : Row_Type := Init;
101
      Row2 : Row_Type := Init;
102
   end record;
103
 
104
   procedure Clear (A : in out Table);          -- Dispatching operation.
105
 
106
   procedure Reset (A : in out Table);          -- Re-dispatching operation.
107
 
108
   -- ...Other operations.
109
 
110
 
111
   type Table2 is new Table with null record;   -- Extension of Table (but
112
                                                -- structurally identical).
113
 
114
   procedure Clear (A : in out Table2);         -- Overrides parent's op.
115
 
116
   -- ...Other operations.
117
 
118
 
119
end C640001_0;
120
 
121
 
122
     --===================================================================--
123
 
124
 
125
package body C640001_0 is
126
 
127
   function Is_True (A : in Row_Type) return Boolean is
128
   begin
129
      for I in A'Range loop
130
         if A(I) /= True then                  -- Return true if all elements
131
            return False;                      -- of A are True.
132
         end if;
133
      end loop;
134
      return True;
135
   end Is_True;
136
 
137
 
138
   function Is_False (A : in Row_Type) return Boolean is
139
   begin
140
      return A = Row_Type'(others => False);   -- Return true if all elements
141
   end Is_False;                               -- of A are False.
142
 
143
 
144
   procedure Clear (A : in out Table) is
145
   begin
146
      for I in Row_Type'Range loop             -- This version of Clear sets
147
         A.Row1(I) := False;                   -- the elements of Row1 only
148
      end loop;                                -- to False.
149
   end Clear;
150
 
151
 
152
   procedure Reset (A : in out Table) is
153
   begin
154
      Clear (Table'Class(A));                  -- Redispatch to appropriate
155
      -- ... Other "reset" activities.         -- version of Clear.
156
   end Reset;
157
 
158
 
159
   procedure Clear (A : in out Table2) is
160
   begin
161
      for I in Row_Type'Range loop             -- This version of Clear sets
162
         A.Row1(I) := True;                    -- the elements of Row1 only
163
      end loop;                                -- to True.
164
   end Clear;
165
 
166
 
167
end C640001_0;
168
 
169
 
170
     --===================================================================--
171
 
172
 
173
with C640001_0;
174
package C640001_1 is
175
 
176
   procedure Clear (T : in out C640001_0.Table);  -- Non-dispatching operation.
177
 
178
end C640001_1;
179
 
180
 
181
     --===================================================================--
182
 
183
 
184
package body C640001_1 is
185
 
186
   procedure Clear (T : in out C640001_0.Table) is
187
   begin
188
      for I in C640001_0.Row_Type'Range loop   -- This version of Clear sets
189
         T.Row2(I) := True;                    -- the elements of Row2 only
190
      end loop;                                -- to True.
191
   end Clear;
192
 
193
end C640001_1;
194
 
195
 
196
     --===================================================================--
197
 
198
 
199
-- This unit represents a support package for table-driven processing of
200
-- data objects. Process_Operand performs a set of operations are performed
201
-- sequentially on a single operand. Note that parameters are provided to
202
-- specify which subset of operations in the operations table are to be
203
-- performed (ordinarily these might be omitted, but the test requires that
204
-- each operation be called individually for a single operand).
205
 
206
generic
207
   type Tag is tagged private;
208
package C640001_2 is
209
 
210
   type Proc_Ptr is access procedure (P: in out Tag);
211
 
212
   type Op_List is private;
213
 
214
   procedure Add_Op (Op   : in     Proc_Ptr;                -- Add operation to
215
                     List : in out Op_List);                -- to list of ops.
216
 
217
   procedure Process_Operand (Operand  : in out Tag;        -- Execute a subset
218
                              List     : in     Op_List;    -- of a list of
219
                              First_Op : in     Positive;   -- operations using
220
                              Last_Op  : in     Positive);  -- a given operand.
221
 
222
   -- ...Other operations.
223
 
224
private
225
   type Op_Array is array (1 .. 3) of Proc_Ptr;
226
 
227
   type Op_List is record
228
      Top : Natural := 0;
229
      Ops : Op_Array;
230
   end record;
231
end C640001_2;
232
 
233
 
234
     --===================================================================--
235
 
236
 
237
package body C640001_2 is
238
 
239
   procedure Add_Op (Op   : in     Proc_Ptr;
240
                     List : in out Op_List) is
241
   begin
242
      List.Top := List.Top + 1;  -- Artificial; no Constraint_Error protection.
243
      List.Ops(List.Top) := Op;
244
   end Add_Op;
245
 
246
 
247
   procedure Process_Operand (Operand  : in out Tag;
248
                              List     : in     Op_List;
249
                              First_Op : in     Positive;
250
                              Last_Op  : in     Positive) is
251
   begin
252
      for I in First_Op .. Last_Op loop
253
         List.Ops(I)(Operand);       -- Implicit dereference of an
254
      end loop;                      -- access-to-subprogram value.
255
   end Process_Operand;
256
 
257
end C640001_2;
258
 
259
 
260
     --===================================================================--
261
 
262
 
263
with C640001_0;
264
with C640001_1;
265
with C640001_2;
266
 
267
with Report;
268
procedure C640001 is
269
 
270
   package Table_Support is new C640001_2 (C640001_0.Table);
271
 
272
   Sub_Ptr   : Table_Support.Proc_Ptr;
273
   My_List   : Table_Support.Op_List;
274
   My_Table1 : C640001_0.Table;             -- Initial values of both Row1 &
275
                                            -- Row2 are (T,F,T,F,T,F,T,F,T,F).
276
   My_Table2 : C640001_0.Table2;            -- Initial values of both Row1 &
277
                                            -- Row2 are (T,F,T,F,T,F,T,F,T,F).
278
begin
279
   Report.Test ("C640001", "Check that, for an access-to-subprogram type " &
280
                           "whose designated profile contains parameters " &
281
                           "of a tagged generic formal type, an access-" &
282
                           "to-subprogram value may designate dispatching " &
283
                           "and non-dispatching operations");
284
 
285
   --
286
   -- Add subprogram access values to list:
287
   --
288
 
289
   Sub_Ptr := C640001_0.Clear'Access;       -- Designates dispatching op.
290
   Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List).
291
 
292
   Sub_Ptr := C640001_1.Clear'Access;       -- Designates non-dispatching op.
293
   Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List).
294
 
295
   Sub_Ptr := C640001_0.Reset'Access;       -- Designates re-dispatching op.
296
   Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List).
297
 
298
 
299
   --
300
   -- Call dispatching operation:
301
   --
302
 
303
   Table_Support.Process_Operand (My_Table1, My_List, 1, 1);   -- Call 1st op.
304
 
305
   if not C640001_0.Is_False (My_Table1.Row1) then
306
      Report.Failed ("Wrong result after calling dispatching operation");
307
   end if;
308
 
309
 
310
   --
311
   -- Call non-dispatching operation:
312
   --
313
 
314
   Table_Support.Process_Operand (My_Table1, My_List, 2, 2);   -- Call 2nd op.
315
 
316
   if not C640001_0.Is_True (My_Table1.Row2) then
317
      Report.Failed ("Wrong result after calling non-dispatching operation");
318
   end if;
319
 
320
 
321
   --
322
   -- Call re-dispatching operation:
323
   --
324
 
325
   Table_Support.Process_Operand (C640001_0.Table(My_Table2),  -- View conv.
326
                                  My_List, 3, 3);              -- Call 3rd op.
327
 
328
   if not C640001_0.Is_True (My_Table2.Row1) then
329
      Report.Failed ("Wrong result after calling re-dispatching operation");
330
   end if;
331
 
332
 
333
   Report.Result;
334
end C640001;

powered by: WebSVN 2.1.0

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