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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C392004.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 subprograms inherited from tagged derivations, which are
28
--      subsequently redefined for the derived type, are available to the
29
--      package defining the new class via view conversion.  Check
30
--      that operations performed on objects using view conversion do not
31
--      affect the extended fields.  Check that visible operations not masked
32
--      by the deriving package remain available to the client, and do not
33
--      affect the extended fields.
34
--
35
-- TEST DESCRIPTION:
36
--      This test declares a tagged type, with a constructor operation,
37
--      derives a type from that tagged type, and declares a constructor
38
--      operation which masks the inherited operation.  It then tests
39
--      that the correct constructor is called, and that the extended
40
--      part of the derived type remains untouched as appropriate.
41
--
42
--
43
-- CHANGE HISTORY:
44
--      06 Dec 94   SAIC    ACVC 2.0
45
--      19 Dec 94   SAIC    Removed RM references from objective text.
46
--      04 Jan 94   SAIC    Fixed objective typo, removed dead code.
47
--
48
--!
49
 
50
with Report;
51
 
52
package C392004_1 is
53
 
54
  type Vehicle is tagged private;
55
 
56
  procedure Create ( The_Vehicle :    out Vehicle; TC_Flag : Natural );
57
  procedure Start  ( The_Vehicle : in out Vehicle );
58
 
59
private
60
 
61
  type Vehicle is tagged record
62
    Engine_On : Boolean;
63
  end record;
64
 
65
end C392004_1;
66
 
67
package body C392004_1 is
68
  procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is
69
  begin
70
    case TC_Flag is
71
      when 1 => null; -- expected flag for this subprogram
72
      when others =>
73
         Report.Failed ("Called Vehicle Create");
74
    end case;
75
    The_Vehicle := (Engine_On => False);
76
  end Create;
77
 
78
  procedure Start ( The_Vehicle : in out Vehicle ) is
79
  begin
80
    The_Vehicle.Engine_On := True;
81
  end Start;
82
 
83
end C392004_1;
84
 
85
----------------------------------------------------------------------------
86
 
87
with C392004_1;
88
package C392004_2 is
89
 
90
  type Car is new C392004_1.Vehicle with record
91
    Convertible : Boolean;
92
  end record;
93
 
94
  -- masking definition
95
  procedure Create( The_Car : out Car; TC_Flag : Natural );
96
 
97
  type Limo is new Car with null record;
98
 
99
  procedure Create( The_Limo : out Limo; TC_Flag : Natural );
100
 
101
end C392004_2;
102
 
103
----------------------------------------------------------------------------
104
 
105
with Report;
106
package body C392004_2 is
107
 
108
  procedure Create( The_Car : out Car; TC_Flag : Natural ) is
109
  begin
110
    case TC_Flag is
111
      when 2      => null; -- expected flag for this subprogram
112
      when others => Report.Failed ("Called Car Create");
113
    end case;
114
    C392004_1.Create( C392004_1.Vehicle(The_Car), 1);
115
    The_Car.Convertible := False;
116
  end Create;
117
 
118
  procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is
119
  begin
120
    case TC_Flag is
121
      when 3      => null; -- expected flag for this subprogram
122
      when others => Report.Failed ("Called Limo Create");
123
    end case;
124
    C392004_1.Create( C392004_1.Vehicle(The_Limo), 1);
125
    The_Limo.Convertible := True;
126
 end Create;
127
 
128
end C392004_2;
129
 
130
----------------------------------------------------------------------------
131
 
132
with Report;
133
with C392004_1; use C392004_1;
134
with C392004_2; use C392004_2;
135
procedure C392004 is
136
 
137
  My_Car : Car;
138
  Your_Car : Limo;
139
 
140
  procedure TC_Assert( Is_True : Boolean; Message : String ) is
141
  begin
142
    if not Is_True then
143
      Report.Failed (Message);
144
    end if;
145
  end TC_Assert;
146
 
147
begin  -- Main test procedure.
148
 
149
  Report.Test ("C392004", "Check subprogram inheritance & visibility " &
150
                          "for derived tagged types" );
151
 
152
  My_Car.Convertible := False;
153
  Create( Vehicle( My_Car ), 1 );
154
  TC_Assert( not My_Car.Convertible, "Altered descendent component 1");
155
 
156
  Create( Your_Car, 3 );
157
  TC_Assert( Your_Car.Convertible, "Did not set inherited component 2");
158
 
159
  My_Car.Convertible := True;
160
  Create( Vehicle( My_Car ), 1 );
161
  TC_Assert( My_Car.Convertible, "Altered descendent component 3");
162
 
163
  Create( My_Car, 2 );
164
  TC_Assert( not My_Car.Convertible, "Did not set extending component 4");
165
 
166
  My_Car.Convertible := False;
167
  Start( Vehicle( My_Car ) );
168
  TC_Assert( not My_Car.Convertible , "Altered descendent component 5");
169
 
170
  Start( My_Car );
171
  TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6");
172
 
173
  Your_Car.Convertible := False;
174
  Start( Vehicle( Your_Car ) );
175
  TC_Assert( not Your_Car.Convertible , "Altered descendent component 7");
176
 
177
  Start( Your_Car );
178
  TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8");
179
 
180
  My_Car.Convertible := True;
181
  Start( Vehicle( My_Car ) );
182
  TC_Assert( My_Car.Convertible, "Altered descendent component 9");
183
 
184
  Start( My_Car );
185
  TC_Assert( My_Car.Convertible, "Altered unreferenced component 10");
186
 
187
  Report.Result;
188
 
189
end C392004;

powered by: WebSVN 2.1.0

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