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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C393001.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 an abstract type can be declared, and in turn concrete
28
--      types can be derived from it.  Check that the definition of
29
--      actual subprograms associated with the derived types dispatch
30
--      correctly.
31
--
32
-- TEST DESCRIPTION:
33
--      This test declares an abstract type Breaker in a package, and
34
--      then derives from it.  The type Basic_Breaker defines the least
35
--      possible in order to not be abstract.  The type Ground_Fault is
36
--      defined to inherit as much as possible, whereas type Special_Breaker
37
--      overrides everything it can.  The type Special_Breaker also includes
38
--      an embedded Basic_Breaker object.  The main program then utilizes
39
--      each of the three types of breaker, and to ascertain that the
40
--      overloading and tagging resolution are correct, each "Create"
41
--      procedure is called with a unique value.  The diagram below
42
--      illustrates the relationships.  This test is derived from C3A2001.
43
--
44
--              Abstract type:           Breaker
45
--                                           |
46
--                                    Basic_Breaker (Short)
47
--                                    /           \
48
--                     (Sharp) Ground_Fault    Special_Breaker (Shock)
49
--
50
--      Test structure is an array of class-wide objects, modeling a circuit
51
--      as a list of components.  The test then creates some values, and
52
--      traverses the list to determine correct operation.
53
--
54
--
55
-- CHANGE HISTORY:
56
--      06 Dec 94   SAIC    ACVC 2.0
57
--      13 Nov 95   SAIC    Revised for 2.0.1
58
--
59
--!
60
 
61
----------------------------------------------------------------- C393001_1
62
 
63
with Report;
64
package C393001_1 is
65
 
66
  type Breaker is abstract tagged private;
67
  type Status  is ( Power_Off, Power_On, Tripped, Failed );
68
 
69
  procedure Flip ( The_Breaker : in out Breaker ) is abstract;
70
  procedure Trip ( The_Breaker : in out Breaker ) is abstract;
71
  procedure Reset( The_Breaker : in out Breaker ) is abstract;
72
  procedure Fail ( The_Breaker : in out Breaker );
73
 
74
  procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status );
75
 
76
  function  Status_Of( The_Breaker : Breaker ) return Status;
77
 
78
private
79
  type Breaker is abstract tagged record
80
    State : Status := Power_Off;
81
  end record;
82
end C393001_1;
83
 
84
with TCTouch;
85
package body C393001_1 is
86
  procedure Fail( The_Breaker : in out Breaker ) is ------------------- a
87
  begin
88
    TCTouch.Touch( 'a' );
89
    The_Breaker.State := Failed;
90
  end Fail;
91
 
92
  procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is
93
  begin
94
    The_Breaker.State := To_State;
95
  end Set;
96
 
97
  function  Status_Of( The_Breaker : Breaker ) return Status is ------- b
98
  begin
99
    TCTouch.Touch( 'b' );
100
    return The_Breaker.State;
101
  end Status_Of;
102
end C393001_1;
103
 
104
----------------------------------------------------------------- C393001_2
105
 
106
with C393001_1;
107
package C393001_2 is
108
 
109
  type Basic_Breaker is new C393001_1.Breaker with private;
110
 
111
  type Voltages is ( V12, V110, V220, V440 );
112
  type Amps     is ( A1, A5, A10, A25, A100 );
113
 
114
  function Construct( Voltage : Voltages; Amperage : Amps )
115
    return Basic_Breaker;
116
 
117
  procedure Flip ( The_Breaker : in out Basic_Breaker );
118
  procedure Trip ( The_Breaker : in out Basic_Breaker );
119
  procedure Reset( The_Breaker : in out Basic_Breaker );
120
private
121
  type Basic_Breaker is new C393001_1.Breaker with record
122
    Voltage_Level : Voltages := V110;
123
    Amperage      : Amps;
124
  end record;
125
end C393001_2;
126
 
