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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c760012.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C760012.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 record components that have per-object access discriminant
28
--      constraints are initialized in the order of their component
29
--      declarations, and after any components that are not so constrained.
30
--
31
--      Check that record components that have per-object access discriminant
32
--      constraints are finalized in the reverse order of their component
33
--      declarations, and before any components that are not so constrained.
34
--
35
-- TEST DESCRIPTION:
36
--      The type List_Item is the "container" type.  It holds two fields that
37
--      have per-object access discriminant constraints, and two fields that
38
--      are not discriminated.  These four fields are all controlled types.
39
--      A fifth field is a pointer used to maintain a linked list of these
40
--      data objects.  Each component is of a unique type which allows for
41
--      the test to simply track the order of initialization and finalization.
42
--
43
--      The types and their purpose are:
44
--        Constrained_First  - a controlled discriminated type
45
--        Constrained_Second - a controlled discriminated type
46
--        Simple_First       - a controlled type with no discriminant
47
--        Simple_Second      - a controlled type with no discriminant
48
--
49
--      The required order of operations:
50
--        Initialize
51
--          ( Simple_First | Simple_Second )   -- no "internal order" required
52
--          Constrained_First
53
--          Constrained_Second
54
--        Finalize
55
--          Constrained_Second
56
--          Constrained_First
57
--          ( Simple_First | Simple_Second )   -- must be inverse of init.
58
--
59
--
60
-- CHANGE HISTORY:
61
--      23 MAY 95   SAIC    Initial version
62
--      02 MAY 96   SAIC    Reorganized for 2.1
63
--      05 DEC 96   SAIC    Simplified for 2.1; added init/fin ordering check
64
--      31 DEC 97   EDS     Remove references to and uses of
65
--                          Initialization_Sequence
66
--!
67
 
68
---------------------------------------------------------------- C760012_0
69
 
70
with Ada.Finalization;
71
with Ada.Unchecked_Deallocation;
72
package C760012_0 is
73
 
74
  type List_Item;
75
 
76
  type List is access all List_Item;
77
 
78
  package Firsts is  -- distinguish first from second
79
    type Constrained_First(Container : access List_Item) is
80
           new Ada.Finalization.Limited_Controlled with null record;
81
    procedure Initialize( T : in out Constrained_First );
82
    procedure Finalize  ( T : in out Constrained_First );
83
 
84
    type Simple_First is new Ada.Finalization.Controlled with
85
      record
86
        My_Init_Seq_Number : Natural;
87
      end record;
88
    procedure Initialize( T : in out Simple_First );
89
    procedure Finalize  ( T : in out Simple_First );
90
 
91
  end Firsts;
92
 
93
  type Constrained_Second(Container : access List_Item) is
94
         new Ada.Finalization.Limited_Controlled with null record;
95
  procedure Initialize( T : in out Constrained_Second );
96
  procedure Finalize  ( T : in out Constrained_Second );
97
 
98
  type Simple_Second is new Ada.Finalization.Controlled with
99
    record
100
      My_Init_Seq_Number : Natural;
101
    end record;
102
  procedure Initialize( T : in out Simple_Second );
103
  procedure Finalize  ( T : in out Simple_Second );
104
 
105
  -- by 3.8(18);6.0 the following type contains components constrained
106
  -- by per-object expressions
107
 
108
 
109
  type List_Item is new Ada.Finalization.Limited_Controlled
110
    with record
111
      ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S
112
      SimpleA  : Firsts.Simple_First;                          -- A T
113
      SimpleB  : Simple_Second;                                -- A T
114
      ContentB : Constrained_Second( List_Item'Access );       -- D R
115
      Next     : List;                                         -- | |
116
    end record;                                                -- | |
117
  procedure Initialize( L : in out List_Item ); ------------------+ |
118
  procedure Finalize  ( L : in out List_Item ); --------------------+
119
 
120
  -- the tags are the same for SimpleA and SimpleB due to the fact that
121
  -- the language does not specify an ordering with respect to this
122
  -- component pair. 7.6(12) does specify the rest of the ordering.
123
 
124
  procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List);
125
 
126
end C760012_0;
127
 
