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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- F393A00.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
-- FOUNDATION DESCRIPTION:
27
--      This foundation provides a simple background for a class family
28
--      based on an abstract type.  It is to be used to test the
29
--      dispatching of various forms of subprogram defined/inherited and
30
--      overridden with the abstract type.
31
--
32
--  type                       procedures                  functions
33
--  ----                       ----------                  ---------
34
--  Object                     Initialize, Swap(abstract)  Create(abstract)
35
--        Object'Class                                     Initialized
36
--    Windmill is new Object   Swap, Stop, Add_Spin        Create, Spin
37
--      Pump is new Windmill   Set_Rate                    Create, Rate
38
--      Mill is new Windmill   Swap, Stop                  Create
39
--
40
-- CHANGE HISTORY:
41
--      06 Dec 94   SAIC    ACVC 2.0
42
--
43
--!
44
 
45
package F393A00_0 is
46
   procedure TC_Touch ( A_Tag : Character );
47
   procedure TC_Validate( Expected: String; Message: String );
48
end F393A00_0;
49
 
50
with Report;
51
package body F393A00_0 is
52
   Expectation : String(1..20);
53
   Finger      : Natural := 0;
54
 
55
   procedure TC_Touch ( A_Tag : Character ) is
56
   begin
57
     Finger := Finger+1;
58
     Expectation(Finger) := A_Tag;
59
   end TC_Touch;
60
 
61
   procedure TC_Validate( Expected: String; Message: String ) is
62
   begin
63
     if Expectation(1..Finger) /= Expected then
64
       Report.Failed( Message & " Expecting: " & Expected
65
                             & " Got: " & Expectation(1..Finger) );
66
     end if;
67
     Finger := 0;
68
   end TC_Validate;
69
end F393A00_0;
70
 
71
----------------------------------------------------------------------
72
 
73
package F393A00_1 is
74
   type Object is abstract tagged private;
75
   procedure Initialize( An_Object: in out Object );
76
   function  Initialized( An_Object: Object'Class ) return Boolean;
77
   procedure Swap( A,B: in out Object ) is abstract;
78
   function  Create return Object is abstract;
79
private
80
   type Object is abstract tagged record
81
     Initialized : Boolean := False;
82
   end record;
83
end F393A00_1;
84
 
85
with F393A00_0;
86
package body F393A00_1 is
87
   procedure Initialize( An_Object: in out Object ) is
88
   begin
89
     An_Object.Initialized := True;
90
     F393A00_0.TC_Touch('a');
91
   end Initialize;
92
 
93
   function  Initialized( An_Object: Object'Class ) return Boolean is
94
   begin
95
     F393A00_0.TC_Touch('b');
96
     return An_Object.Initialized;
97
   end Initialized;
98
end F393A00_1;
99
 
100
----------------------------------------------------------------------
101
 
102
with F393A00_1;
103
package F393A00_2 is
104
 
105
   type Rotational_Measurement is range -1_000 .. 1_000;
106
   type Windmill is new F393A00_1.Object with private;
107
 
108
   procedure Swap( A,B: in out Windmill );
109
 
110
   function  Create return Windmill;
111
 
112
   procedure Add_Spin( To_Mill : in out Windmill;
113
                      RPMs    : in     Rotational_Measurement );
114
 
115
   procedure Stop( Mill : in out Windmill );
116
 
117
   function  Spin( Mill : Windmill ) return Rotational_Measurement;
118
 
119
private
120
   type Windmill is new F393A00_1.Object with
121
     record
122
       Spin : Rotational_Measurement := 0;
123
     end record;
124
end F393A00_2;
125
 
126
with F393A00_0;
127
package body F393A00_2 is
128
 
129
   procedure Swap( A,B: in out Windmill ) is
130
     T : constant Windmill := B;
131
   begin
132
     F393A00_0.TC_Touch('c');
133
     B := A;
134
     A := T;
135
   end Swap;
136
 
137
   function  Create return Windmill is
138
     A_Mill : Windmill;
139
   begin
140
     F393A00_0.TC_Touch('d');
141
     return A_Mill;
142
   end Create;
143
 
144
   procedure Add_Spin( To_Mill : in out Windmill;
145
                      RPMs    : in     Rotational_Measurement ) is
146
   begin
147
     F393A00_0.TC_Touch('e');
148
     To_Mill.Spin := To_Mill.Spin + RPMs;
149
   end Add_Spin;
150
 
151
   procedure Stop( Mill : in out Windmill ) is
152
   begin
153
     F393A00_0.TC_Touch('f');
154
     Mill.Spin := 0;
155
   end Stop;
156
 
157
   function  Spin( Mill : Windmill ) return Rotational_Measurement is
158
   begin
159
     F393A00_0.TC_Touch('g');
160
     return Mill.Spin;
161
   end Spin;
162
 
163
end F393A00_2;
164
 
165
----------------------------------------------------------------------
166
 
167
with F393A00_2;
168
package F393A00_3 is
169
   type Pump is new F393A00_2.Windmill with private;
170
   function Create return Pump;
171
 
172
   type Gallons_Per_Revolution is digits 3;
173
   procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution);
174
   function  Rate( Of_Pump: Pump ) return Gallons_Per_Revolution;
175
private
176
   type Pump is new F393A00_2.Windmill with
177
     record
178
       GPRPM : Gallons_Per_Revolution := 0.0; -- Gallons/RPM
179
     end record;
180
end F393A00_3;
181
 
182
with F393A00_0;
183
package body F393A00_3 is
184
   function Create return Pump is
185
     Sump : Pump;
186
   begin
187
     F393A00_0.TC_Touch('h');
188
     return Sump;
189
   end Create;
190
 
191
   procedure Set_Rate( A_Pump: in out Pump; To_Rate: Gallons_Per_Revolution)
192
   is
193
   begin
194
     F393A00_0.TC_Touch('i');
195
     A_Pump.GPRPM := To_Rate;
196
   end Set_Rate;
197
 
198
   function  Rate( Of_Pump: Pump ) return Gallons_Per_Revolution is
199
   begin
200
     F393A00_0.TC_Touch('j');
201
     return Of_Pump.GPRPM;
202
   end Rate;
203
end F393A00_3;
204
 
205
----------------------------------------------------------------------
206
 
207
with F393A00_2;
208
with F393A00_3;
209
package F393A00_4 is
210
   type Mill is new F393A00_2.Windmill with private;
211
 
212
   procedure Swap( A,B: in out Mill );
213
   function  Create return Mill;
214
   procedure Stop( It: in out Mill );
215
 private
216
   type Mill is new F393A00_2.Windmill with
217
     record
218
       Pump: F393A00_3.Pump := F393A00_3.Create;
219
     end record;
220
end F393A00_4;
221
 
222
with F393A00_0;
223
package body F393A00_4 is
224
   procedure Swap( A,B: in out Mill ) is
225
     T: constant Mill := A;
226
   begin
227
     F393A00_0.TC_Touch('k');
228
     A := B;
229
     B := T;
230
   end Swap;
231
 
232
   function  Create return Mill is
233
     A_Mill : Mill;
234
   begin
235
     F393A00_0.TC_Touch('l');
236
     return A_Mill;
237
   end Create;
238
 
239
   procedure Stop( It: in out Mill ) is
240
   begin
241
     F393A00_0.TC_Touch('m');
242
     F393A00_3.Stop( It.Pump );
243
     F393A00_2.Stop( F393A00_2.Windmill( It ) );
244
   end Stop;
245
end F393A00_4;

powered by: WebSVN 2.1.0

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