1-- C58005H.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-- CHECK THAT CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE
26-- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER.
27
28-- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH
29-- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES.
30
31-- SPS 3/10/83
32-- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations.
33--               The objects must be used, and must be tied somehow to the
34--               calls to Failed.
35
36WITH REPORT;
37USE REPORT;
38PROCEDURE C58005H IS
39
40     PACKAGE PACK IS
41          TYPE PV (D : NATURAL) IS PRIVATE;
42          TYPE LP (D : NATURAL) IS LIMITED PRIVATE;
43     PRIVATE
44          TYPE PV (D : NATURAL) IS RECORD
45               NULL;
46          END RECORD;
47          TYPE LP (D : NATURAL) IS RECORD
48               NULL;
49          END RECORD;
50     END PACK;
51
52     USE PACK;
53
54     TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL;
55     TYPE REC (D : NATURAL) IS RECORD
56          NULL;
57     END RECORD;
58
59     TYPE ACC_REC IS ACCESS REC;
60     TYPE ACC_ARR IS ACCESS ARR;
61     TYPE ACC_PV IS ACCESS PV;
62     TYPE ACC_LP IS ACCESS LP;
63
64     SUBTYPE ACC_REC1 IS ACC_REC (D => 1);
65     SUBTYPE ACC_REC2 IS ACC_REC (D => 2);
66
67     SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10);
68     SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5);
69
70     SUBTYPE ACC_PV1 IS ACC_PV (D => 1);
71     SUBTYPE ACC_PV2 IS ACC_PV (D => 2);
72
73     SUBTYPE ACC_LP1 IS ACC_LP (D => 1);
74     SUBTYPE ACC_LP2 IS ACC_LP (D => 2);
75
76     VAR1 : ACC_REC1 := NEW REC(1);
77     VAR2 : ACC_REC2 := NEW REC(2);
78     VAA1 : ACC_ARR1 := NEW ARR(1 .. 10);
79     VAA2 : ACC_ARR2 := NEW ARR(2 .. 5);
80     VAP1 : ACC_PV1 := NEW PV(1);
81     VAP2 : ACC_PV2 := NEW PV(2);
82     VAL1 : ACC_LP1 := NEW LP(1);
83     VAL2 : ACC_LP2 := NEW LP(2);
84
85     FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS
86     BEGIN
87          RETURN X;
88     END FREC;
89
90     FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS
91     BEGIN
92          RETURN X;
93     END FARR;
94
95     FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS
96     BEGIN
97          RETURN X;
98     END FPV;
99
100     FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS
101     BEGIN
102          RETURN X;
103     END FLP;
104
105     PACKAGE BODY PACK IS
106          FUNCTION LF (X : LP) RETURN INTEGER IS
107          BEGIN
108               RETURN IDENT_INT(3);
109          END LF;
110     BEGIN
111          NULL;
112     END PACK;
113
114BEGIN
115
116     TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " &
117                      "OF FUNCTIONS");
118
119     BEGIN
120          VAR2 := FREC (VAR1);
121          IF VAR2.D /= REPORT.IDENT_INT(2) THEN
122              FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1");
123          ELSE
124              FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2");
125          END IF;
126     EXCEPTION
127          WHEN CONSTRAINT_ERROR => NULL;
128          WHEN OTHERS =>
129               FAILED ("WRONG EXCEPTION RAISED - REC");
130     END;
131
132     BEGIN
133          VAA2 := FARR (VAA1);
134          IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN
135              FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1");
136          ELSE
137              FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2");
138          END IF;
139     EXCEPTION
140          WHEN CONSTRAINT_ERROR => NULL;
141          WHEN OTHERS =>
142               FAILED ("WRONG EXCEPTION RAISED - ARR");
143     END;
144
145     BEGIN
146          VAP2 := FPV (VAP1);
147          IF VAP2.D /= REPORT.IDENT_INT(2) THEN
148              FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1");
149          ELSE
150              FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2");
151          END IF;
152     EXCEPTION
153          WHEN CONSTRAINT_ERROR => NULL;
154          WHEN OTHERS =>
155               FAILED ("WRONG EXCEPTION RAISED - PV");
156     END;
157
158     BEGIN
159          VAL2 := FLP (VAL1);
160          IF VAL2.D /= REPORT.IDENT_INT(2) THEN
161              FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1");
162          ELSE
163              FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2");
164          END IF;
165     EXCEPTION
166          WHEN CONSTRAINT_ERROR => NULL;
167          WHEN OTHERS =>
168               FAILED ("WRONG EXCEPTION RAISED - LP");
169     END;
170
171     RESULT;
172END C58005H;
173