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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C392C07.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 for a call to a dispatching subprogram the subprogram
28
--     body which is executed is determined by the controlling tag for
29
--     the case where the call has dynamic tagged controlling operands
30
--     of the type T.  Check for calls to these same subprograms where
31
--     the operands are of specific statically tagged types:
32
--     objects (declared or allocated), formal parameters, view
33
--     conversions, and function calls (both primitive and non-primitive).
34
--
35
-- TEST DESCRIPTION:
36
--      This test uses foundation F392C00 to test the usages of statically
37
--      tagged objects and values.  This test is derived in part from
38
--      C392C05.
39
--
40
--
41
-- CHANGE HISTORY:
42
--      06 Dec 94   SAIC    ACVC 2.0
43
--      24 Oct 95   SAIC    Updated for ACVC 2.0.1
44
--
45
--!
46
 
47
with Report;
48
with TCTouch;
49
with F392C00_1;
50
procedure C392C07 is -- Hardware_Store
51
  package Switch renames F392C00_1;
52
 
53
  subtype Switch_Class is Switch.Toggle'Class;
54
 
55
  type Reference is access all Switch_Class;
56
 
57
  A_Switch   : aliased Switch.Toggle;
58
  A_Dimmer   : aliased Switch.Dimmer;
59
  An_Autodim : aliased Switch.Auto_Dimmer;
60
 
61
  type Light_Bank is array(Positive range <>) of Reference;
62
 
63
  Lamps : Light_Bank(1..3);
64
 
65
-- dynamically tagged controlling operands : class wide formal parameters
66
  procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is
67
  begin
68
    if Switch.On( Device ) /= On then
69
      Switch.Flip( Device );
70
    end if;
71
  end Clamp;
72
  function Class_Item(Bank_Pos: Positive) return Switch_Class is
73
  begin
74
    return Lamps(Bank_Pos).all;
75
  end Class_Item;
76
 
77
begin  -- Main test procedure.
78
  Report.Test ("C392C07", "Check that a dispatching subprogram call is "
79
                        & "determined by the controlling tag for "
80
                        & "dynamically tagged controlling operands" );
81
 
82
  Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access );
83
 
84
-- dynamically tagged operands referring to
85
-- statically tagged declared objects
86
  for Knob in Lamps'Range loop
87
    Clamp( Lamps(Knob).all, On => True );
88
  end loop;
89
  TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" );
90
 
91
  Lamps(1) := new Switch.Toggle;
92
  Lamps(2) := new Switch.Dimmer;
93
  Lamps(3) := new Switch.Auto_Dimmer;
94
 
95
-- turn the full bank of switches ON
96
-- dynamically tagged allocated objects
97
  for Knob in Lamps'Range loop
98
    Clamp( Lamps(Knob).all, On => True );
99
  end loop;
100
  TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated");
101
 
102
-- Double check execution correctness
103
  if Switch.Off( Lamps(1).all )
104
     or Switch.Off( Lamps(2).all )
105
     or Switch.Off( Lamps(3).all ) then
106
    Report.Failed( "Bad Value" );
107
  end if;
108
  TCTouch.Validate( "CCC", "Class-wide");
109
 
110
-- turn the full bank of switches OFF
111
  for Knob in Lamps'Range loop
112
    Switch.Flip( Lamps(Knob).all );
113
  end loop;
114
  TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops");
115
 
116
-- check switches for OFF
117
-- a few function calls as operands
118
  for Knob in Lamps'Range loop
119
    if not Switch.Off( Class_Item(Knob) ) then
120
      Report.Failed("At function tests, Switch not OFF");
121
    end if;
122
  end loop;
123
  TCTouch.Validate( "CCC",
124
                         "Using function returning class-wide type");
125
 
126
-- Switches are all OFF now.
127
-- dynamically tagged view conversion
128
  Clamp( Switch_Class( A_Switch ) );
129
  Clamp( Switch_Class( A_Dimmer ) );
130
  Clamp( Switch_Class( An_Autodim ) );
131
  TCTouch.Validate( "BABGBABKGBA", "View Conversions" );
132
 
133
-- dynamically tagged controlling operands : declared class wide objects
134
--  calling primitive functions
135
  declare
136
    Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' );
137
  begin
138
    Switch.Flip( Dine_O_Might );
139
    if Switch.On( Dine_O_Might ) then
140
      Report.Failed( "Exploded at Dine_O_Might" );
141
    end if;
142
    TCTouch.Validate( "WAB", "Dispatching function 1" );
143
  end;
144
 
145
  declare
146
    Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' );
147
  begin
148
    Switch.Flip( Dyne_A_Mite );
149
    if Switch.On( Dyne_A_Mite ) then
150
      Report.Failed( "Exploded at Dyne_A_Mite" );
151
    end if;
152
    TCTouch.Validate( "WGBAB", "Dispatching function 2" );
153
  end;
154
 
155
  declare
156
    Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' );
157
  begin
158
    Switch.Flip( Din_Um_Out );
159
    if Switch.Off( Din_Um_Out ) then
160
      Report.Failed( "Exploded at Din_Um_Out" );
161
    end if;
162
    TCTouch.Validate( "WKCC", "Dispatching function 3" );
163
 
164
-- Non-dispatching function calls.
165
    if not Switch.TC_Non_Disp( Switch.Toggle( Din_Um_Out ) ) then
166
      Report.Failed( "Non primitive, via view conversion" );
167
    end if;
168
    TCTouch.Validate( "X", "View Conversion 1" );
169
 
170
    if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then
171
      Report.Failed( "Non primitive, via view conversion" );
172
    end if;
173
    TCTouch.Validate( "Y", "View Conversion 2" );
174
  end;
175
 
176
  -- a few more function calls as operands (oops)
177
  if not Switch.On( Switch.Toggle'( Switch.Create ) ) then
178
    Report.Failed("Toggle did not create ""On""");
179
  end if;
180
 
181
  if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then
182
    Report.Failed("Dimmer created ""Off""");
183
  end if;
184
 
185
  if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
186
    Report.Failed("Auto_Dimmer created ""Off""");
187
  end if;
188
 
189
  Report.Result;
190
end C392C07;

powered by: WebSVN 2.1.0

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