1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
-- C58005H.ADA
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
-- CHECK THAT CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE
-- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER.
-- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH
-- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES.
-- SPS 3/10/83
-- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations.
-- The objects must be used, and must be tied somehow to the
-- calls to Failed.
WITH REPORT;
USE REPORT;
PROCEDURE C58005H IS
PACKAGE PACK IS
TYPE PV (D : NATURAL) IS PRIVATE;
TYPE LP (D : NATURAL) IS LIMITED PRIVATE;
PRIVATE
TYPE PV (D : NATURAL) IS RECORD
NULL;
END RECORD;
TYPE LP (D : NATURAL) IS RECORD
NULL;
END RECORD;
END PACK;
USE PACK;
TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL;
TYPE REC (D : NATURAL) IS RECORD
NULL;
END RECORD;
TYPE ACC_REC IS ACCESS REC;
TYPE ACC_ARR IS ACCESS ARR;
TYPE ACC_PV IS ACCESS PV;
TYPE ACC_LP IS ACCESS LP;
SUBTYPE ACC_REC1 IS ACC_REC (D => 1);
SUBTYPE ACC_REC2 IS ACC_REC (D => 2);
SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10);
SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5);
SUBTYPE ACC_PV1 IS ACC_PV (D => 1);
SUBTYPE ACC_PV2 IS ACC_PV (D => 2);
SUBTYPE ACC_LP1 IS ACC_LP (D => 1);
SUBTYPE ACC_LP2 IS ACC_LP (D => 2);
VAR1 : ACC_REC1 := NEW REC(1);
VAR2 : ACC_REC2 := NEW REC(2);
VAA1 : ACC_ARR1 := NEW ARR(1 .. 10);
VAA2 : ACC_ARR2 := NEW ARR(2 .. 5);
VAP1 : ACC_PV1 := NEW PV(1);
VAP2 : ACC_PV2 := NEW PV(2);
VAL1 : ACC_LP1 := NEW LP(1);
VAL2 : ACC_LP2 := NEW LP(2);
FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS
BEGIN
RETURN X;
END FREC;
FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS
BEGIN
RETURN X;
END FARR;
FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS
BEGIN
RETURN X;
END FPV;
FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS
BEGIN
RETURN X;
END FLP;
PACKAGE BODY PACK IS
FUNCTION LF (X : LP) RETURN INTEGER IS
BEGIN
RETURN IDENT_INT(3);
END LF;
BEGIN
NULL;
END PACK;
BEGIN
TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " &
"OF FUNCTIONS");
BEGIN
VAR2 := FREC (VAR1);
IF VAR2.D /= REPORT.IDENT_INT(2) THEN
FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1");
ELSE
FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - REC");
END;
BEGIN
VAA2 := FARR (VAA1);
IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN
FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1");
ELSE
FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - ARR");
END;
BEGIN
VAP2 := FPV (VAP1);
IF VAP2.D /= REPORT.IDENT_INT(2) THEN
FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1");
ELSE
FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - PV");
END;
BEGIN
VAL2 := FLP (VAL1);
IF VAL2.D /= REPORT.IDENT_INT(2) THEN
FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1");
ELSE
FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2");
END IF;
EXCEPTION
WHEN CONSTRAINT_ERROR => NULL;
WHEN OTHERS =>
FAILED ("WRONG EXCEPTION RAISED - LP");
END;
RESULT;
END C58005H;
|
