Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c4/c48007b.ada @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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
33 WITH REPORT;
34
35 PROCEDURE C48007B IS
36
37 USE REPORT;
38
39 BEGIN
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
133 END C48007B;