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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C730003.A
2
--
3
--                             Grant of Unlimited Rights
4
--
5
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
6
--     F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
7
--     software and documentation contained herein.  Unlimited rights are
8
--     defined in DFAR 252.227-7013(a)(19).  By making this public release,
9
--     the Government intends to confer upon all recipients unlimited rights
10
--     equal to those held by the Government.  These rights include rights to
11
--     use, duplicate, release or disclose the released technical data and
12
--     computer software in whole or in part, in any manner and for any purpose
13
--     whatsoever, and to have or permit others to do so.
14
--
15
--                                    DISCLAIMER
16
--
17
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
18
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
19
--     WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
20
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
21
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
22
--     PARTICULAR PURPOSE OF SAID MATERIAL.
23
--*
24
--
25
-- OBJECTIVE:
26
--      Check that the characteristics of a type derived from a private
27
--      extension (outside the scope of the full view) are those defined by
28
--      the partial view of the private extension.
29
--      In particular, check that a component of the derived type may be
30
--      explicitly declared with the same name as a component declared for
31
--      the full view of the private extension.
32
--      Check that a component defined in the private extension of a type
33
--      may be updated through a view conversion of a type derived from
34
--      the type.
35
--
36
-- TEST DESCRIPTION:
37
--      Consider:
38
--
39
--      package Parent is
40
--         type T is tagged record
41
--            ...
42
--         end record;
43
--
44
--         type DT is new T with private;
45
--         procedure Op1 (P: in out DT);
46
--
47
--      private
48
--         type DT is new T with record
49
--            Y: ...;                                             -- (A)
50
--         end record;
51
--      end Parent;
52
--
53
--      package body Parent is
54
--         function Op1 (P: in DT) return ... is
55
--         begin
56
--            return P.Y;
57
--         end Op1;
58
--      end Parent;
59
--
60
--      package Unrelated is
61
--         type Intermediate is new DT with record
62
--            Y: ...;  -- Note: same name as component of         -- (B)
63
--                     --       parent's full view.
64
--         end record;
65
--      end Unrelated;
66
--
67
--      package Parent.Child is
68
--         type DDT is new Intermediate with null record;
69
--         -- Implicit declared Op1 (P.DDT);                      -- (C)
70
--
71
--         procedure Op2 (P: in out DDT);
72
--      end Parent.Child;
73
--
74
--      package body Parent.Child is
75
--         procedure Op2 (P: in out DDT) is
76
--            Obj : DT renames DT(P);
77
--         begin
78
--            ...
79
--            P.Y := ...;      -- Updates DDT's Y.                -- (D)
80
--            DT(P).Y := ...;  -- Updates DT's Y.                 -- (E)
81
--            Obj.Y := ...;    -- Updates DT's Y.                 -- (F)
82
--         end Op2;
83
--      end Parent.Child;
84
--
85
--      Types DT and DDT both declare a component Y at (A) and (B),
86
--      respectively. The component Y of the full view of DT is not visible
87
--      at the place where DDT is declared. Therefore, it is invisible for
88
--      all views of DDT (although it still exists for objects of DDT), and
89
--      it is legal to declare another component for DDT with the same name.
90
--
91
--      DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns
92
--      the component Y; for calls with an operand of type DDT, Op1 returns
93
--      the Y inherited from DT, not the new Y explicitly declared for DDT,
94
--      even though the inherited Y is not visible for any view of DDT.
95
--
96
--      Within the body of Op2, the assignment statement at (D) updates the
97
--      Y explicitly declared for DDT. At (E) and (F), however, a view
98
--      conversion denotes a new view of P as an object of type DT, which
99
--      enables access to the Y from the full view of DT. Thus, the
100
--      assignment statements at (E) and (F) update the (invisible) Y from DT.
101
--
102
--      Note that the above analysis would be wrong if the new component Y
103
--      were declared directly in Child.  In that case, the two same-named
104
--      components would be illegal -- see AI-150.
105
--
106
--
107
-- CHANGE HISTORY:
108
--      06 Dec 1994   SAIC    ACVC 2.0
109
--      29 JUN 1999   RAD     Declare same-named component in an
110
--                            unrelated package -- see AI-150.
111
--
112
--!
113
 
114
package C730003_0 is
115
 
116
   type Suit_Kind is (Clubs, Diamonds, Hearts, Spades);
117
   type Face_Kind is (Up, Down);
118
 
119
   type Playing_Card is tagged record
120
      Face: Face_Kind;
121
      Suit: Suit_Kind;
122
   end record;
123
 
124
   procedure Turn_Over_Card (Card : in out Playing_Card);
125
 
126
   type Disp_Card is new Playing_Card with private;
127
 
128
   subtype ASCII_Representation is Natural range 1..14;
129
 
130
   function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation;
131
 
132
private
133
 
134
   type Disp_Card is new Playing_Card with record
135
      View: ASCII_Representation;                                       -- (A)
