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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- CC51006.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 primitive
28
--      subprogram of a formal (nontagged) derived type declares a view of
29
--      the corresponding primitive subprogram of the ancestor type, even if
30
--      the subprogram has been overridden for the actual type. Check that for
31
--      a formal derived type with no discriminant part, if the ancestor
32
--      subtype is an unconstrained scalar subtype then the actual may be
33
--      either constrained or unconstrained.
34
--
35
-- TEST DESCRIPTION:
36
--      The formal derived type has no discriminant part, but the ancestor
37
--      subtype is unconstrained, making the formal type unconstrained. Since
38
--      the ancestor subtype is a scalar subtype (not an access or composite
39
--      subtype), the actual may be either constrained or unconstrained.
40
--
41
--      Declare a root type of a class as an unconstrained scalar (use floating
42
--      point). Declare a primitive subprogram of the root type. Declare a
43
--      generic package which has a formal derived type with the scalar root
44
--      type as ancestor. Inside the generic, declare an operation which calls
45
--      the ancestor type's primitive subprogram. Derive both constrained and
46
--      unconstrained types from the root type and override the primitive
47
--      subprogram for each. Declare a constrained subtype of the unconstrained
48
--      derivative. Instantiate the generic package for the derived types and
49
--      the subtype and call the "generic" operation for each one. Confirm that
50
--      in all cases the root type's implementation of the primitive
51
--      subprogram is called.
52
--
53
--
54
-- CHANGE HISTORY:
55
--      06 Dec 94   SAIC    ACVC 2.0
56
--
57
--!
58
 
59
package CC51006_0 is  -- Weight class.
60
 
61
   type Weight_Type is digits 3;         -- Root type of class (unconstrained).
62
 
63
   function Weight_To_String (Wt : Weight_Type) return String;
64
 
65
   -- ... Other operations.
66
 
67
end CC51006_0;
68
 
69
 
70
     --==================================================================--
71
 
72
 
73
package body CC51006_0 is
74
 
75
   -- The implementations of the operations below are purely artificial; the
76
   -- validity of their implementations in the context of the abstraction is
77
   -- irrelevant to the feature being tested.
78
 
79
   function Weight_To_String (Wt : Weight_Type) return String is
80
   begin
81
      if Wt > 0.0 then         -- Always true for this test.
82
         return ("Root type's implementation called");
83
      else
84
         return ("Unexpected result                ");
85
      end if;
86
   end Weight_To_String;
87
 
88
end CC51006_0;
89
 
90
 
91
     --==================================================================--
92
 
93
 
94
with CC51006_0;  -- Weight class.
95
generic          -- Generic weight operations.
96
   type Weight is new CC51006_0.Weight_Type;
97
package CC51006_1 is
98
 
99
   procedure Output_Weight (Wt : in Weight; TC_Return : out String);
100
 
101
   -- ... Other operations.
102
 
103
end CC51006_1;
104
 
105
 
106
     --==================================================================--
107
 
108
 
109
package body CC51006_1 is
110
 
111
 
112
   -- The implementation of this procedure is purely artificial, and contains
113
   -- an artificial parameter for testing purposes: the procedure returns the
114
   -- weight string to the caller.
115
 
116
   procedure Output_Weight (Wt : in Weight; TC_Return : out String) is
117
   begin
118
      TC_Return := Weight_To_String (Wt);   -- Should always call root type's
119
   end Output_Weight;                       -- implementation.
120
 
121
 
122
end CC51006_1;
123
 
124
 
125
     --==================================================================--
126
 
127
 
128
with CC51006_0;       -- Weight class.
129
use  CC51006_0;
130
package CC51006_2 is  -- Extensions to weight class.
131
 
132
   type Grams is new Weight_Type;                         -- Unconstrained
133
                                                          -- derivative.
134
 
135
   function Weight_To_String (Wt : Grams) return String;  -- Overrides root
136
                                                          -- type's operation.
137
 
138
   subtype Milligrams is Grams                            -- Constrained
139
     range 0.0 .. 0.999;                                  -- subtype (of der.).
140
 
141
   type Pounds is new Weight_Type                         -- Constrained
142
     range 0.0 .. 500.0;                                  -- derivative.
143
 
144
   function Weight_To_String (Wt : Pounds) return String; -- Overrides root
145
                                                          -- type's operation.
146
 
147
end CC51006_2;
148
 
149
 
150
     --==================================================================--
151
 
152
 
153
package body CC51006_2 is
154
 
155
   -- The implementations of the operations below are purely artificial; the
156
   -- validity of their implementations in the context of the abstraction is
157
   -- irrelevant to the feature being tested.
158
 
159
   function Weight_To_String (Wt : Grams) return String is
160
   begin
161
      return ("GRAMS: Should never be called    ");
162
   end Weight_To_String;
163
 
164
 
165
   function Weight_To_String (Wt : Pounds) return String is
166
   begin
167
      return ("POUNDS: Should never be called   ");
168
   end Weight_To_String;
169
 
170
end CC51006_2;
171
 
172
 
173
     --==================================================================--
174
 
175
 
176
with CC51006_1; -- Generic weight operations.
177
with CC51006_2; -- Extensions to weight class.
178
 
179
with Report;
180
procedure CC51006 is
181
 
182
   package Metric_Wts_G  is new CC51006_1 (CC51006_2.Grams);      -- Unconstr.
183
   package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr.
184
   package US_Wts        is new CC51006_1 (CC51006_2.Pounds);     -- Constr.
185
 
186
   Gms : CC51006_2.Grams      := 113.451;
187
   Mgm : CC51006_2.Milligrams := 0.549;
188
   Lbs : CC51006_2.Pounds     := 24.52;
189
 
190
 
191
   subtype TC_Buffers is String (1 .. 33);
192
 
193
   TC_Expected : constant TC_Buffers := "Root type's implementation called";
194
   TC_Buffer   :          TC_Buffers;
195
 
196
begin
197
   Report.Test ("CC51006", "Check that, in an instance, each implicit "  &
198
                "declaration of a primitive subprogram of a formal "     &
199
                "(nontagged) type declares a view of the corresponding " &
200
                "primitive subprogram of the ancestor type");
201
 
202
 
203
   Metric_Wts_G.Output_Weight (Gms, TC_Buffer);
204
 
205
   if TC_Buffer /= TC_Expected then
206
      Report.Failed ("Root operation not called for unconstrained derivative");
207
   end if;
208
 
209
 
210
   Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer);
211
 
212
   if TC_Buffer /= TC_Expected then
213
      Report.Failed ("Root operation not called for constrained subtype");
214
   end if;
215
 
216
 
217
   US_Wts.Output_Weight (Lbs, TC_Buffer);
218
 
219
   if TC_Buffer /= TC_Expected then
220
      Report.Failed ("Root operation not called for constrained derivative");
221
   end if;
222
 
223
   Report.Result;
224
end CC51006;

powered by: WebSVN 2.1.0

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