1-- CC3120A.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 GENERIC IN PARAMETERS ARE ALWAYS COPIED, AND THAT
26-- GENERIC IN OUT PARAMETERS ARE ALWAYS RENAMED.
27
28-- DAT 8/10/81
29-- SPS 10/21/82
30
31WITH REPORT; USE REPORT;
32
33PROCEDURE CC3120A IS
34BEGIN
35     TEST ("CC3120A", "GENERIC IN PARMS ARE COPIED, GENERIC IN OUT"
36          & " PARMS ARE RENAMED");
37
38     DECLARE
39          S1, S2 : INTEGER;
40          A1, A2, A3 : STRING (1 .. IDENT_INT (3));
41
42          TYPE REC IS RECORD
43               C1, C2 : INTEGER := 1;
44          END RECORD;
45
46          R1, R2 : REC;
47
48          PACKAGE P IS
49               TYPE PRIV IS PRIVATE;
50               PROCEDURE SET_PRIV (P : IN OUT PRIV);
51          PRIVATE
52               TYPE PRIV IS NEW REC;
53          END P;
54          USE P;
55
56          P1, P2 : PRIV;
57          EX : EXCEPTION;
58
59          GENERIC
60               TYPE T IS PRIVATE;
61               P1 : IN OUT T;
62               P2 : IN T;
63          PROCEDURE GP;
64
65          B_ARR : ARRAY (1..10) OF BOOLEAN;
66
67          PACKAGE BODY P IS
68               PROCEDURE SET_PRIV (P : IN OUT PRIV) IS
69               BEGIN
70                    P.C1 := 3;
71               END SET_PRIV;
72          END P;
73
74          PROCEDURE GP IS
75          BEGIN
76               IF P1 = P2 THEN
77                    FAILED ("PARAMETER SCREW_UP SOMEWHERE");
78               END IF;
79               P1 := P2;
80               IF P1 /= P2 THEN
81                    FAILED ("ASSIGNMENT SCREW_UP SOMEWHERE");
82               END IF;
83               RAISE EX;
84               FAILED ("RAISE STATEMENT DOESN'T WORK");
85          END GP;
86     BEGIN
87          S1 := 4;
88          S2 := 5;
89          A1 := "XYZ";
90          A2 := "ABC";
91          A3 := "DEF";
92          R1.C1 := 4;
93          R2.C1 := 5;
94          B_ARR := (1|3|5|7|9 => TRUE, 2|4|6|8|10 => FALSE);
95          SET_PRIV (P2);
96
97          IF S1 = S2
98          OR A1 = A3
99          OR R1 = R2
100          OR P1 = P2 THEN
101               FAILED ("WRONG ASSIGNMENT");
102          END IF;
103          BEGIN
104               DECLARE
105                    PROCEDURE PR IS NEW GP (INTEGER, S1, S2);
106               BEGIN
107                    S2 := S1;
108                    PR;       -- OLD S2 ASSIGNED TO S1, SO S1 /= S2 NOW
109                    FAILED ("EX NOT RAISED 1");
110               EXCEPTION
111                    WHEN EX => NULL;
112               END;
113
114               DECLARE
115                    SUBTYPE STR_1_3 IS STRING (IDENT_INT (1)..3);
116                    PROCEDURE PR IS NEW GP (STR_1_3, A1, A3);
117               BEGIN
118                    A3 := A1;
119                    PR;
120                    FAILED ("EX NOT RAISED 2");
121               EXCEPTION
122                    WHEN EX => NULL;
123               END;
124
125               DECLARE
126                    PROCEDURE PR IS NEW GP (REC, R1, R2);
127               BEGIN
128                    R2 := R1;
129                    PR;
130                    FAILED ("EX NOT RAISED 3");
131               EXCEPTION
132                    WHEN EX => NULL;
133               END;
134
135               DECLARE
136                    PROCEDURE PR IS NEW GP (PRIV, P1, P2);
137               BEGIN
138                    P2 := P1;
139                    PR;
140                    FAILED ("EX NOT RAISED 4");
141               EXCEPTION
142                    WHEN EX => NULL;
143               END;
144               DECLARE
145                    PROCEDURE PR IS NEW GP (CHARACTER,
146                                            A3(IDENT_INT(2)),
147                                            A3(IDENT_INT(3)));
148               BEGIN
149                    A3(3) := A3(2);
150                    PR;
151                    FAILED ("EX NOT RAISED 5");
152               EXCEPTION
153                    WHEN EX => NULL;
154               END;
155
156               DECLARE
157                    PROCEDURE PR IS NEW GP (BOOLEAN,
158                                            B_ARR(IDENT_INT(2)),
159                                            B_ARR(IDENT_INT(3)));
160               BEGIN
161                    B_ARR(3) := B_ARR(2);
162                    PR;
163                    FAILED ("EX NOT RAISED 6");
164               EXCEPTION
165                    WHEN EX => NULL;
166               END;
167          END;
168
169          IF S1 = S2
170          OR A1 = A2
171          OR R1 = R2
172          OR P1 = P2
173          OR A3(2) = A3(3)
174          OR B_ARR(2) = B_ARR(3) THEN
175               FAILED ("ASSIGNMENT FAILED 2");
176          END IF;
177     END;
178
179     RESULT;
180END CC3120A;
181