1-- C37403A.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 WHEN A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR
26-- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT DO
27-- NOT HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' REGARDLESS OF THE MODE
28-- OF THE PARAMETER.
29
30-- R.WILLIAMS 9/1/86
31
32WITH REPORT; USE REPORT;
33PROCEDURE C37403A IS
34
35BEGIN
36     TEST ( "C37403A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " &
37                       "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " &
38                       "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " &
39                       "DO NOT HAVE DEFAULTS, 'CONSTRAINED IS " &
40                       "'TRUE' REGARDLESS OF THE MODE OF THE " &
41                       "PARAMETER" );
42
43
44     DECLARE
45
46          SUBTYPE INT IS INTEGER RANGE 1.. 10;
47
48          TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>)
49               OF INTEGER;
50
51          TYPE SQUARE (SIDE : INT) IS
52               RECORD
53                    MAT : MATRIX (1 .. SIDE, 1 .. SIDE);
54               END RECORD;
55
56          S1 : SQUARE (2) := (2, ((1, 2), (3, 4)));
57
58          S2 : SQUARE (2) := S1;
59
60          S3 : SQUARE (2);
61
62          SC : CONSTANT SQUARE := (SIDE => 1, MAT => (1 => (1 => 1)));
63
64          PROCEDURE P (PIN1, PIN2 : IN     SQUARE;
65                       PINOUT     : IN OUT SQUARE;
66                       POUT       : OUT    SQUARE) IS
67
68          BEGIN
69               IF PIN1'CONSTRAINED THEN
70                    NULL;
71               ELSE
72                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
73                             "OF IN MODE - 1" );
74               END IF;
75
76               IF PIN2'CONSTRAINED THEN
77                    NULL;
78               ELSE
79                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
80                             "OF IN MODE - 2" );
81               END IF;
82
83               IF PINOUT'CONSTRAINED THEN
84                    NULL;
85               ELSE
86                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
87                             "OBJECT OF IN OUT MODE - 1" );
88               END IF;
89
90               IF POUT'CONSTRAINED THEN
91                    NULL;
92               ELSE
93                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
94                             "OBJECT OF OUT MODE - 1" );
95               END IF;
96
97               POUT := (2, ((1, 2), (3, 4)));
98          END P;
99
100          TASK T IS
101               ENTRY Q (PIN1, PIN2  : IN     SQUARE;
102                        PINOUT      : IN OUT SQUARE;
103                        POUT        : OUT    SQUARE);
104          END T;
105
106          TASK BODY T IS
107          BEGIN
108               ACCEPT Q (PIN1, PIN2  : IN     SQUARE;
109                         PINOUT      : IN OUT SQUARE;
110                         POUT        : OUT    SQUARE) DO
111
112                    BEGIN
113                         IF PIN1'CONSTRAINED THEN
114                              NULL;
115                         ELSE
116                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
117                                       "OBJECT OF IN MODE - 3" );
118                         END IF;
119
120                         IF PIN2'CONSTRAINED THEN
121                              NULL;
122                         ELSE
123                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
124                                       "OBJECT OF IN MODE - 4" );
125                         END IF;
126
127                         IF PINOUT'CONSTRAINED THEN
128                              NULL;
129                         ELSE
130                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
131                                       "OBJECT OF " &
132                                       "IN OUT MODE - 2" );
133                         END IF;
134
135                         IF POUT'CONSTRAINED THEN
136                              NULL;
137                         ELSE
138                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
139                                       "OBJECT OF " &
140                                       "OUT MODE - 2" );
141                         END IF;
142
143                         POUT := (2, ((1, 2), (3, 4)));
144                    END;
145               END Q;
146          END T;
147
148          GENERIC
149               PIN1, PIN2 : IN     SQUARE;
150               PINOUT     : IN OUT SQUARE;
151          PACKAGE R IS END R;
152
153          PACKAGE BODY R IS
154          BEGIN
155               IF PIN1'CONSTRAINED THEN
156                    NULL;
157               ELSE
158                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
159                             "OF IN MODE - 5" );
160               END IF;
161
162               IF PIN2'CONSTRAINED THEN
163                    NULL;
164               ELSE
165                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
166                             "OF IN MODE - 6" );
167               END IF;
168
169               IF PINOUT'CONSTRAINED THEN
170                    NULL;
171               ELSE
172                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
173                             "OBJECT OF IN OUT MODE - 3" );
174               END IF;
175
176          END R;
177
178          PACKAGE S IS NEW R (S1, SC, S2);
179
180     BEGIN
181          P (S1, SC, S2, S3);
182          T.Q (S1, SC, S2, S3);
183     END;
184
185     RESULT;
186END C37403A;
187