136
   end record;
137
 
138
end C730003_0;
139
 
140
--==================================================================--
141
 
142
package body C730003_0 is
143
 
144
   procedure Turn_Over_Card (Card: in out Playing_Card) is
145
   begin
146
      Card.Face := Up;
147
   end Turn_Over_Card;
148
 
149
   function Get_Private_View (A_Card : Disp_Card)
150
     return ASCII_Representation is
151
   begin
152
      return A_Card.View;
153
   end Get_Private_View;
154
 
155
end C730003_0;
156
 
157
--==================================================================--
158
 
159
with C730003_0; use C730003_0;
160
package C730003_1 is
161
 
162
   subtype Graphic_Representation is String (1 .. 2);
163
 
164
   type Graphic_Card is new Disp_Card with record
165
      View : Graphic_Representation;                                    -- (B)
166
                                          -- "Duplicate" component field name.
167
   end record;
168
 
169
end C730003_1;
170
 
171
--==================================================================--
172
 
173
with C730003_1; use C730003_1;
174
package C730003_0.C730003_2 is
175
 
176
   Queen_Of_Spades   : constant C730003_0.ASCII_Representation := 12;
177
   Ace_Of_Hearts     : constant String := "AH";
178
   Close_To_The_Vest : constant C730003_0.ASCII_Representation := 14;
179
   Read_Em_And_Weep  : constant String := "AA";
180
 
181
   type Graphic_Card is new C730003_1.Graphic_Card with null record;
182
 
183
   -- Implicit function Get_Private_View                                -- (C)
184
   --           (A_Card : Graphic_Card) return C730003_0.ASCII_Representation;
185
 
186
   function  Get_View       (Card : Graphic_Card) return String;
187
   procedure Update_View    (Card : in out Graphic_Card);
188
   procedure Hide_From_View (Card : in out Graphic_Card);
189
 
190
end C730003_0.C730003_2;
191
 
192
--==================================================================--
193
 
194
package body C730003_0.C730003_2 is
195
 
196
   function Get_View (Card : Graphic_Card) return String is
197
   begin
198
      return Card.View;
199
   end Get_View;
200
 
201
   procedure Update_View (Card : in out Graphic_Card) is
202
      ASCII_View      : Disp_Card renames Disp_Card(Card); -- View conversion.
203
   begin
204
      ASCII_View.View := Queen_Of_Spades;                               -- (F)
205
                                              -- Assignment to "hidden" field.
206
      Card.View       := Ace_Of_Hearts;                                 -- (D)
207
                                 -- Assignment to Graphic_Card declared field.
208
   end Update_View;
209
 
210
   procedure Hide_From_View (Card : in out Graphic_Card) is
211
   begin
212
      -- Update both of Card's View components.
213
      Disp_Card(Card).View := Close_To_The_Vest;                        -- (E)
214
                                              -- Assignment to "hidden" field.
215
      Card.View            := Read_Em_And_Weep;                         -- (D)
216
                                 -- Assignment to Graphic_Card declared field.
217
   end Hide_From_View;
218
 
219
end C730003_0.C730003_2;
220
 
221
--==================================================================--
222
 
223
with C730003_0;
224
with C730003_0.C730003_2;
225
with Report;
226
 
227
procedure C730003 is
228
begin
229
 
230
   Report.Test ("C730003", "Check that the characteristics of a type "   &
231
                           "derived from a private extension (outside "  &
232
                           "the scope of the full view) are those "      &
233
                           "defined by the partial view of the private " &
234
                           "extension");
235
 
236
   Check_Your_Cards:
237
   declare
238
      use C730003_0;
239
      use C730003_0.C730003_2;
240
 
241
      Top_Card_On_The_Deck : Graphic_Card;
242
 
243
   begin
244
 
245
      -- Update value in the components of the card.  There are two
246
      -- component fields named View, although one is not visible for
247
      -- any view of a Graphic_Card.
248
 
249
      Update_View(Top_Card_On_The_Deck);
250
 
251
      -- Verify that both "View" components of the card have been updated.
252
 
253
      if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then
254
         Report.Failed ("Incorrect value in visible component - 1");
255
      end if;
256
 
257
      if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades
258
      then
259
         Report.Failed ("Incorrect value in non-visible component - 1");
260
      end if;
261
 
262
      -- Again, update the components of the card (to blank values).
263
 
264
      Hide_From_View(Top_Card_On_The_Deck);
265
 
266
      -- Verify that both components have been updated.
267
 
268
      if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then
269
         Report.Failed ("Incorrect value in visible component - 2");
270
      end if;
271
 
272
      if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest
273
      then
274
         Report.Failed ("Incorrect value in non-visible component - 2");
275
      end if;
276
 
277
   exception
278
      when others => Report.Failed("Exception raised in test block");
279
   end Check_Your_Cards;
280
 
281
   Report.Result;
282
 
283
end C730003;

powered by: WebSVN 2.1.0

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