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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc51d02.a] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- CC51D02.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, in an instance, each implicit declaration of a user-defined
28
--      subprogram of a formal private extension declares a view of the
29
--      corresponding primitive subprogram of the ancestor, and that if the
30
--      tag in a call is statically determined to be that of the formal type,
31
--      the body executed will be that corresponding to the actual type.
32
--
33
--      Check subprograms declared within a generic formal package. Check for
34
--      the case where the actual type passed to the formal private extension
35
--      is a class-wide type. Check for several types in the same class.
36
--
37
--
38
-- TEST DESCRIPTION:
39
--      Declare a list abstraction in a generic package which manages lists of
40
--      elements of any nonlimited type (foundation code). Declare a package
41
--      which declares a tagged type and a derivative. Declare an operation
42
--      for the root tagged type and override it for the derivative. Declare
43
--      a generic subprogram which operates on lists of elements of tagged
44
--      types. Provide the generic subprogram with two formal parameters: (1)
45
--      a formal derived tagged type which represents a list element type, and
46
--      (2) a generic formal package with the list abstraction package as
47
--      template. Use the formal derived type as the generic formal actual
48
--      part for the formal package. Within the generic subprogram, call the
49
--      operation of the root tagged type. In the main program, instantiate
50
--      the generic list package and the generic subprogram with the class-wide
51
--      type for the root tagged type.
52
--
53
-- TEST FILES:
54
--      The following files comprise this test:
55
--
56
--         FC51D00.A
57
--      -> CC51D02.A
58
--
59
--
60
-- CHANGE HISTORY:
61
--      06 Dec 94   SAIC    ACVC 2.0
62
--      05 Jan 95   SAIC    Changed types of TC_Expected_1 and TC_Expected_2
63
--                          from specific to class-wide. Eliminated (illegal)
64
--                          assignment step prior to comparison of
65
--                          TC_Expected_X with item on stack.
66
--
67
--!
68
 
69
package CC51D02_0 is -- This package simulates support for a personnel
70
                     -- database.
71
 
72
   type SSN_Type is new String (1 .. 9);
73
 
74
   type Blind_ID_Type is tagged record                   -- Root type of
75
      SSN : SSN_Type;                                    -- class.
76
      -- ... Other components.
77
   end record;
78
 
79
   procedure Update_ID (Item : in out Blind_ID_Type);    -- Parent operation.
80
 
81
   -- ... Other operations.
82
 
83
 
84
   type Name_Type is new String (1 .. 9);
85
 
86
   type Named_ID_Type is new Blind_ID_Type with record   -- Direct derivative
87
      Name : Name_Type := "Doe      ";                   -- of root type.
88
      -- ... Other components.
89
   end record;
90
 
91
   -- Inherits Update_ID from parent.
92
 
93
   procedure Update_ID (Item : in out Named_ID_Type);    -- Overrides parent's
94
                                                         -- implementation.
95
 
96
end CC51D02_0;
97
 
98
 
99
     --==================================================================--
100
 
101
 
102
package body CC51D02_0 is
103
 
104
   -- The implementations of Update_ID are purely artificial; the validity of
105
   -- their implementations in the context of the abstraction is irrelevant to
106
   -- the feature being tested.
107
 
108
   procedure Update_ID (Item : in out Blind_ID_Type) is
109
   begin
110
      Item.SSN := "111223333";
111
   end Update_ID;
112
 
113
 
114
   procedure Update_ID (Item : in out Named_ID_Type) is
115
   begin
116
      Item.SSN := "444556666";
117
      -- ... Other stuff.
118
   end Update_ID;
119
 
120
end CC51D02_0;
121
 
122
 
123
     --==================================================================--
124
 
125
 
126
--                           --
127
-- Formal package used here. --
128
--                           --
129
 
130
with FC51D00;    -- Generic list abstraction.
131
with CC51D02_0;  -- Tagged type declarations.
132
generic          -- This procedure simulates a generic operation for types
133
                 -- in the class rooted at Blind_ID_Type.
134
   type Elem_Type (<>) is new CC51D02_0.Blind_ID_Type with private;
