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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- C760007.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 Adjust is called for the execution of a return
28
--      statement for a function returning a result of a (non-limited)
29
--      controlled type.
30
--
31
--      Check that Adjust is called when evaluating an aggregate
32
--      component association for a controlled component.
33
--
34
--      Check that Adjust is called for the assignment of the ancestor
35
--      expression of an extension aggregate when the type of the
36
--      aggregate is controlled.
37
--
38
-- TEST DESCRIPTION:
39
--      A type is derived from Ada.Finalization.Controlled; the dispatching
40
--      procedure Adjust is defined for the new type.  Structures and
41
--      subprograms to model the test objectives are used to check that
42
--      Adjust is called at the right time.  For the sake of simplicity,
43
--      globally accessible data is used to check that the calls are made.
44
--
45
--
46
-- CHANGE HISTORY:
47
--      06 DEC 94   SAIC    ACVC 2.0
48
--      14 OCT 95   SAIC    Update and repair for ACVC 2.0.1
49
--      05 APR 96   SAIC    Add RM reference
50
--      06 NOV 96   SAIC    Reduce adjust requirement
51
--      25 NOV 97   EDS     Allowed zero calls to adjust at line 144
52
--!
53
 
54
---------------------------------------------------------------- C760007_0
55
 
56
with Ada.Finalization;
57
package C760007_0 is
58
 
59
  type Controlled is new Ada.Finalization.Controlled with record
60
    TC_ID : Natural := Natural'Last;
61
  end record;
62
  procedure Adjust( Object: in out Controlled );
63
 
64
  type Structure is record
65
    Controlled_Component : Controlled;
66
  end record;
67
 
68
  type Child is new Controlled with record
69
    TC_XX : Natural := Natural'Last;
70
  end record;
71
  procedure Adjust( Object: in out Child );
72
 
73
  Adjust_Count       : Natural := 0;
74
  Child_Adjust_Count : Natural := 0;
75
 
76
end C760007_0;
77
 
78
package body C760007_0 is
79
 
80
  procedure Adjust( Object: in out Controlled ) is
81
  begin
82
    Adjust_Count := Adjust_Count +1;
83
  end Adjust;
84
 
85
  procedure Adjust( Object: in out Child ) is
86
  begin
87
    Child_Adjust_Count := Child_Adjust_Count +1;
88
  end Adjust;
89
 
90
end C760007_0;
91
 
92
------------------------------------------------------------------ C760007
93
 
94
with Report;
95
with C760007_0;
96
procedure C760007 is
97
 
98
  procedure Check_Adjust_Count(Message: String;
99
                               Min: Natural := 1;
100
                               Max: Natural := 2) is
101
  begin
102
 
103
     -- in order to allow for the anonymous objects referred to in
104
     -- the reference manual, the check for calls to Adjust must be
105
     -- in a range.  This number must then be further adjusted
106
     -- to allow for the optimization that does not call for an adjust
107
     -- of an aggregate initial value built directly in the object
108
 
109
     if C760007_0.Adjust_Count not in Min..Max then
