1-- C48007B.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-- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS
26-- RAISED IF T IS A CONSTRAINED TYPE WITH DISCRIMINANTS (RECORD, PRIVATE
27-- OR LIMITED) AND AT LEAST ONE DISCRIMINANT VALUE SPECIFIED FOR T DOES
28-- NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE ALLOCATOR'S BASE
29-- TYPE.
30
31-- EG  08/10/84
32
33WITH REPORT;
34
35PROCEDURE C48007B IS
36
37     USE REPORT;
38
39BEGIN
40
41     TEST("C48007B","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " &
42                    "THAT CONSTRAINT_ERROR IS RAISED WHEN "     &
43                    "APPROPRIATE - CONSTRAINED TYPE WITH "      &
44                    "DISCRIMINANT");
45
46     DECLARE
47
48          TYPE UR(A, B : INTEGER) IS
49               RECORD
50                    C : INTEGER;
51               END RECORD;
52
53          PACKAGE P IS
54
55               TYPE UP(A, B : INTEGER) IS PRIVATE;
56               TYPE UL(A, B : INTEGER) IS LIMITED PRIVATE;
57
58          PRIVATE
59
60               TYPE UP(A, B : INTEGER) IS
61                    RECORD
62                         C : INTEGER;
63                    END RECORD;
64               TYPE UL(A, B : INTEGER) IS
65                    RECORD
66                         C : INTEGER;
67                    END RECORD;
68
69          END P;
70
71          USE P;
72
73          SUBTYPE CR IS UR(1, 2);
74          SUBTYPE CP IS UP(12, 13);
75          SUBTYPE CL IS UL(4, 4);
76
77          TYPE A_UR IS ACCESS UR(1, 9);
78          TYPE A_UP IS ACCESS UP(9, 13);
79          TYPE A_UL IS ACCESS UL(4, 9);
80
81          VUR : A_UR;
82          VUP : A_UP;
83          VUL : A_UL;
84
85     BEGIN
86
87          BEGIN -- CR
88
89               VUR := NEW CR;
90               FAILED("NO EXCEPTION RAISED - CR");
91
92          EXCEPTION
93
94               WHEN CONSTRAINT_ERROR =>
95                    NULL;
96               WHEN OTHERS =>
97                    FAILED("WRONG EXCEPTION RAISED - CR");
98
99          END;
100
101          BEGIN -- CP
102
103               VUP := NEW CP;
104               FAILED("NO EXCEPTION RAISED - CP");
105
106          EXCEPTION
107
108               WHEN CONSTRAINT_ERROR =>
109                    NULL;
110               WHEN OTHERS =>
111                    FAILED("WRONG EXCEPTION RAISED - CP");
112
113          END;
114
115          BEGIN -- CL
116
117               VUL := NEW CL;
118               FAILED("NO EXCEPTION RAISED - CL");
119
120          EXCEPTION
121
122               WHEN CONSTRAINT_ERROR =>
123                    NULL;
124               WHEN OTHERS =>
125                    FAILED("WRONG EXCEPTION RAISED - CL");
126
127          END;
128
129     END;
130
131     RESULT;
132
133END C48007B;
134