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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- CC50001.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 predefined
28
--      operator of a formal tagged private type declares a view of the
29
--      corresponding predefined operator of the actual type (even if the
30
--      operator has been overridden for the actual type). Check that the
31
--      body executed is determined by the type and tag of the operands.
32
--
33
-- TEST DESCRIPTION:
34
--      The formal tagged private type has an unknown discriminant part, and
35
--      is thus indefinite. This allows both definite and indefinite types
36
--      to be passed as actuals. For tagged types, definite implies
37
--      nondiscriminated, and indefinite implies discriminated (with known
38
--      or unknown discriminants).
39
--
40
--      Only nonlimited tagged types are tested, since equality operators
41
--      are not predefined for limited types.
42
--
43
--      A tagged type is passed as an actual to a generic formal tagged
44
--      private type. The tagged type overrides the predefined equality
45
--      operator. A subprogram within the generic calls the equality operator
46
--      of the formal type. In an instance, the equality operator denotes
47
--      a view of the predefined operator of the actual type, but the
48
--      call dispatches to the body of the overriding operator.
49
--
50
--
51
-- CHANGE HISTORY:
52
--      06 Dec 94   SAIC    ACVC 2.0
53
--      21 Nov 95   SAIC    ACVC 2.0.1 fixes: Corrected expected result on
54
--                          calls to "=" within the instance. Modified
55
--                          commentary.
56
--
57
--!
58
 
59
package CC50001_0 is
60
 
61
   type Count_Type is tagged record                     -- Nondiscriminated
62
      Count : Integer := 0;                             -- tagged type.
63
   end record;
64
 
65
   function "="(Left, Right : Count_Type)               -- User-defined
66
     return Boolean;                                    -- equality operator.
67
 
68
 
69
   subtype Str_Len is Natural range 0 .. 100;
70
   subtype Stu_ID  is String (1 .. 5);
71
   subtype Dept_ID is String (1 .. 4);
72
   subtype Emp_ID  is String (1 .. 9);
73
   type    Status   is (Student, Faculty, Staff);
74
 
75
   type Person_Type (Stat : Status;                     -- Discriminated
76
                     NameLen, AddrLen : Str_Len) is     -- tagged type.
77
     tagged record
78
      Name    : String (1 .. NameLen);
79
      Address : String (1 .. AddrLen);
80
      case Stat is
81
         when Student =>
82
            Student_ID  : Stu_ID;
83
         when Faculty =>
84
            Department  : Dept_ID;
85
         when Staff   =>
86
            Employee_ID : Emp_ID;
87
      end case;
88
   end record;
89
 
90
   function "="(Left, Right : Person_Type)              -- User-defined
91
     return Boolean;                                    -- equality operator.
92
 
93
 
94
   -- Testing entities: ------------------------------------------------
95
 
96
   TC_Count_Item     : constant Count_Type  := (Count => 111);
97
 
98
   TC_Person_Item    : constant Person_Type :=
99
     (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931");
100
 
101
   ---------------------------------------------------------------------
102
 
103
 
104
end CC50001_0;
105
 
106
 
107
     --===================================================================--
108
 
109
 
110
package body CC50001_0 is
111
 
112
   function "="(Left, Right : Count_Type) return Boolean is
113
   begin
114
      return False;   -- Return FALSE even if Left = Right.
115
   end "=";
116
 
117
 
118
   function "="(Left, Right : Person_Type) return Boolean is
119
   begin
120
      return False;   -- Return FALSE even if Left = Right.
121
   end "=";
122
 
123
end CC50001_0;
124
 
125
 
126
     --===================================================================--
127
 
128
 
129
with CC50001_0;  -- Tagged (actual) type declarations.
130
generic        -- Generic stack abstraction.
131
 
132
   type Item (<>) is tagged private;            -- Formal tagged private type.
133
 
134
package CC50001_1 is
135
 
136
   -- Simulate a generic stack abstraction. In a real application, the
137
   -- second operand of Push might be of type Stack, and type Stack
138
   -- would have at least one component (pointing to the top stack item).
139
 
140
   type Stack is private;
141
 
142
   procedure Push (I : in Item; TC_Check : out Boolean);
143
 
144
   -- ... Other stack operations.
145
 
146
private
147
 
148
   -- ... Stack and ancillary type declarations.
149
 
150
   type Stack is record                       -- Artificial.
151
      null;
152
   end record;
153
 
154
end CC50001_1;
155
 
156
 
157
     --===================================================================--
158
 
159
 
160
package body CC50001_1 is
161
 
162
   -- For the sake of brevity, the implementation of Push is completely
163
   -- artificial; the goal is to model a call of the equality operator within
164
   -- the generic.
165
   --
166
   -- A real application might implement Push such that it does not add new
167
   -- items to the stack if they are identical to the top item; in that
168
   -- case, the equality operator would be called as part of an "if"
169
   -- condition.
170
 
171
   procedure Push (I : in Item; TC_Check : out Boolean) is
172
   begin
173
      TC_Check := not (I = I);              -- Call user-defined "="; should
174
                                            -- return FALSE. Negation of
175
                                            -- result makes TC_Check TRUE.
176
   end Push;
177
 
178
end CC50001_1;
179
 
180
 
181
     --==================================================================--
182
 
183
 
184
with CC50001_0;  -- Tagged (actual) type declarations.
185
with CC50001_1;  -- Generic stack abstraction.
186
 
187
use  CC50001_0;  -- Overloaded "=" directly visible.
188
 
189
with Report;
190
procedure CC50001 is
191
 
192
   package Count_Stacks  is new CC50001_1 (CC50001_0.Count_Type);
193
   package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type);
194
 
195
   User_Defined_Op_Called : Boolean;
196
 
197
begin
198
   Report.Test ("CC50001", "Check that, in an instance, each implicit "     &
199
                "declaration of a primitive subprogram of a formal tagged " &
200
                "private type declares a view of the corresponding "        &
201
                "predefined operator of the actual type (even if the "      &
202
                "operator has been overridden or hidden for the actual type)");
203
 
204
--
205
-- Test which "=" is called inside generic:
206
--
207
 
208
   User_Defined_Op_Called := False;
209
 
210
   Count_Stacks.Push (CC50001_0.TC_Count_Item,
211
                      User_Defined_Op_Called);
212
 
213
 
214
   if not User_Defined_Op_Called then
215
      Report.Failed ("User-defined ""="" not called inside generic for Count");
216
   end if;
217
 
218
 
219
   User_Defined_Op_Called := False;
220
 
221
   Person_Stacks.Push (CC50001_0.TC_Person_Item,
222
                       User_Defined_Op_Called);
223
 
224
   if not User_Defined_Op_Called then
225
      Report.Failed ("User-defined ""="" not called inside generic " &
226
                     "for Person");
227
   end if;
228
 
229
 
230
--
231
-- Test which "=" is called outside generic:
232
--
233
 
234
   User_Defined_Op_Called := False;
235
 
236
   User_Defined_Op_Called :=
237
     not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item);
238
 
239
   if not User_Defined_Op_Called then
240
      Report.Failed ("User-defined ""="" not called outside generic "&
241
                     "for Count");
242
   end if;
243
 
244
 
245
   User_Defined_Op_Called := False;
246
 
247
   User_Defined_Op_Called :=
248
     not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item);
249
 
250
   if not User_Defined_Op_Called then
251
      Report.Failed ("User-defined ""="" not called outside generic "&
252
                     "for Person");
253
   end if;
254
 
255
 
256
   Report.Result;
257
end CC50001;

powered by: WebSVN 2.1.0

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