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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C3A0007.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 call to a subprogram via an access-to-subprogram value
28
--      stored in a data structure will correctly dispatch according to the
29
--      tag of the class-wide parameter passed via that call.
30
--
31
-- TEST DESCRIPTION:
32
--      Declare an access to procedure type in a package specification.
33
--      Declare a root tagged type with the access to procedure type as a
34
--      component.  Declare three primitive procedures for the type that
35
--      can be referred to by the access to procedure type.  Use the access
36
--      to procedure type to initialize the component of a record.
37
--
38
--      Extend the root type with a record extension in another package
39
--      specification. Declare a new primitive procedure for the extension
40
--      (in addition to its three inherited subprograms).
41
--
42
--      In the main program, declare an operation for the root tagged type
43
--      which can be passed as an access value to change the initial value
44
--      of the component.  Call the inherited operation indirectly by
45
--      dereferencing the access value to check on the initial value of the
46
--      extension.  Call inherited operations indirectly by dereferencing
47
--      the access value to replace the initial value.  Call the primitive
48
--      procedure indirectly by dereferencing the access value to modify the
49
--      extension.
50
--
51
--          type Button
52
--            procedure Push(Button)
53
--            procedure Set_Response(Button,Button_Response_Ptr)
54
--            procedure Default_Response(Button)
55
--
56
--          type Priority_Button (new Button)
57
--            procedures Push, Set_Response inherited
58
--            procedure Default_Response
59
--            procedure Set_Priority
60
--
61
--
62
-- CHANGE HISTORY:
63
--      06 Dec 94   SAIC    ACVC 2.0
64
--
65
--!
66
 
67
package C3A0007_0 is
68
 
69
   Default_Call   : Boolean := False;
70
 
71
   type Button is tagged private;
72
 
73
   type Button_Response_Ptr is access procedure
74
      (B : in out Button'Class);
75
 
76
   procedure Push (B : in out Button);               -- to be inherited
77
 
78
   procedure Set_Response (B : in out Button;        -- to be inherited
79
                           R : in Button_Response_Ptr);
80
 
81
   procedure Response  (B : in out Button);          -- to be inherited
82
 
83
private
84
   procedure Default_Response(B: in out Button'Class);
85
   type Button is tagged                             -- root tagged type
86
      record
87
         Action :  Button_Response_Ptr
88
                  := Default_Response'Access;
89
      end record;
90
end C3A0007_0;
91
 
92
with C3A0007_0;
93
package C3A0007_1 is
94
 
95
   type Priority_Button is new C3A0007_0.Button
96
     with record
97
        Priority : Integer := 0;
98
      end record;
99
 
100
   -- Inherits procedure Push from Button
101
   -- Inherits procedure Set_Response from Button
102
 
103
   -- Override procedure Response from Button
104
   procedure Response (B : in out Priority_Button);
105
 
106
   -- Primitive operation of the extension
107
   procedure Set_Priority (B : in out Priority_Button);
108
 
109
end C3A0007_1;
110
 
111
with C3A0007_0;
112
package C3A0007_2 is
113
 
114
   Emergency_Call : Boolean := False;
115
 
116
   procedure Emergency (B : in out C3A0007_0.Button'Class);
117
end C3A0007_2;
118
 
119
-----------------------------------------------------------------------------
120
 
121
with TCTouch;
122
package body C3A0007_0 is
123
 
124
   procedure Push (B : in out Button) is
125
   begin
126
      TCTouch.Touch( 'P' ); --------------------------------------------- P
127
      -- Invoking subprogram designated by access value
128
      B.Action (B);
129
   end Push;
130
 
131
 
132
   procedure Set_Response (B : in out Button;
133
                           R : in     Button_Response_Ptr) is
134
   begin
135
      TCTouch.Touch( 'S' ); --------------------------------------------- S
136
      -- Set procedure value in record
137
      B.Action := R;
138
   end Set_Response;
139
 
140
 
141
   procedure Response (B : in out Button) is
142
   begin
143
      TCTouch.Touch( 'D' ); --------------------------------------------- D
144
      Default_Call := True;
145
   end Response;
146
 
147
   procedure Default_Response (B : in out Button'Class) is
148
   begin
149
      TCTouch.Touch( 'C' ); --------------------------------------------- C
150
      Response(B);
151
   end Default_Response;
152
 
153
end C3A0007_0;
154
 
155
with TCTouch;
156
package body C3A0007_1 is
157
 
158
   procedure Set_Priority (B : in out Priority_Button) is
159
   begin
160
      TCTouch.Touch( 's' ); --------------------------------------------- s
161
      B.Priority := 1;
162
   end Set_Priority;
163
 
164
   procedure Response (B : in out Priority_Button) is
165
   begin
166
      TCTouch.Touch( 'd' ); --------------------------------------------- d
167
   end Response;
168
 
169
end C3A0007_1;
170
 
171
with TCTouch;
172
package body C3A0007_2 is
173
   procedure Emergency (B : in out C3A0007_0.Button'Class) is
174
      begin
175
        TCTouch.Touch( 'E' ); ------------------------------------------- E
176
        Emergency_Call := True;
177
      end Emergency;
178
end C3A0007_2;
179
 
180
-----------------------------------------------------------------------------
181
 
182
with Report;
183
with TCTouch;
184
 
185
with C3A0007_0;
186
with C3A0007_1;
187
with C3A0007_2;
188
procedure C3A0007 is
189
 
190
   Pink_Button  : C3A0007_0.Button;
191
   Green_Button : C3A0007_1.Priority_Button;
192
 
193
begin
194
 
195
   Report.Test ("C3A0007", "Check that a call to a subprogram via an "
196
                         & "access-to-subprogram value stored in a data "
197
                         & "structure will correctly dispatch according to "
198
                         & "the tag of the class-wide parameter passed "
199
                         & "via that call" );
200
 
201
   -- Call inherited operation Push to set Default_Response value
202
   -- in the extension.
203
 
204
   C3A0007_1.Push (Green_Button);
205
   TCTouch.Validate("PCd", "First Green Button Push");
206
 
207
   TCTouch.Assert_Not(C3A0007_0.Default_Call,
208
                         "Incorrect Green Default_Response");
209
 
210
   C3A0007_0.Push (Pink_Button);
211
   TCTouch.Validate("PCD", "First Pink Button Push");
212
 
213
   -- Call inherited operations Set_Response and Push to set
214
   -- Emergency value in the extension.
215
   C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access);
216
   C3A0007_1.Push (Green_Button);
217
   TCTouch.Validate("SPE", "Second Green Button Push");
218
 
219
   TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency");
220
 
221
   C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access);
222
   C3A0007_0.Push (Pink_Button);
223
   TCTouch.Validate("SPE", "Second Pink Button Push");
224
 
225
   -- Call primitive operation to set priority value
226
   -- in the extension.
227
   C3A0007_1.Set_Priority (Green_Button);
228
   TCTouch.Validate("s", "Green Button Priority");
229
 
230
   TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority");
231
 
232
   Report.Result;
233
 
234
end C3A0007;

powered by: WebSVN 2.1.0

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