URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c38002a.ada] - Blame information for rev 720

Details | Compare with Previous | View Log


-- C38002A.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.
--*
-- OBJECTIVE:
--     CHECK THAT AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT
--     DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION
--     WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT.
--
--     CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN
--     SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT
--     DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT
--     DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION,
--     DERIVED TYPE DEFINITION, PRIVATE TYPE.
--
--     CHECK FOR UNCONSTRAINED GENERIC FORMAL TYPE.
 
-- HISTORY:
--     AH  09/02/86 CREATED ORIGINAL TEST.
--     DHH 08/16/88 REVISED HEADER AND ENTERED COMMENTS FOR PRIVATE TYPE
--                  AND CORRECTED INDENTATION.
--     BCB 04/12/90 ADDED CHECKS FOR AN ARRAY AS A SUBPROGRAM RETURN
--                  TYPE AND AN ARRAY AS A FORMAL PARAMETER.
--     LDC 10/01/90 ADDED CODE SO F, FPROC, G, GPROC AREN'T OPTIMIZED 
--                  AWAY
 
WITH REPORT; USE REPORT;
PROCEDURE C38002A IS
 
BEGIN
     TEST ("C38002A", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " &
           "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " &
           "ARRAY OR RECORD TYPES");
 
     DECLARE
          C3 : CONSTANT INTEGER := IDENT_INT(3);
 
          TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
          TYPE ARR_NAME IS ACCESS ARR;
          SUBTYPE ARR_NAME_3 IS ARR_NAME(1..3);
 
          TYPE REC(DISC : INTEGER) IS
               RECORD
                    COMP : ARR_NAME(1..DISC);
               END RECORD;
          TYPE REC_NAME IS ACCESS REC;
 
          OBJ : REC_NAME(C3);
 
          TYPE ARR2 IS ARRAY (1..10) OF REC_NAME(C3);
 
          TYPE REC2 IS
               RECORD
                    COMP2 : REC_NAME(C3);
               END RECORD;
 
          TYPE NAME_REC_NAME IS ACCESS REC_NAME(C3);
 
          TYPE DERIV IS NEW REC_NAME(C3);
          SUBTYPE REC_NAME_3 IS REC_NAME(C3);
 
          FUNCTION F (PARM : REC_NAME_3) RETURN REC_NAME_3 IS
          BEGIN
               IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
                    COMMENT("DON'T OPTIMIZE F AWAY");
               END IF;
               RETURN PARM;
          END;
 
          PROCEDURE FPROC (PARM : REC_NAME_3) IS
          BEGIN
               IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
                    COMMENT("DON'T OPTIMIZE FPROC AWAY");
               END IF;
          END FPROC;
 
          FUNCTION G (PA : ARR_NAME_3) RETURN ARR_NAME_3 IS
          BEGIN
               IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
                    COMMENT("DON'T OPTIMIZE G AWAY");
               END IF;
               RETURN PA;
          END G;
 
          PROCEDURE GPROC (PA : ARR_NAME_3) IS
          BEGIN
               IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
                    COMMENT("DON'T OPTIMIZE GPROC AWAY");
               END IF;
          END GPROC;
 
     BEGIN
          DECLARE
               R : REC_NAME;
          BEGIN
               R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
               R := F(R);
               R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
               R := F(R);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY FUNCTION FOR RECORD");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
                                 "ACCESS VALUE - RECORD,FUNCTION");
                    END IF;
          END;
 
          DECLARE
               R : REC_NAME;
          BEGIN
               R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));
               FPROC(R);
               R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));
               FPROC(R);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY PROCEDURE FOR RECORD");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
                                 "ACCESS VALUE - RECORD,PROCEDURE");
                    END IF;
          END;
 
          DECLARE
               A : ARR_NAME;
          BEGIN
               A := NEW ARR'(1..3 => 5);
               A := G(A);
               A := NEW ARR'(1..4 => 6);
               A := G(A);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY FUNCTION FOR ARRAY");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF A = NULL OR ELSE A(4) /= 6 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
                                 "ACCESS VALUE - ARRAY,FUNCTION");
                    END IF;
          END;
 
          DECLARE
               A : ARR_NAME;
          BEGIN
               A := NEW ARR'(1..3 => 5);
               GPROC(A);
               A := NEW ARR'(1..4 => 6);
               GPROC(A);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY PROCEDURE FOR ARRAY");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF A = NULL OR ELSE A(4) /= 6 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &
                                 "ACCESS VALUE - ARRAY,PROCEDURE");
                    END IF;
          END;
     END;
 
     DECLARE
          C3 : CONSTANT INTEGER := IDENT_INT(3);
 
          TYPE REC (DISC : INTEGER) IS
               RECORD
                    NULL;
               END RECORD;
 
          TYPE P_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
          TYPE P_ARR_NAME IS ACCESS P_ARR;
 
          TYPE P_REC_NAME IS ACCESS REC;
 
          GENERIC
               TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;
          PACKAGE P IS
               TYPE ACC_REC IS ACCESS REC;
               TYPE ACC_ARR IS ACCESS UNCON_ARR;
               TYPE ACC_P_ARR IS ACCESS P_ARR;
               SUBTYPE ACC_P_ARR_3 IS ACC_P_ARR(1..3);
               OBJ : ACC_REC(C3);
 
               TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3);
 
               TYPE REC1 IS
                    RECORD
                         COMP1 : ACC_REC(C3);
                    END RECORD;
 
               TYPE REC2 IS
                    RECORD
                         COMP2 : ACC_ARR(1..C3);
                    END RECORD;
 
               SUBTYPE ACC_REC_3 IS ACC_REC(C3);
 
               FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3;
 
               PROCEDURE FPROC (PARM : ACC_REC_3);
 
               FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3;
 
               PROCEDURE GPROC (PA : ACC_P_ARR_3);
 
               TYPE ACC1 IS PRIVATE;
               TYPE ACC2 IS PRIVATE;
               TYPE DER1 IS PRIVATE;
               TYPE DER2 IS PRIVATE;
 
          PRIVATE
 
               TYPE ACC1 IS ACCESS ACC_REC(C3);
               TYPE ACC2 IS ACCESS ACC_ARR(1..C3);
               TYPE DER1 IS NEW ACC_REC(C3);
               TYPE DER2 IS NEW ACC_ARR(1..C3);
          END P;
 
          PACKAGE BODY P IS
               FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS
               BEGIN
                    IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
                         COMMENT("DON'T OPTIMIZE F AWAY");
                    END IF;
                    RETURN PARM;
               END;
 
               PROCEDURE FPROC (PARM : ACC_REC_3) IS
               BEGIN
                    IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
                         COMMENT("DON'T OPTIMIZE FPROC AWAY");
                    END IF;
               END FPROC;
 
               FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3 IS
               BEGIN
                    IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN
                         COMMENT("DON'T OPTIMIZE G AWAY");
                    END IF;
                    RETURN PA;
               END;
 
               PROCEDURE GPROC (PA : ACC_P_ARR_3) IS
               BEGIN
                    IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN
                         COMMENT("DON'T OPTIMIZE GPROC AWAY");
                    END IF;
               END GPROC;
          END P;
 
          PACKAGE NP IS NEW P (UNCON_ARR => P_ARR);
 
          USE NP;
 
     BEGIN
          DECLARE
               R : ACC_REC;
          BEGIN
               R := NEW REC(DISC => 3);
               R := F(R);
               R := NEW REC(DISC => 4);
               R := F(R);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY FUNCTION FOR A RECORD -GENERIC");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
                                 "OF ACCESS VALUE - RECORD," &
                                 "FUNCTION -GENERIC");
                    END IF;
          END;
 
          DECLARE
               R : ACC_REC;
          BEGIN
               R := NEW REC(DISC => 3);
               FPROC(R);
               R := NEW REC(DISC => 4);
               FPROC(R);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY PROCEDURE FOR A RECORD -GENERIC");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF R = NULL OR ELSE R.DISC /= 4 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
                                 "OF ACCESS VALUE - RECORD," &
                                 "PROCEDURE -GENERIC");
                    END IF;
          END;
 
          DECLARE
               A : ACC_P_ARR;
          BEGIN
               A := NEW P_ARR'(1..3 => 5);
               A := G(A);
               A := NEW P_ARR'(1..4 => 6);
               A := G(A);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY FUNCTION FOR AN ARRAY -GENERIC");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF A = NULL OR ELSE A(4) /= 6 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
                                 "OF ACCESS VALUE - ARRAY," &
                                 "FUNCTION -GENERIC");
                    END IF;
          END;
 
          DECLARE
               A : ACC_P_ARR;
          BEGIN
               A := NEW P_ARR'(1..3 => 5);
               GPROC(A);
               A := NEW P_ARR'(1..4 => 6);
               GPROC(A);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY PROCEDURE FOR AN ARRAY -GENERIC");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF A = NULL OR ELSE A(4) /= 6 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
                                 "OF ACCESS VALUE - ARRAY," &
                                 "PROCEDURE -GENERIC");
                    END IF;
          END;
     END;
 
     DECLARE
          TYPE CON_INT IS RANGE 1..10;
 
          GENERIC
               TYPE UNCON_INT IS RANGE <>;
          PACKAGE P2 IS
               SUBTYPE NEW_INT IS UNCON_INT RANGE 1..5;
               FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT;
 
               PROCEDURE PROC_INT (PARM : NEW_INT);
          END P2;
 
          PACKAGE BODY P2 IS
               FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT IS
               BEGIN
                    IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN
                         COMMENT("DON'T OPTIMIZE F AWAY");
                    END IF;
                    RETURN PARM;
               END FUNC_INT;
 
               PROCEDURE PROC_INT (PARM : NEW_INT) IS
               BEGIN
                    IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN
                         COMMENT("DON'T OPTIMIZE FPROC AWAY");
                    END IF;
               END PROC_INT;
          END P2;
 
          PACKAGE NP2 IS NEW P2 (UNCON_INT => CON_INT);
 
          USE NP2;
 
     BEGIN
          DECLARE
               R : CON_INT;
          BEGIN
               R := 2;
               R := FUNC_INT(R);
               R := 8;
               R := FUNC_INT(R);
               FAILED ("INCOMPATIBLE CONSTRAINT ON VALUE " &
                       "ACCEPTED BY FUNCTION -GENERIC");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF R /= 8 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
                                 "OF VALUE -FUNCTION, GENERIC");
                    END IF;
          END;
 
          DECLARE
               R : CON_INT;
          BEGIN
               R := 2;
               PROC_INT(R);
               R := 9;
               PROC_INT(R);
               FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &
                       "ACCEPTED BY PROCEDURE -GENERIC");
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    IF R /= 9 THEN
                         FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &
                                 "OF ACCESS VALUE - PROCEDURE, " &
                                 "GENERIC");
                    END IF;
          END;
     END;
 
     RESULT;
