1-- 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
51package 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
85end C410001_0;
86
87-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
88
89with Report;
90package 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
169end C410001_0;
170
171------------------------------------------------------------------- C410001
172
173with Report;
174with TCTouch;
175with C410001_0;
176procedure 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
230begin  -- 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
303end C410001;
304