Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c6/c64104o.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 -- C64104O.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 CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL
27 -- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE
28 -- THE ACTUAL BOUNDS OR DISCRIMINANTS OF THE DESIGNATED OBJECT DIFFER
29 -- FROM THOSE OF THE FORMAL.
30
31 -- HISTORY
32 -- CPP 7/23/84 CREATED ORIGINAL TEST.
33 -- DHH 8/31/87 ADDED COMMENT IN PROCEDURE Q SO THAT CODE WILL NOT BE
34 -- OPTIMIZED OUT OF EXISTENCE.
35
36
37 WITH REPORT; USE REPORT;
38 PROCEDURE C64104O IS
39
40 BEGIN
41
42 TEST ("C64104O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " &
43 "CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER BOUNDS " &
44 "DIFFER");
45
46 DECLARE
47
48
49 CALLED : BOOLEAN := FALSE;
50
51 PACKAGE P IS
52 TYPE T IS PRIVATE;
53 DC : CONSTANT T;
54 GENERIC PACKAGE PP IS
55 END PP;
56 PRIVATE
57 TYPE T IS ACCESS STRING;
58 DC : CONSTANT T := NEW STRING'("AAA");
59 END P;
60
61 PROCEDURE Q (X : IN OUT P.T) IS
62
63 BEGIN
64
65 CALLED := TRUE;
66 X := P.DC;
67 IF P. "=" (X, P.DC) THEN
68 COMMENT("PROCEDURE Q WAS CALLED");
69 END IF;
70
71 EXCEPTION
72 WHEN OTHERS =>
73 FAILED ("EXCEPTION RAISED INSIDE SUBPROGRAM");
74 END Q;
75
76 GENERIC
77 Y : IN OUT P.T;
78 PACKAGE CALL IS
79 END CALL;
80
81 PACKAGE BODY CALL IS
82 BEGIN
83 Q(Y);
84 END CALL;
85
86 PACKAGE BODY P IS
87 Z : T(1..5) := NEW STRING'("CCCCC");
88 PACKAGE BODY PP IS
89 PACKAGE CALL_Q IS NEW CALL(Z);
90 END PP;
91 END P;
92
93 BEGIN
94 BEGIN
95 DECLARE
96 PACKAGE CALL_Q_NOW IS NEW P.PP;
97 BEGIN
98 FAILED ("NO EXCEPTION RAISED");
99 END;
100 EXCEPTION
101 WHEN CONSTRAINT_ERROR =>
102 IF NOT CALLED THEN
103 FAILED ("SUBPROGRAM Q WAS NOT CALLED");
104 END IF;
105 WHEN OTHERS =>
106 FAILED ("WRONG EXCEPTION RAISED");
107 END;
108
109 RESULT;
110 END;
111
112 END C64104O;