110
       Report.Failed(Message
111
                   & " = " & Natural'Image(C760007_0.Adjust_Count));
112
     end if;
113
     C760007_0.Adjust_Count := 0;
114
  end Check_Adjust_Count;
115
 
116
  procedure Check_Child_Adjust_Count(Message: String;
117
                                     Min: Natural := 1;
118
                                     Max: Natural := 2) is
119
  begin
120
     -- ditto above
121
 
122
     if C760007_0.Child_Adjust_Count not in Min..Max then
123
       Report.Failed(Message
124
                   & " = " & Natural'Image(C760007_0.Child_Adjust_Count));
125
     end if;
126
     C760007_0.Child_Adjust_Count := 0;
127
  end Check_Child_Adjust_Count;
128
 
129
  Object : C760007_0.Controlled;
130
 
131
--      Check that Adjust is called for the execution of a return
132
--      statement for a function returning a result of a (non-limited)
133
--      controlled type or a result of a noncontrolled type with
134
--      controlled components.
135
 
136
  procedure Subtest_1 is
137
    function Create return C760007_0.Controlled is
138
      New_Object : C760007_0.Controlled;
139
    begin
140
      return New_Object;
141
    end Create;
142
 
143
    procedure Examine( Thing : in C760007_0.Controlled ) is
144
    begin
145
      Check_Adjust_Count("Function call passed as parameter",0);
146
    end Examine;
147
 
148
  begin
149
    -- this assignment must call Adjust:
150
    --   1: on the value resulting from the function
151
    --      ** unless this is optimized out by building the result directly
152
    --         in the target object.
153
    --   2: on Object once it's been assigned
154
    -- may call adjust
155
    --   1: for a anonymous object created in the evaluation of the function
156
    --   2: for a anonymous object created in the assignment operation
157
 
158
    Object := Create;
159
 
160
    Check_Adjust_Count("Function call",1,4);
161
 
162
    Examine( Create );
163
 
164
  end Subtest_1;
165
 
166
--      Check that Adjust is called when evaluating an aggregate
167
--      component association for a controlled component.
168
 
169
  procedure Subtest_2 is
170
    S : C760007_0.Structure;
171
 
172
    procedure Examine( Thing : in C760007_0.Structure ) is
173
    begin
174
      Check_Adjust_Count("Aggregate passed as parameter");
175
    end Examine;
176
 
177
  begin
178
    -- this assignment must call Adjust:
179
    --   1: on the value resulting from the aggregate
180
    --      ** unless this is optimized out by building the result directly
181
    --         in the target object.
182
    --   2: on Object once it's been assigned
183
    -- may call adjust
184
    --   1: for a anonymous object created in the evaluation of the aggregate
185
    --   2: for a anonymous object created in the assignment operation
186
    S := ( Controlled_Component => Object );
187
    Check_Adjust_Count("Aggregate and Assignment", 1, 4);
188
 
189
    Examine( C760007_0.Structure'(Controlled_Component => Object) );
190
  end Subtest_2;
191
 
192
--      Check that Adjust is called for the assignment of the ancestor
193
--      expression of an extension aggregate when the type of the
194
--      aggregate is controlled.
195
 
196
  procedure Subtest_3 is
197
    Bambino : C760007_0.Child;
198
 
199
    procedure Examine( Thing : in C760007_0.Child ) is
200
    begin
201
      Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2);
202
      Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4);
203
    end Examine;
204
 
205
  begin
206
    -- implementation permissions make all of the following calls to adjust
207
    -- optional:
208
    -- these assignments may call Adjust:
209
    --   1: on the value resulting from the aggregate
210
    --   2: on Object once it's been assigned
211
    --   3: for a anonymous object created in the evaluation of the aggregate
212
    --   4: for a anonymous object created in the assignment operation
213
    Bambino := ( Object with TC_XX => 10 );
214
    Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2);
215
    Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 );
216
 
217
    Bambino := ( C760007_0.Controlled with TC_XX => 11 );
218
    Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2);
219
    Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 );
220
 
221
    Examine( ( Object with TC_XX => 21 ) );
222
 
223
    Examine( ( C760007_0.Controlled with TC_XX => 37 ) );
224
 
225
  end Subtest_3;
226
 
227
begin  -- Main test procedure.
228
 
229
  Report.Test ("C760007", "Check that Adjust is called for the " &
230
                          "execution of a return statement for a " &
231
                          "function returning a result containing a " &
232
                          "controlled type.  Check that Adjust is " &
233
                          "called when evaluating an aggregate " &
234
                          "component association for a controlled " &
235
                          "component.  " &
236
                          "Check that Adjust is called for the " &
237
                          "assignment of the ancestor expression of an " &
238
                          "extension aggregate when the type of the " &
239
                          "aggregate is controlled" );
240
 
241
  Subtest_1;
242
  Subtest_2;
243
  Subtest_3;
244
 
245
  Report.Result;
246
 
247
end C760007;

powered by: WebSVN 2.1.0

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