127
with TCTouch;
128
package body C393001_2 is
129
  function Construct( Voltage : Voltages; Amperage : Amps ) ----------- c
130
    return Basic_Breaker is
131
    It : Basic_Breaker;
132
  begin
133
    TCTouch.Touch( 'c' );
134
    It.Amperage := Amperage;
135
    It.Voltage_Level := Voltage;
136
    C393001_1.Set( It, C393001_1.Power_Off );
137
    return It;
138
  end Construct;
139
 
140
  procedure Flip ( The_Breaker : in out Basic_Breaker ) is ------------ d
141
  begin
142
    TCTouch.Touch( 'd' );
143
    case Status_Of( The_Breaker ) is
144
      when C393001_1.Power_Off =>
145
        C393001_1.Set( The_Breaker, C393001_1.Power_On );
146
      when C393001_1.Power_On =>
147
        C393001_1.Set( The_Breaker, C393001_1.Power_Off );
148
      when C393001_1.Tripped | C393001_1.Failed  => null;
149
    end case;
150
  end Flip;
151
 
152
  procedure Trip ( The_Breaker : in out Basic_Breaker ) is ------------ e
153
  begin
154
    TCTouch.Touch( 'e' );
155
    C393001_1.Set( The_Breaker, C393001_1.Tripped );
156
  end Trip;
157
 
158
  procedure Reset( The_Breaker : in out Basic_Breaker ) is ------------ f
159
  begin
160
    TCTouch.Touch( 'f' );
161
    case Status_Of( The_Breaker ) is
162
      when C393001_1.Power_Off | C393001_1.Tripped =>
163
        C393001_1.Set( The_Breaker, C393001_1.Power_On );
164
      when C393001_1.Power_On  | C393001_1.Failed  => null;
165
    end case;
166
  end Reset;
167
 
168
end C393001_2;
169
 
170
with C393001_1,C393001_2;
171
package C393001_3 is
172
 
173
  type Ground_Fault is new C393001_2.Basic_Breaker with private;
174
 
175
  function Construct( Voltage : C393001_2.Voltages; Amperage : C393001_2.Amps
176
)
177
    return Ground_Fault;
178
 
179
  procedure Set_Trip( The_Breaker : in out Ground_Fault;
180
                      Capacitance : in     Integer );
181
 
182
private
183
  type Ground_Fault is new C393001_2.Basic_Breaker with record
184
    Capacitance : Integer;
185
  end record;
186
end C393001_3;
187
 
188
----------------------------------------------------------------- C393001_3
189
 
190
with TCTouch;
191
package body C393001_3 is
192
 
193
  function Construct( Voltage  : C393001_2.Voltages; ------------------ g
194
                      Amperage : C393001_2.Amps )
195
    return Ground_Fault is
196
 
197
    It : Ground_Fault;
198
 
199
    procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
200
    begin
201
      It := C393001_2.Construct( Voltage, Amperage );
202
    end Set_Root;
203
 
204
  begin
205
    TCTouch.Touch( 'g' );
206
    Set_Root( C393001_2.Basic_Breaker( It ) );
207
    It.Capacitance := 0;
208
    return It;
209
  end Construct;
210
 
211
  procedure Set_Trip( The_Breaker : in out Ground_Fault; -------------- h
212
                      Capacitance : in     Integer ) is
213
  begin
214
    TCTouch.Touch( 'h' );
215
    The_Breaker.Capacitance := Capacitance;
216
  end Set_Trip;
217
 
218
end C393001_3;
219
 
220
----------------------------------------------------------------- C393001_4
221
 
222
with C393001_1, C393001_2;
223
package C393001_4 is
224
 
225
  type Special_Breaker is new C393001_2.Basic_Breaker with private;
226
 
227
  function Construct( Voltage     : C393001_2.Voltages;
228
                      Amperage    : C393001_2.Amps )
229
    return Special_Breaker;
