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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C3A0009.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 subprogram references may be passed as parameters using
28
--      access-to-subprogram types. Check that the passed subprograms may
29
--      be invoked from within the called subprogram.
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 private extension in the same package
39
--      specification. Declare two new primitive subprograms 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 operations indirectly by
45
--      de-referencing the access value to set value in the extension.
46
--      Call the primitive function to modify the extension by passing
47
--      the access value designating the primitive procedure as a parameter.
48
--
49
--
50
-- CHANGE HISTORY:
51
--      06 Dec 94   SAIC    ACVC 2.0
52
--
53
--!
54
 
55
package C3A0009_0 is -- Push_Buttons
56
 
57
   type Button is tagged private;
58
 
59
   -- Type accesses to procedures Push and Default_Response
60
   type Button_Response_Ptr is access procedure
61
      (B : in out Button);
62
 
63
   procedure Push (B : in out Button);               -- to be inherited
64
 
65
   procedure Set_Response (B : in out Button;        -- to be inherited
66
                           R : in Button_Response_Ptr);
67
 
68
   procedure Default_Response  (B : in out Button);  -- to be inherited
69
 
70
   type Alert_Button is new Button with private;  -- private extension of
71
                                                  -- root tagged type
72
   -- Inherits procedure Push from Button
73
   -- Inherits procedure Set_Response from Button
74
   -- Inherits procedure Default_Response from Button
75
 
76
   procedure Replace_Action( B: in out Alert_Button );
77
 
78
   -- type accesses to procedure Default_Action
79
   type Button_Action_Ptr is access procedure;
80
 
81
   -- The following function is needed to set value in the
82
   -- extension's private component.
83
   function Alert (B : in Alert_Button) return Button_Action_Ptr;
84
 
85
private
86
 
87
   type Button is tagged                             -- root tagged type
88
      record
89
         Response :  Button_Response_Ptr
90
                  := Default_Response'Access;
91
      end record;
92
 
93
   procedure Default_Action;
94
 
95
   type Alert_Button is new Button with record
96
        Action :  Button_Action_Ptr
97
               := Default_Action'Access;
98
      end record;
99
 
100
end C3A0009_0;
101
 
102
 
103
-----------------------------------------------------------------------------
104
 
105
 
106
with TCTouch;
107
package body C3A0009_0 is
108
 
109
   procedure Push (B : in out Button) is
110
   begin
111
      TCTouch.Touch( 'P' ); --------------------------------------------- P
112
      -- Invoking subprogram designated by access value
113
      B.Response (B);
114
   end Push;
115
 
116
 
117
   procedure Set_Response (B : in out Button;
118
                           R : in     Button_Response_Ptr) is
119
   begin
120
      TCTouch.Touch( 'S' ); --------------------------------------------- S
121
      -- Set procedure value in record
122
      B.Response := R;
123
   end Set_Response;
124
 
125
 
126
   procedure Default_Response (B : in out Button) is
127
   begin
128
      TCTouch.Touch( 'D' ); --------------------------------------------- D
129
   end Default_Response;
130
 
131
 
132
   procedure Default_Action is
133
   begin
134
      TCTouch.Touch( 'd' ); --------------------------------------------- d
135
   end Default_Action;
136
 
137
   procedure Replacement_Action is
138
   begin
139
      TCTouch.Touch( 'r' ); --------------------------------------------- r
140
   end Replacement_Action;
141
 
142
   procedure Replace_Action( B: in out Alert_Button ) is
143
   begin
144
      TCTouch.Touch( 'R' ); --------------------------------------------- R
145
      B.Action := Replacement_Action'Access;
146
   end Replace_Action;
147
 
148
   function Alert (B : in Alert_Button) return Button_Action_Ptr is
149
   begin
150
      TCTouch.Touch( 'A' ); --------------------------------------------- A
151
      return (B.Action);
152
   end Alert;
153
 
154
end C3A0009_0;
155
 
156
-----------------------------------------------------------------------------
157
 
158
with C3A0009_0;
159
package C3A0009_1 is -- Emergency_Items
160
   package Push_Buttons renames C3A0009_0;
161
 
162
   procedure Emergency (B : in out Push_Buttons.Button);
163
end C3A0009_1;
164
 
165
with TCTouch;
166
package body C3A0009_1 is -- Emergency_Items
167
   procedure Emergency (B : in out Push_Buttons.Button) is
168
      begin
169
        TCTouch.Touch( 'E' ); ------------------------------------------- E
170
      end Emergency;
171
end C3A0009_1;
172
-----------------------------------------------------------------------------
173
 
174
with Report;
175
 
176
with C3A0009_0, C3A0009_1;
177
with TCTouch;
178
procedure C3A0009 is
179
 
180
   package Push_Buttons    renames C3A0009_0;
181
   package Emergency_Items renames C3A0009_1;
182
 
183
   Black_Button : Push_Buttons.Alert_Button;
184
   Alert_Ptr    : Push_Buttons.Button_Action_Ptr;
185
 
186
begin
187
 
188
   Report.Test ("C3A0009", "Check that subprogram references may be passed "
189
                         & "as parameters using access-to-subprogram types. "
190
                         & "Check that the passed subprograms may be "
191
                         & "invoked from within the called subprogram");
192
 
193
 
194
   Push_Buttons.Push( Black_Button );
195
   Push_Buttons.Alert( Black_Button ).all;
196
 
197
   TCTouch.Validate( "PDAd", "Default operation set" );
198
 
199
   -- Call inherited operations Set_Response and Push to set
200
   -- Emergency value in the extension.
201
   Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access);
202
 
203
 
204
   Push_Buttons.Push( Black_Button );
205
   Push_Buttons.Alert( Black_Button ).all;
206
 
207
   TCTouch.Validate( "SPEAd", "Altered Response set" );
208
 
209
   -- Call primitive operation to set action value in the extension.
210
   Push_Buttons.Replace_Action( Black_Button );
211
 
212
 
213
   Push_Buttons.Push( Black_Button );
214
   Push_Buttons.Alert( Black_Button ).all;
215
 
216
   TCTouch.Validate( "RPEAr", "Altered Action set" );
217
 
218
   Report.Result;
219
end C3A0009;

powered by: WebSVN 2.1.0

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