END C38002A;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c38002a.ada] - Blame information for rev 720

Line No.	Rev	Author	Line
1	720	jeremybenn	`-- C38002A.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 AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT`
27			`-- DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION`
28			`-- WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT.`
29			`--`
30			`-- CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN`
31			`-- SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT`
32			`-- DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT`
33			`-- DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION,`
34			`-- DERIVED TYPE DEFINITION, PRIVATE TYPE.`
35			`--`
36			`-- CHECK FOR UNCONSTRAINED GENERIC FORMAL TYPE.`
37
38			`-- HISTORY:`
39			`-- AH 09/02/86 CREATED ORIGINAL TEST.`
40			`-- DHH 08/16/88 REVISED HEADER AND ENTERED COMMENTS FOR PRIVATE TYPE`
41			`-- AND CORRECTED INDENTATION.`
42			`-- BCB 04/12/90 ADDED CHECKS FOR AN ARRAY AS A SUBPROGRAM RETURN`
43			`-- TYPE AND AN ARRAY AS A FORMAL PARAMETER.`
44			`-- LDC 10/01/90 ADDED CODE SO F, FPROC, G, GPROC AREN'T OPTIMIZED`
45			`-- AWAY`
46
47			`WITH REPORT; USE REPORT;`
48			`PROCEDURE C38002A IS`
49
50			`BEGIN`
51			`TEST ("C38002A", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " &`
52			`"ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " &`
53			`"ARRAY OR RECORD TYPES");`
54
55			`DECLARE`
56			`C3 : CONSTANT INTEGER := IDENT_INT(3);`
57
58			`TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;`
59			`TYPE ARR_NAME IS ACCESS ARR;`
60			`SUBTYPE ARR_NAME_3 IS ARR_NAME(1..3);`
61
62			`TYPE REC(DISC : INTEGER) IS`
63			`RECORD`
64			`COMP : ARR_NAME(1..DISC);`
65			`END RECORD;`
66			`TYPE REC_NAME IS ACCESS REC;`
67
68			`OBJ : REC_NAME(C3);`
69
70			`TYPE ARR2 IS ARRAY (1..10) OF REC_NAME(C3);`
71
72			`TYPE REC2 IS`
73			`RECORD`
74			`COMP2 : REC_NAME(C3);`
75			`END RECORD;`
76
77			`TYPE NAME_REC_NAME IS ACCESS REC_NAME(C3);`
78
79			`TYPE DERIV IS NEW REC_NAME(C3);`
80			`SUBTYPE REC_NAME_3 IS REC_NAME(C3);`
81
82			`FUNCTION F (PARM : REC_NAME_3) RETURN REC_NAME_3 IS`
83			`BEGIN`
84			`IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN`
85			`COMMENT("DON'T OPTIMIZE F AWAY");`
86			`END IF;`
87			`RETURN PARM;`
88			`END;`
89
90			`PROCEDURE FPROC (PARM : REC_NAME_3) IS`
91			`BEGIN`
92			`IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN`
93			`COMMENT("DON'T OPTIMIZE FPROC AWAY");`
94			`END IF;`
95			`END FPROC;`
96
97			`FUNCTION G (PA : ARR_NAME_3) RETURN ARR_NAME_3 IS`
98			`BEGIN`
99			`IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN`
100			`COMMENT("DON'T OPTIMIZE G AWAY");`
101			`END IF;`
102			`RETURN PA;`
103			`END G;`
104
105			`PROCEDURE GPROC (PA : ARR_NAME_3) IS`
106			`BEGIN`
107			`IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN`
108			`COMMENT("DON'T OPTIMIZE GPROC AWAY");`
109			`END IF;`
110			`END GPROC;`
111
112			`BEGIN`
113			`DECLARE`
114			`R : REC_NAME;`
115			`BEGIN`
116			`R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));`
117			`R := F(R);`
118			`R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));`
119			`R := F(R);`
120			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
121			`"ACCEPTED BY FUNCTION FOR RECORD");`
122			`EXCEPTION`
123			`WHEN CONSTRAINT_ERROR =>`
124			`IF R = NULL OR ELSE R.DISC /= 4 THEN`
125			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &`
126			`"ACCESS VALUE - RECORD,FUNCTION");`
127			`END IF;`
128			`END;`
129
130			`DECLARE`
131			`R : REC_NAME;`
132			`BEGIN`
133			`R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5));`
134			`FPROC(R);`
135			`R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5));`
136			`FPROC(R);`
137			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
138			`"ACCEPTED BY PROCEDURE FOR RECORD");`
139			`EXCEPTION`
140			`WHEN CONSTRAINT_ERROR =>`
141			`IF R = NULL OR ELSE R.DISC /= 4 THEN`
142			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &`
143			`"ACCESS VALUE - RECORD,PROCEDURE");`
144			`END IF;`
145			`END;`
146
147			`DECLARE`
148			`A : ARR_NAME;`
149			`BEGIN`
150			`A := NEW ARR'(1..3 => 5);`
151			`A := G(A);`
152			`A := NEW ARR'(1..4 => 6);`
153			`A := G(A);`
154			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
155			`"ACCEPTED BY FUNCTION FOR ARRAY");`
156			`EXCEPTION`
157			`WHEN CONSTRAINT_ERROR =>`
158			`IF A = NULL OR ELSE A(4) /= 6 THEN`
159			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &`
160			`"ACCESS VALUE - ARRAY,FUNCTION");`
161			`END IF;`
162			`END;`
163
164			`DECLARE`
165			`A : ARR_NAME;`
166			`BEGIN`
167			`A := NEW ARR'(1..3 => 5);`
168			`GPROC(A);`
169			`A := NEW ARR'(1..4 => 6);`
170			`GPROC(A);`
171			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
172			`"ACCEPTED BY PROCEDURE FOR ARRAY");`
173			`EXCEPTION`
174			`WHEN CONSTRAINT_ERROR =>`
175			`IF A = NULL OR ELSE A(4) /= 6 THEN`
176			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " &`
177			`"ACCESS VALUE - ARRAY,PROCEDURE");`
178			`END IF;`
179			`END;`
180			`END;`
181
182			`DECLARE`
183			`C3 : CONSTANT INTEGER := IDENT_INT(3);`
184
185			`TYPE REC (DISC : INTEGER) IS`
186			`RECORD`
187			`NULL;`
188			`END RECORD;`
189
190			`TYPE P_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;`
191			`TYPE P_ARR_NAME IS ACCESS P_ARR;`
192
193			`TYPE P_REC_NAME IS ACCESS REC;`
194
195			`GENERIC`
196			`TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER;`
197			`PACKAGE P IS`
198			`TYPE ACC_REC IS ACCESS REC;`
199			`TYPE ACC_ARR IS ACCESS UNCON_ARR;`
200			`TYPE ACC_P_ARR IS ACCESS P_ARR;`
201			`SUBTYPE ACC_P_ARR_3 IS ACC_P_ARR(1..3);`
202			`OBJ : ACC_REC(C3);`
203
204			`TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3);`
205
206			`TYPE REC1 IS`
207			`RECORD`
208			`COMP1 : ACC_REC(C3);`
209			`END RECORD;`
210
211			`TYPE REC2 IS`
212			`RECORD`
213			`COMP2 : ACC_ARR(1..C3);`
214			`END RECORD;`
215
216			`SUBTYPE ACC_REC_3 IS ACC_REC(C3);`
217
218			`FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3;`
219
220			`PROCEDURE FPROC (PARM : ACC_REC_3);`
221
222			`FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3;`
223
224			`PROCEDURE GPROC (PA : ACC_P_ARR_3);`
225
226			`TYPE ACC1 IS PRIVATE;`
227			`TYPE ACC2 IS PRIVATE;`
228			`TYPE DER1 IS PRIVATE;`
229			`TYPE DER2 IS PRIVATE;`
230
231			`PRIVATE`
232
233			`TYPE ACC1 IS ACCESS ACC_REC(C3);`
234			`TYPE ACC2 IS ACCESS ACC_ARR(1..C3);`
235			`TYPE DER1 IS NEW ACC_REC(C3);`
236			`TYPE DER2 IS NEW ACC_ARR(1..C3);`
237			`END P;`
238
239			`PACKAGE BODY P IS`
240			`FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS`
241			`BEGIN`
242			`IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN`
243			`COMMENT("DON'T OPTIMIZE F AWAY");`
244			`END IF;`
245			`RETURN PARM;`
246			`END;`
247
248			`PROCEDURE FPROC (PARM : ACC_REC_3) IS`
249			`BEGIN`
250			`IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN`
251			`COMMENT("DON'T OPTIMIZE FPROC AWAY");`
252			`END IF;`
253			`END FPROC;`
254
255			`FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3 IS`
256			`BEGIN`
257			`IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN`
258			`COMMENT("DON'T OPTIMIZE G AWAY");`
259			`END IF;`
260			`RETURN PA;`
261			`END;`
262
263			`PROCEDURE GPROC (PA : ACC_P_ARR_3) IS`
264			`BEGIN`
265			`IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN`
266			`COMMENT("DON'T OPTIMIZE GPROC AWAY");`
267			`END IF;`
268			`END GPROC;`
269			`END P;`
270
271			`PACKAGE NP IS NEW P (UNCON_ARR => P_ARR);`
272
273			`USE NP;`
274
275			`BEGIN`
276			`DECLARE`
277			`R : ACC_REC;`
278			`BEGIN`
279			`R := NEW REC(DISC => 3);`
280			`R := F(R);`
281			`R := NEW REC(DISC => 4);`
282			`R := F(R);`
283			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
284			`"ACCEPTED BY FUNCTION FOR A RECORD -GENERIC");`
285			`EXCEPTION`
286			`WHEN CONSTRAINT_ERROR =>`
287			`IF R = NULL OR ELSE R.DISC /= 4 THEN`
288			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &`
289			`"OF ACCESS VALUE - RECORD," &`
290			`"FUNCTION -GENERIC");`
291			`END IF;`
292			`END;`
293
294			`DECLARE`
295			`R : ACC_REC;`
296			`BEGIN`
297			`R := NEW REC(DISC => 3);`
298			`FPROC(R);`
299			`R := NEW REC(DISC => 4);`
300			`FPROC(R);`
301			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
302			`"ACCEPTED BY PROCEDURE FOR A RECORD -GENERIC");`
303			`EXCEPTION`
304			`WHEN CONSTRAINT_ERROR =>`
305			`IF R = NULL OR ELSE R.DISC /= 4 THEN`
306			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &`
307			`"OF ACCESS VALUE - RECORD," &`
308			`"PROCEDURE -GENERIC");`
309			`END IF;`
310			`END;`
311
312			`DECLARE`
313			`A : ACC_P_ARR;`
314			`BEGIN`
315			`A := NEW P_ARR'(1..3 => 5);`
316			`A := G(A);`
317			`A := NEW P_ARR'(1..4 => 6);`
318			`A := G(A);`
319			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
320			`"ACCEPTED BY FUNCTION FOR AN ARRAY -GENERIC");`
321			`EXCEPTION`
322			`WHEN CONSTRAINT_ERROR =>`
323			`IF A = NULL OR ELSE A(4) /= 6 THEN`
324			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &`
325			`"OF ACCESS VALUE - ARRAY," &`
326			`"FUNCTION -GENERIC");`
327			`END IF;`
328			`END;`
329
330			`DECLARE`
331			`A : ACC_P_ARR;`
332			`BEGIN`
333			`A := NEW P_ARR'(1..3 => 5);`
334			`GPROC(A);`
335			`A := NEW P_ARR'(1..4 => 6);`
336			`GPROC(A);`
337			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
338			`"ACCEPTED BY PROCEDURE FOR AN ARRAY -GENERIC");`
339			`EXCEPTION`
340			`WHEN CONSTRAINT_ERROR =>`
341			`IF A = NULL OR ELSE A(4) /= 6 THEN`
342			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &`
343			`"OF ACCESS VALUE - ARRAY," &`
344			`"PROCEDURE -GENERIC");`
345			`END IF;`
346			`END;`
347			`END;`
348
349			`DECLARE`
350			`TYPE CON_INT IS RANGE 1..10;`
351
352			`GENERIC`
353			`TYPE UNCON_INT IS RANGE <>;`
354			`PACKAGE P2 IS`
355			`SUBTYPE NEW_INT IS UNCON_INT RANGE 1..5;`
356			`FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT;`
357
358			`PROCEDURE PROC_INT (PARM : NEW_INT);`
359			`END P2;`
360
361			`PACKAGE BODY P2 IS`
362			`FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT IS`
363			`BEGIN`
364			`IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN`
365			`COMMENT("DON'T OPTIMIZE F AWAY");`
366			`END IF;`
367			`RETURN PARM;`
368			`END FUNC_INT;`
369
370			`PROCEDURE PROC_INT (PARM : NEW_INT) IS`
371			`BEGIN`
372			`IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN`
373			`COMMENT("DON'T OPTIMIZE FPROC AWAY");`
374			`END IF;`
375			`END PROC_INT;`
376			`END P2;`
377
378			`PACKAGE NP2 IS NEW P2 (UNCON_INT => CON_INT);`
379
380			`USE NP2;`
381
382			`BEGIN`
383			`DECLARE`
384			`R : CON_INT;`
385			`BEGIN`
386			`R := 2;`
387			`R := FUNC_INT(R);`
388			`R := 8;`
389			`R := FUNC_INT(R);`
390			`FAILED ("INCOMPATIBLE CONSTRAINT ON VALUE " &`
391			`"ACCEPTED BY FUNCTION -GENERIC");`
392			`EXCEPTION`
393			`WHEN CONSTRAINT_ERROR =>`
394			`IF R /= 8 THEN`
395			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &`
396			`"OF VALUE -FUNCTION, GENERIC");`
397			`END IF;`
398			`END;`
399
400			`DECLARE`
401			`R : CON_INT;`
402			`BEGIN`
403			`R := 2;`
404			`PROC_INT(R);`
405			`R := 9;`
406			`PROC_INT(R);`
407			`FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " &`
408			`"ACCEPTED BY PROCEDURE -GENERIC");`
409			`EXCEPTION`
410			`WHEN CONSTRAINT_ERROR =>`
411			`IF R /= 9 THEN`
412			`FAILED ("ERROR IN EVALUATION/ASSIGNMENT " &`
413			`"OF ACCESS VALUE - PROCEDURE, " &`
414			`"GENERIC");`
415			`END IF;`
416			`END;`
417			`END;`
418
419			`RESULT;`
420			`END C38002A;`