128
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
129
 
130
with TCTouch;
131
package body C760012_0 is
132
 
133
  package body Firsts is
134
 
135
    procedure Initialize( T : in out Constrained_First ) is
136
    begin
137
      TCTouch.Touch('C');   ----------------------------------------------- C
138
    end Initialize;
139
 
140
    procedure Finalize  ( T : in out Constrained_First ) is
141
    begin
142
      TCTouch.Touch('S');   ----------------------------------------------- S
143
    end Finalize;
144
 
145
    procedure Initialize( T : in out Simple_First ) is
146
    begin
147
      T.My_Init_Seq_Number := 0;
148
      TCTouch.Touch('A');   ----------------------------------------------- A
149
    end Initialize;
150
 
151
    procedure Finalize  ( T : in out Simple_First ) is
152
    begin
153
      TCTouch.Touch('T');   ----------------------------------------------- T
154
    end Finalize;
155
 
156
  end Firsts;
157
 
158
  procedure Initialize( T : in out Constrained_Second ) is
159
  begin
160
    TCTouch.Touch('D');   ------------------------------------------------- D
161
  end Initialize;
162
 
163
  procedure Finalize  ( T : in out Constrained_Second ) is
164
  begin
165
    TCTouch.Touch('R');   ------------------------------------------------- R
166
  end Finalize;
167
 
168
 
169
  procedure Initialize( T : in out Simple_Second ) is
170
  begin
171
    T.My_Init_Seq_Number := 0;
172
    TCTouch.Touch('A');   ------------------------------------------------- A
173
  end Initialize;
174
 
175
  procedure Finalize  ( T : in out Simple_Second ) is
176
  begin
177
    TCTouch.Touch('T');   ------------------------------------------------- T
178
  end Finalize;
179
 
180
  procedure Initialize( L : in out List_Item ) is
181
  begin
182
    TCTouch.Touch('F');   ------------------------------------------------- F
183
  end Initialize;
184
 
185
  procedure Finalize  ( L : in out List_Item ) is
186
  begin
187
    TCTouch.Touch('Q');   ------------------------------------------------- Q
188
  end Finalize;
189
 
190
end C760012_0;
191
 
192
--------------------------------------------------------------------- C760012
193
 
194
with Report;
195
with TCTouch;
196
with C760012_0;
197
procedure C760012 is
198
 
199
  use type C760012_0.List;
200
 
201
  procedure Subtest_1 is
202
  -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints
203
  -- 7.6.1(9);6.0 dictates the order of finalization of the components
204
 
205
    One_Of_Them : C760012_0.List_Item;
206
  begin
207
    if One_Of_Them.Next /= null then  -- just to hold the subtest in place
208
      Report.Failed("No default value for Next");
209
    end if;
210
  end Subtest_1;
211
 
212
  List : C760012_0.List;
213
 
214
  procedure Subtest_2 is
215
  begin
216
 
217
    List := new C760012_0.List_Item;
218
 
219
    List.Next := new C760012_0.List_Item;
220
 
221
  end Subtest_2;
222
 
223
  procedure Subtest_3 is
224
  begin
225
 
226
    C760012_0.Deallocate( List.Next );
227
 
228
    C760012_0.Deallocate( List );
229
 
230
  end Subtest_3;
231
 
232
begin  -- Main test procedure.
233
 
234
  Report.Test ("C760012", "Check that record components that have " &
235
                          "per-object access discriminant constraints " &
236
                          "are initialized in the order of their " &
237
                          "component declarations, and after any " &
238
                          "components that are not so constrained.  " &
239
                          "Check that record components that have " &
240
                          "per-object access discriminant constraints " &
241
                          "are finalized in the reverse order of their " &
242
                          "component declarations, and before any " &
243
                          "components that are not so constrained" );
244
 
245
  Subtest_1;
246
  TCTouch.Validate("AACDFQRSTT", "One object");
247
 
248
  Subtest_2;
249
  TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated");
250
 
251
  Subtest_3;
252
  TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated");
253
 
254
  Report.Result;
255
 
256
end C760012;

powered by: WebSVN 2.1.0

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