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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c410001.a] - Blame information for rev 720

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C410001.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 evaluating an access to subprogram variable containing
28
--      the value null causes the exception Constraint_Error.
29
--      Check that the default value for objects of access to subprogram
30
--      types is null.
31
--
32
-- TEST DESCRIPTION:
33
--      This test defines a few simple access_to_subprogram types, and
34
--      objects of those types.  It checks that the default values for
35
--      these objects is null, and that an attempt to make a subprogram
36
--      call via one of this objects containing a null value causes the
37
--      predefined exception Constraint_Error.  The check is performed
38
---     both with the default null value, and with an explicitly assigned
39
--      null value, after the object has been used to successfully designate
40
--      and call a subprogram.
41
--
42
--
43
-- CHANGE HISTORY:
44
--      05 APR 96   SAIC   Initial version
45
--      04 NOV 96   SAIC   Revised for 2.1 release
46
--      26 FEB 97   PWB.CTA Initialized variable before passing to function
47
--!
48
 
49
----------------------------------------------------------------- C410001_0
50
 
51
package C410001_0 is
52
 
53
  -- used to "switch state" in the software
54
  Expect_Exception : Boolean;
55
 
56
  -- define a minimal mixture of access_to_subprogram types
57
 
58
  type Proc_Ref is access procedure;
59
 
60
  type Func_Ref is access function(I:Integer) return Integer;
61
 
62
  type Proc_Para_Ref is access procedure(P:Proc_Ref);
63
 
64
  type Func_Para_Ref is access function(F:Func_Ref) return Integer;
65
 
66
  type Prot_Proc_Ref is access protected procedure;
67
 
68
  type Prot_Func_Ref is access protected function return Boolean;
69
 
70
  -- define some subprograms for them to reference
71
 
72
  procedure Proc;
73
 
74
  function Func(I:Integer) return Integer;
75
 
76
  procedure Proc_Para( Param : Proc_Ref );
77
 
78
  function Func_Para( Param : Func_Ref ) return Integer;
79
 
80
  protected Prot_Obj is
81
    procedure Prot_Proc;
82
    function Prot_Func return Boolean;
83
  end Prot_Obj;
84
 
85
end C410001_0;
86
 
87
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
88
 
89
with Report;
90
package body C410001_0 is
91
 
92
  -- Note that some failing cases will cause duplicate failure messages;
93
  -- rather than have the procedure/function bodies be null, the error
94
  -- checking code makes for a reasonable anti-optimization feature.
95
 
96
  procedure Proc is
97
  begin
98
    if Expect_Exception then
99
      Report.Failed("Expected exception did not occur: Proc");
100
    end if;
101
  end Proc;
102
 
103
  function Func(I:Integer) return Integer is
104
  begin
105
    if Expect_Exception then
106
      Report.Failed("Expected exception did not occur: Func");
107
    end if;
108
    return Report.Ident_Int(I);
109
  end Func;
110
 
111
  procedure Proc_Para( Param : Proc_Ref ) is
112
  begin
113
 
114
    Param.all;        -- call by explicit dereference
115
 
116
    if Expect_Exception then
117
      Report.Failed("Expected exception did not occur: Proc_Para");
118
    end if;
119
 
120
  exception
121
    when Constraint_Error =>
122
      if not Expect_Exception then
123
        Report.Failed("Unexpected Constraint_Error: Proc_Para");
124
      end if;  -- else null; expected the exception
125
    when others => Report.Failed("Unexpected exception: Proc_Para");
126
  end Proc_Para;
127
 
128
  function Func_Para( Param : Func_Ref ) return Integer is
129
  begin
130
 
131
    return Param(1);  -- call by implicit dereference
132
 
133
    if Expect_Exception then
134
      Report.Failed("Expected exception did not occur: Func_Para");
135
    end if;
136
    return 1;  -- really just to avoid warnings
137
 
138
  exception
139
    when Constraint_Error =>
140
      if not Expect_Exception then
141
        Report.Failed("Unexpected Constraint_Error: Func_Para");
142
        return 0;
143
      else
144
        return 1995;  -- any value other than this is unexpected
145
      end if;
146
    when others => Report.Failed("Unexpected exception: Func_Para");
147
                   return -42;
148
  end Func_Para;
149
 
150
  protected body Prot_Obj is
151
 
152
    procedure Prot_Proc is
153
    begin
154
      if Expect_Exception then
155
        Report.Failed("Expected exception did not occur: Prot_Proc");
156
      end if;
157
    end Prot_Proc;
158
 
159
    function Prot_Func return Boolean is
160
    begin
161
      if Expect_Exception then
162
        Report.Failed("Expected exception did not occur: Prot_Func");