230
 
231
  procedure Flip ( The_Breaker : in out Special_Breaker );
232
  procedure Trip ( The_Breaker : in out Special_Breaker );
233
  procedure Reset( The_Breaker : in out Special_Breaker );
234
  procedure Fail ( The_Breaker : in out Special_Breaker );
235
 
236
  function Status_Of( The_Breaker : Special_Breaker ) return C393001_1.Status;
237
  function On_Backup( The_Breaker : Special_Breaker ) return Boolean;
238
 
239
private
240
  type Special_Breaker is new C393001_2.Basic_Breaker with record
241
    Backup : C393001_2.Basic_Breaker;
242
  end record;
243
end C393001_4;
244
 
245
with TCTouch;
246
package body C393001_4 is
247
 
248
  function Construct( Voltage     : C393001_2.Voltages; --------------- i
249
                      Amperage    : C393001_2.Amps )
250
    return Special_Breaker is
251
    It: Special_Breaker;
252
    procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is
253
    begin
254
      It := C393001_2.Construct( Voltage, Amperage );
255
    end Set_Root;
256
  begin
257
    TCTouch.Touch( 'i' );
258
    Set_Root( C393001_2.Basic_Breaker( It ) );
259
    Set_Root( It.Backup );
260
    return It;
261
  end Construct;
262
 
263
  function Status_Of( It: C393001_1.Breaker ) return C393001_1.Status
264
    renames C393001_1.Status_Of;
265
 
266
  procedure Flip ( The_Breaker : in out Special_Breaker ) is ---------- j
267
  begin
268
    TCTouch.Touch( 'j' );
269
    case Status_Of( C393001_1.Breaker( The_Breaker )) is
270
      when C393001_1.Power_Off | C393001_1.Power_On =>
271
        C393001_2.Flip( C393001_2.Basic_Breaker( The_Breaker ) );
272
      when others =>
273
        C393001_2.Flip( The_Breaker.Backup );
274
    end case;
275
  end Flip;
276
 
277
  procedure Trip ( The_Breaker : in out Special_Breaker ) is ---------- k
278
  begin
279
    TCTouch.Touch( 'k' );
280
    case Status_Of( C393001_1.Breaker( The_Breaker )) is
281
      when C393001_1.Power_Off => null;
282
      when C393001_1.Power_On  =>
283
        C393001_2.Reset( The_Breaker.Backup );
284
        C393001_2.Trip( C393001_2.Basic_Breaker( The_Breaker ) );
285
      when others =>
286
        C393001_2.Trip( The_Breaker.Backup );
287
    end case;
288
  end Trip;
289
 
290
  procedure Reset( The_Breaker : in out Special_Breaker ) is ---------- l
291
  begin
292
    TCTouch.Touch( 'l' );
293
    case Status_Of( C393001_1.Breaker( The_Breaker )) is
294
      when C393001_1.Tripped  =>
295
        C393001_2.Reset( C393001_2.Basic_Breaker( The_Breaker ));
296
      when C393001_1.Failed  =>
297
        C393001_2.Reset( The_Breaker.Backup );
298
      when C393001_1.Power_On | C393001_1.Power_Off =>
299
        null;
300
    end case;
301
  end Reset;
302
 
303
  procedure Fail ( The_Breaker : in out Special_Breaker ) is ---------- m
304
  begin
305
    TCTouch.Touch( 'm' );
306
    case Status_Of( C393001_1.Breaker( The_Breaker )) is
307
      when C393001_1.Failed  =>
308
        C393001_2.Fail( The_Breaker.Backup );
309
      when others =>
310
        C393001_2.Fail( C393001_2.Basic_Breaker( The_Breaker ));
311
        C393001_2.Reset( The_Breaker.Backup );
312
    end case;
313
  end Fail;
314
 
315
  function Status_Of( The_Breaker : Special_Breaker ) ----------------- n