135
   with package List_Mgr is new FC51D00 (Elem_Type);
136
procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
137
 
138
 
139
     --==================================================================--
140
 
141
 
142
-- The implementation of CC51D02_1 is purely artificial; the validity
143
-- of its implementation in the context of the abstraction is irrelevant
144
-- to the feature being tested.
145
--
146
-- The expected behavior here is as follows: for each actual type corresponding
147
-- to Elem_Type, the call to Update_ID should invoke the actual type's
148
-- implementation (based on the tag of the actual), which updates the object's
149
-- SSN field. Write_Element then adds the object to the list.
150
 
151
procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
152
   Element : Elem_Type := E;   -- Can't update IN parameter.
153
                               -- Initialization of unconstrained variable.
154
begin
155
   Update_ID (Element);                    -- Executes actual type's version
156
                                           -- (for this test, this will be a
157
                                           -- dispatching call).
158
   List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version
159
                                           -- (for this test, this will be a
160
                                           -- class-wide operation).
161
end CC51D02_1;
162
 
163
 
164
     --==================================================================--
165
 
166
 
167
with FC51D00;    -- Generic list abstraction.
168
with CC51D02_0;  -- Tagged type declarations.
169
with CC51D02_1;  -- Generic operation.
170
 
171
with Report;
172
procedure CC51D02 is
173
 
174
   use CC51D02_0;                                        -- All types & ops
175
                                                         -- directly visible.
176
 
177
   -- Begin test code declarations: -----------------------
178
 
179
   TC_Expected_1 : Blind_ID_Type'Class :=
180
                   Blind_ID_Type'(SSN => "111223333");
181
   TC_Expected_2 : Blind_ID_Type'Class :=
182
                   Named_ID_Type'("444556666", "Doe      ");
183
 
184
 
185
   TC_Initial_1  : Blind_ID_Type       := (SSN => "777889999");
186
   TC_Initial_2  : Named_ID_Type       := ("777889999", "Doe      ");
187
   TC_Initial_3  : Blind_ID_Type'Class := TC_Initial_2;
188
 
189
   -- End test code declarations. -------------------------
190
 
191
 
192
   package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class);
193
 
194
   procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class,
195
                                                ID_Class_Lists);
196
 
197
   Blind_List  : ID_Class_Lists.List_Type;
198
   Named_List  : ID_Class_Lists.List_Type;
199
   Maimed_List : ID_Class_Lists.List_Type;
200
 
201
 
202
begin
203
   Report.Test ("CC51D02", "Formal private extension, class-wide actual: " &
204
                "body of primitive subprogram executed is that of actual " &
205
                "type. Check for subprograms declared in formal package");
206
 
207
 
208
   Update_and_Write (Blind_List, TC_Initial_1);    -- Test root type actual.
209
 
210
   if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then
211
      Report.Failed ("Result for root type actual is not in proper class");
212
   elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
213
      Report.Failed ("Wrong result for root type actual");
214
   end if;
215
 
216
 
217
   Update_and_Write (Named_List, TC_Initial_2);    -- Test derived type actual.
218
 
219
   if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then
220
      Report.Failed ("Result for derived type actual is not in proper class");
221
   elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then
222
      Report.Failed ("Wrong result for derived type actual");
223
   end if;
224
 
225
 
226
   -- In the subtest below, an object of a class-wide type (TC_Initial_3) is
227
   -- passed to Update_and_Write. It has been initialized with an object of
228
   -- type Named_ID_Type, so the result should be identical to
229
   -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that
230
   -- a new list of Named IDs is used (Maimed_List). This is to assure test
231
   -- validity, since Named_List has already been updated by a previous
232
   -- subtest.
233
 
234
   Update_and_Write (Maimed_List, TC_Initial_3);   -- Test class-wide actual.
235
 
236
   if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then
237
      Report.Failed ("Result for class-wide actual is not in proper class");
238
   elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then
239
      Report.Failed ("Wrong result for class-wide actual");
240
   end if;
241
 
242
 
243
   Report.Result;
244
end CC51D02;

powered by: WebSVN 2.1.0

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