Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c34009a.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 -- C34009A.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 THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED
27 -- (IMPLICITLY) FOR DERIVED NON-LIMITED PRIVATE TYPES WITHOUT
28 -- DISCRIMINANTS.
29
30 -- HISTORY:
31 -- JRK 08/28/87 CREATED ORIGINAL TEST.
32 -- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE.
33 -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X.
34 -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X.
35
36 WITH SYSTEM; USE SYSTEM;
37 WITH REPORT; USE REPORT;
38
39 PROCEDURE C34009A IS
40
41 PACKAGE PKG IS
42
43 TYPE PARENT IS PRIVATE;
44
45 FUNCTION CREATE (X : INTEGER) RETURN PARENT;
46
47 FUNCTION CON (X : INTEGER) RETURN PARENT;
48
49 PRIVATE
50
51 TYPE PARENT IS NEW INTEGER;
52
53 END PKG;
54
55 USE PKG;
56
57 TYPE T IS NEW PARENT;
58
59 X : T;
60 K : INTEGER := X'SIZE;
61 W : PARENT;
62 B : BOOLEAN := FALSE;
63
64 PROCEDURE A (X : ADDRESS) IS
65 BEGIN
66 B := IDENT_BOOL (TRUE);
67 END A;
68
69 PACKAGE BODY PKG IS
70
71 FUNCTION CREATE (X : INTEGER) RETURN PARENT IS
72 BEGIN
73 RETURN PARENT (IDENT_INT (X));
74 END CREATE;
75
76 FUNCTION CON (X : INTEGER) RETURN PARENT IS
77 BEGIN
78 RETURN PARENT (X);
79 END CON;
80
81 END PKG;
82
83 BEGIN
84 TEST ("C34009A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " &
85 "ARE DECLARED (IMPLICITLY) FOR DERIVED " &
86 "NON-LIMITED PRIVATE TYPES WITHOUT " &
87 "DISCRIMINANTS");
88
89 X := CREATE (30);
90 IF X /= CON (30) THEN
91 FAILED ("INCORRECT :=");
92 END IF;
93
94 IF T'(X) /= CON (30) THEN
95 FAILED ("INCORRECT QUALIFICATION");
96 END IF;
97
98 IF T (X) /= CON (30) THEN
99 FAILED ("INCORRECT SELF CONVERSION");
100 END IF;
101
102 W := CREATE (-30);
103 IF T (W) /= CON (-30) THEN
104 FAILED ("INCORRECT CONVERSION FROM PARENT");
105 END IF;
106
107 IF PARENT (X) /= CON (30) THEN
108 FAILED ("INCORRECT CONVERSION TO PARENT");
109 END IF;
110
111 IF X = CON (0) THEN
112 FAILED ("INCORRECT =");
113 END IF;
114
115 IF X /= CON (30) THEN
116 FAILED ("INCORRECT /=");
117 END IF;
118
119 IF NOT (X IN T) THEN
120 FAILED ("INCORRECT ""IN""");
121 END IF;
122
123 IF X NOT IN T THEN
124 FAILED ("INCORRECT ""NOT IN""");
125 END IF;
126
127 B := FALSE;
128 A (X'ADDRESS);
129 IF NOT B THEN
130 FAILED ("INCORRECT 'ADDRESS");
131 END IF;
132
133 RESULT;
134 END C34009A;