316
    return C393001_1.Status is
317
  begin
318
    TCTouch.Touch( 'n' );
319
    case Status_Of( C393001_1.Breaker( The_Breaker )) is
320
      when C393001_1.Power_On  => return C393001_1.Power_On;
321
      when C393001_1.Power_Off => return C393001_1.Power_Off;
322
      when others =>
323
        return C393001_2.Status_Of( The_Breaker.Backup );
324
    end case;
325
  end Status_Of;
326
 
327
  function On_Backup( The_Breaker : Special_Breaker ) return Boolean is
328
    use C393001_2;
329
    use type C393001_1.Status;
330
  begin
331
    return Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Tripped
332
        or Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Failed;
333
  end On_Backup;
334
 
335
end C393001_4;
336
 
337
------------------------------------------------------------------- C393001
338
 
339
with Report, TCTouch;
340
with C393001_1, C393001_2, C393001_3, C393001_4;
341
procedure C393001 is
342
 
343
  procedure Flipper( The_Circuit : in out C393001_1.Breaker'Class ) is
344
  begin
345
      C393001_1.Flip( The_Circuit );
346
  end Flipper;
347
 
348
  procedure Tripper( The_Circuit : in out C393001_1.Breaker'Class ) is
349
  begin
350
      C393001_1.Trip( The_Circuit );
351
  end Tripper;
352
 
353
  procedure Restore( The_Circuit : in out C393001_1.Breaker'Class ) is
354
  begin
355
      C393001_1.Reset( The_Circuit );
356
  end Restore;
357
 
358
  procedure Failure( The_Circuit : in out C393001_1.Breaker'Class ) is
359
  begin
360
      C393001_1.Fail( The_Circuit );
361
  end Failure;
362
 
363
  Short : C393001_1.Breaker'Class -- Basic_Breaker
364
          := C393001_2.Construct( C393001_2.V440, C393001_2.A5 );
365
  Sharp : C393001_1.Breaker'Class -- Ground_Fault
366
          := C393001_3.Construct( C393001_2.V110, C393001_2.A1 );
367
  Shock : C393001_1.Breaker'Class -- Special_Breaker
368
          := C393001_4.Construct( C393001_2.V12,  C393001_2.A100 );
369
 
370
begin  -- Main test procedure.
371
 
372
  Report.Test ("C393001", "Check that an abstract type can be declared " &
373
               "and used.  Check actual subprograms dispatch correctly" );
374
 
375
  TCTouch.Validate( "cgcicc", "Declaration" );
376
 
377
  Flipper( Short );
378
  TCTouch.Validate( "db", "Flipping Short" );
379
  Flipper( Sharp );
380
  TCTouch.Validate( "db", "Flipping Sharp" );
381
  Flipper( Shock );
382
  TCTouch.Validate( "jbdb", "Flipping Shock" );
383
 
384
  Tripper( Short );
385
  TCTouch.Validate( "e", "Tripping Short" );
386
  Tripper( Sharp );
387
  TCTouch.Validate( "e", "Tripping Sharp" );
388
  Tripper( Shock );
389
  TCTouch.Validate( "kbfbe", "Tripping Shock" );
390
 
391
  Restore( Short );
392
  TCTouch.Validate( "fb", "Restoring Short" );
393
  Restore( Sharp );
394
  TCTouch.Validate( "fb", "Restoring Sharp" );
395
  Restore( Shock );
396
  TCTouch.Validate( "lbfb", "Restoring Shock" );
397
 
398
  Failure( Short );
399
  TCTouch.Validate( "a", "Shock Failing" );
400
  Failure( Sharp );
401
  TCTouch.Validate( "a", "Shock Failing" );
402
  Failure( Shock );
403
  TCTouch.Validate( "mbafb", "Shock Failing" );
404
 
405
  Report.Result;
406
 
407
end C393001;

powered by: WebSVN 2.1.0

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