163
      end if;
164
      return Report.Ident_Bool( True );
165
    end Prot_Func;
166
 
167
  end Prot_Obj;
168
 
169
end C410001_0;
170
 
171
------------------------------------------------------------------- C410001
172
 
173
with Report;
174
with TCTouch;
175
with C410001_0;
176
procedure C410001 is
177
 
178
  Proc_Ref_Var : C410001_0.Proc_Ref;
179
 
180
  Func_Ref_Var : C410001_0.Func_Ref;
181
 
182
  Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref;
183
 
184
  Func_Para_Ref_Var : C410001_0.Func_Para_Ref;
185
 
186
  type Enclosure is record
187
    Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref;
188
    Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref;
189
  end record;
190
 
191
  Enclosed : Enclosure;
192
 
193
  Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access;
194
 
195
  Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access;
196
 
197
  procedure Make_Calls( Expecting_Exceptions : Boolean ) is
198
    type Case_Numbers is range 1..6;
199
    Some_Integer : Integer := 0;
200
  begin
201
    for Cases in Case_Numbers loop
202
      Catch_Exception : begin
203
        case Cases is
204
          when 1 => Proc_Ref_Var.all;
205
          when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer );
206
          when 3 => Proc_Para_Ref_Var( Valid_Proc );
207
          when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func );
208
          when 5 => Enclosed.Prot_Proc_Ref_Var.all;
209
          when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all
210
                                    /= Expecting_Exceptions,
211
                                    "Case 6");
212
        end case;
213
        if Expecting_Exceptions then
214
          Report.Failed("Exception expected: Case"
215
                        & Case_Numbers'Image(Cases) );
216
        end if;
217
      exception
218
        when Constraint_Error =>
219
          if not Expecting_Exceptions then
220
            Report.Failed("Constraint_Error not expected: Case"
221
                          & Case_Numbers'Image(Cases) );
222
          end if;
223
        when others =>
224
          Report.Failed("Wrong/Bad Exception: Case"
225
                        & Case_Numbers'Image(Cases) );
226
      end Catch_Exception;
227
    end loop;
228
  end Make_Calls;
229
 
230
begin  -- Main test procedure.
231
 
232
  Report.Test ("C410001", "Check that evaluating an access to subprogram " &
233
                          "variable containing the value null causes the " &
234
                          "exception Constraint_Error. Check that the " &
235
                          "default value for objects of access to " &
236
                          "subprogram types is null" );
237
 
238
  -- check that the default values are null
239
  declare
240
    use C410001_0; -- make all "="'s visible for all types
241
  begin
242
    TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" );
243
 
244
    TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" );
245
 
246
    TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" );
247
 
248
    TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" );
249
 
250
    TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null,
251
                   "Enclosed.Prot_Proc_Ref_Var = null" );
252
 
253
    TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null,
254
                   "Enclosed.Prot_Func_Ref_Var = null" );
255
  end;
256
 
257
  -- check that calls via the default values cause Constraint_Error
258
 
259
  C410001_0.Expect_Exception := True;
260
 
261
  Make_Calls( Expecting_Exceptions => True );
262
 
263
  -- assign non-null values to the objects
264
 
265
  Proc_Ref_Var      := C410001_0.Proc'Access;
266
  Func_Ref_Var      := C410001_0.Func'Access;
267
  Proc_Para_Ref_Var := C410001_0.Proc_Para'Access;
268
  Func_Para_Ref_Var := C410001_0.Func_Para'Access;
269
  Enclosed          := (C410001_0.Prot_Obj.Prot_Proc'Access,
270
                        C410001_0.Prot_Obj.Prot_Func'Access);
271
 
272
  -- check that the calls perform normally
273
 
274
  C410001_0.Expect_Exception := False;
275
 
276
  Make_Calls( Expecting_Exceptions => False );
277
 
278
  -- check that a passed null value causes Constraint_Error
279
 
280
  C410001_0.Expect_Exception := True;
281
 
282
  Proc_Para_Ref_Var( null );
283
 
284
  TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995,
285
                 "Func_Para_Ref_Var( null )");
286
 
287
  -- assign the null value to the objects
288
 
289
  Proc_Ref_Var      := null;
290
  Func_Ref_Var      := null;
291
  Proc_Para_Ref_Var := null;
292
  Func_Para_Ref_Var := null;
293
  Enclosed          := (null,null);
294
 
295
  -- check that calls now again cause Constraint_Error
296
 
297
  C410001_0.Expect_Exception := True;
298
 
299
  Make_Calls( Expecting_Exceptions => True );
300
 
301
  Report.Result;
302
 
303
end C410001;

powered by: WebSVN 2.1.0

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