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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C392D02.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 a primitive procedure declared in a private part is not
28
--      overridden by a procedure explicitly declared at a place where the
29
--      primitive procedure in question is not visible.
30
--
31
--      Check for the case where the non-overriding operation is declared in a
32
--      separate (non-child) package from that declaring the parent type, and
33
--      the descendant type is a record extension.
34
--
35
-- TEST DESCRIPTION:
36
--      Consider:
37
--
38
--      package P is
39
--         type Root is tagged ...
40
--      private
41
--         procedure Pri_Op (A: Root);
42
--      end P;
43
--
44
--      with P;
45
--      package Q is
46
--         type Derived is new P.Root with record...
47
--         procedure Pri_Op (A: Derived);  -- Does NOT override parent's Op.
48
--         ...
49
--      end Q;
50
--
51
--      Type Derived inherits Pri_Op from the parent type Root. However,
52
--      because P.Pri_Op is never visible within the immediate scope of
53
--      Derived, it is not implicitly declared for Derived. As a result,
54
--      the explicit Q.Pri_Op does not override P.Pri_Op and is totally
55
--      unrelated to it.
56
--
57
--      Dispatching calls to P.Pri_Op with operands of tag Derived will
58
--      not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op.
59
--
60
-- TEST FILES:
61
--      The following files comprise this test:
62
--
63
--         F392D00.A
64
--         C392D02.A
65
--
66
--
67
-- CHANGE HISTORY:
68
--      06 Dec 94   SAIC    ACVC 2.0
69
--
70
--!
71
 
72
with F392D00;
73
package C392D02_0 is
74
 
75
   type Aperture is (Eight, Sixteen);
76
 
77
   type Auto_Speed is new F392D00.Remote_Camera with record
78
      -- ...
79
      FStop : Aperture;
80
   end record;
81
 
82
 
83
   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
84
                                Speed : in     F392D00.Shutter_Speed);
85
                                                   -- Does NOT override.
86
 
87
   -- This version of Set_Shutter_Speed does NOT override the operation
88
   -- inherited from the parent, because the inherited operation is never
89
   -- visible (and thus, is never implicitly declared) within the immediate
90
   -- scope of type Auto_Speed.
91
 
92
   procedure Self_Test (C : in out Auto_Speed'Class);
93
 
94
   -- ...Other operations.
95
 
96
end C392D02_0;
97
 
98
 
99
     --==================================================================--
100
 
101
 
102
package body C392D02_0 is
103
 
104
   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
105
                                Speed : in     F392D00.Shutter_Speed) is
106
   begin
107
      -- Artificial for testing purposes.
108
      C.Shutter := F392D00.Four_Hundred;
109
   end Set_Shutter_Speed;
110
 
111
   ----------------------------------------------------
112
   procedure Self_Test (C : in out Auto_Speed'Class) is
113
   begin
114
      -- Should dispatch to the Set_Shutter_Speed explicitly declared
115
      -- for Auto_Speed.
116
      Set_Shutter_Speed (C, F392D00.Two_Fifty);
117
   end Self_Test;
118
 
119
end C392D02_0;
120
 
121
 
122
     --==================================================================--
123
 
124
 
125
with F392D00;
126
with C392D02_0;
127
 
128
with Report;
129
 
130
procedure C392D02 is
131
   Basic_Camera : F392D00.Remote_Camera;
132
   Auto_Camera1 : C392D02_0.Auto_Speed;
133
   Auto_Camera2 : C392D02_0.Auto_Speed;
134
 
135
   TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed
136
                           := F392D00.Thousand;
137
   TC_Expected_Speed       : constant F392D00.Shutter_Speed
138
                           := F392D00.Four_Hundred;
139
 
140
   use type F392D00.Shutter_Speed;
141
 
142
begin
143
   Report.Test ("C392D02", "Dispatching for non-overridden primitive " &
144
                "subprograms: record extension declared in non-child " &
145
                "package, parent is tagged record");
146
 
147
-- Call the class-wide operation for Remote_Camera'Class, which dispatches
148
-- to Set_Shutter_Speed:
149
 
150
   -- For an object of type Remote_Camera, the dispatching call should
151
   -- dispatch to the body declared for the root type:
152
 
153
   F392D00.Self_Test(Basic_Camera);
154
 
155
   if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then
156
      Report.Failed ("Call dispatched incorrectly for root type");
157
   end if;
158
 
159
 
160
   -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test,
161
   -- since C392D02_0.Set_Shutter_Speed does not override
162
   -- F392D00.Set_Shutter_Speed.
163
 
164
   -- For an object of type Auto_Speed, the dispatching call should
165
   -- also dispatch to the body declared for the root type:
166
 
167
   F392D00.Self_Test(Auto_Camera1);
168
 
169
   if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then
170
      Report.Failed ("Call dispatched incorrectly for derived type");
171
   end if;
172
 
173
   -- Call to Self_Test from C392D02_0 invokes the dispatching call to
174
   -- Set_Shutter_Speed which should dispatch to the body explicitly declared
175
   -- for Auto_Speed:
176
 
177
   C392D02_0.Self_Test(Auto_Camera2);
178
 
179
   if Auto_Camera2.Shutter /= TC_Expected_Speed then
180
      Report.Failed ("Call to explicit subprogram executed the wrong body");
181
   end if;
182
 
183
   Report.Result;
184
 
185
end C392D02;

powered by: WebSVN 2.1.0

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