1-- C41304A.ADA
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-- OBJECTIVE:
26--     CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN:
27--       L DENOTES AN ACCESS OBJECT HAVING THE VALUE NULL.
28--       L IS A FUNCTION CALL DELIVERING THE ACCESS VALUE NULL.
29
30-- HISTORY:
31--     WKB 08/14/81
32--     JRK 08/17/81
33--     SPS 10/26/82
34--     TBN 03/26/86  PUT THE NON-EXISTENT COMPONENT CASES INTO C41304B.
35--     JET 01/05/88  MODIFIED HEADER FORMAT AND ADDED CODE TO PREVENT
36--                   OPTIMIZATION.
37
38WITH REPORT; USE REPORT;
39PROCEDURE C41304A IS
40
41     TYPE R IS
42          RECORD
43               I : INTEGER;
44          END RECORD;
45
46     TYPE T IS ACCESS R;
47
48BEGIN
49     TEST ("C41304A", "CONSTRAINT_ERROR WHEN L IN L.R DENOTES A NULL " &
50                      "ACCESS OBJECT OR A FUNCTION CALL DELIVERING " &
51                      "NULL");
52
53     --------------------------------------------------
54
55     DECLARE
56
57          A : T := NEW R' (I => 1);
58          J : INTEGER;
59
60     BEGIN
61
62          IF EQUAL (4, 4) THEN
63               A := NULL;
64          END IF;
65
66          J := A.I;
67          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A NULL ACCESS " &
68                  "OBJECT");
69
70          IF EQUAL (J,J) THEN
71               COMMENT ("NO EXCEPTION RAISED");
72          END IF;
73
74     EXCEPTION
75
76          WHEN CONSTRAINT_ERROR =>
77               NULL;
78          WHEN OTHERS =>
79               FAILED ("WRONG EXCEPTION RAISED FOR A NULL ACCESS " &
80                       "OBJECT");
81
82     END;
83
84     --------------------------------------------------
85
86     DECLARE
87
88          J : INTEGER;
89
90          FUNCTION F RETURN T IS
91          BEGIN
92               IF EQUAL (4, 4) THEN
93                    RETURN NULL;
94               END IF;
95               RETURN NEW R' (I => 2);
96          END F;
97
98     BEGIN
99
100          J := F.I;
101          FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " &
102                  "DELIVERING A NULL ACCESS VALUE");
103
104          IF EQUAL (J,J) THEN
105               COMMENT ("NO EXCEPTION RAISED");
106          END IF;
107
108     EXCEPTION
109
110          WHEN CONSTRAINT_ERROR =>
111               NULL;
112          WHEN OTHERS =>
113               FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " &
114                       "DELIVERING A NULL ACCESS VALUE");
115
116     END;
117
118     RESULT;
119END C41304A;
120