Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c393011.a @ 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 -- C393011.A
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 --
26 -- TEST OBJECTIVE:
27 -- Check that an abstract extended type can be derived from an abstract
28 -- type, and that a a non-abstract type may then be derived from the
29 -- second abstract type.
30 --
31 -- TEST DESCRIPTION:
32 -- Define an abstract type with three primitive operations, two of them
33 -- abstract. Derive an extended type from it, inheriting the non-
34 -- abstract operation, overriding one of the abstract operations with
35 -- a non-abstract operation, and overriding the other abstract operation
36 -- with an abstract operation. The extended type is therefore abstract;
37 -- derive an extended type from it. Override the abstract operation with
38 -- a non-abstract operation; inherit one operation from the original
39 -- abstract type, and inherit one operation from the intermediate
40 -- abstract type.
41 --
42 --
43 -- CHANGE HISTORY:
44 -- 06 Dec 94 SAIC ACVC 2.0
45 --
46 --!
47
48 Package C393011_0 is
49 -- Definitions
50
51 type Status_Enum is (None, Unhandled, Pending, Handled);
52 type Serial_Type is new Integer range 0 .. Integer'Last;
53 subtype Priority_Type is Integer range 0..10;
54
55 type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen);
56
57 Next : Serial_Type := 1;
58 Display_Device : Display_Enum := Bit_Bucket;
59
60 end C393011_0;
61 -- Definitions;
62
63 --=======================================================================--
64
65 with C393011_0;
66 -- Definitions
67
68 Package C393011_1 is
69 -- Alert
70
71 package Definitions renames C393011_0;
72
73 type Alert_Type is abstract tagged record
74 Status : Definitions.Status_Enum := Definitions.None;
75 Serial_Num : Definitions.Serial_Type := 0;
76 Priority : Definitions.Priority_Type;
77 end record;
78 -- Alert_Type is an abstract type with
79 -- two operations to be overridden
80
81 procedure Set_Status ( A : in out Alert_Type; -- not abstract
82 To : Definitions.Status_Enum);
83
84 procedure Set_Serial ( A : in out Alert_Type) is abstract;
85 procedure Display ( A : Alert_Type) is abstract;
86
87 end C393011_1;
88 -- Alert
89
90 --=======================================================================--
91
92 with C393011_0;
93 package body C393011_1 is
94 -- Alert
95 procedure Set_Status ( A : in out Alert_Type;
96 To : Definitions.Status_Enum) is
97 begin
98 A.Status := To;
99 end Set_Status;
100
101 end C393011_1;
102 -- Alert;
103
104 --=======================================================================--
105
106 with C393011_0,
107 -- Definitions,
108 C393011_1,
109 -- Alert,
110 Calendar;
111
112 Package C393011_3 is
113 -- New_Alert
114
115 type New_Alert_Type is abstract new C393011_1.Alert_Type with record
116 Display_Dev : C393011_0.Display_Enum := C393011_0.TTY;
117 end record;
118
119 -- procedure Set_Status is inherited
120
121 procedure Set_Serial ( A : in out New_Alert_Type); -- override/see body
122
123 procedure Display ( A : New_Alert_Type) is abstract;
124 -- override is abstract
125 -- still can't declare objects of New_Alert_Type
126
127 end C393011_3;
128 -- New_Alert
129
130 --=======================================================================--
131
132 with C393011_0;
133 Package Body C393011_3 is
134 -- New_Alert
135
136 package Definitions renames C393011_0;
137
138 procedure Set_Serial (A : in out New_Alert_Type) is
139 use type Definitions.Serial_Type;
140 begin
141 A.Serial_Num := Definitions.Next;
142 Definitions.Next := Definitions."+"( Definitions.Next, 1);
143 end Set_Serial;
144
145 End C393011_3;
146 -- New_Alert;
147
148 --=======================================================================--
149
150 with C393011_0,
151 -- Definitions
152 C393011_3;
153 -- New_Alert -- package Alert is not visible
154 package C393011_4 is
155
156 package New_Alert renames C393011_3;
157 package Definitions renames C393011_0;
158
159 type Final_Alert_Type is new New_Alert.New_Alert_Type with null record;
160 -- inherits Set_Status including body
161 -- inherits Set_Serial including body
162 -- must override Display since inherited Display is abstract
163 procedure Display(FA : in Final_Alert_Type);
164 procedure Handle (FA : in out Final_Alert_Type);
165
166 end C393011_4;
167
168 package body C393011_4 is
169
170 procedure Display (FA : in Final_Alert_Type) is
171 begin
172 Definitions.Display_Device := FA.Display_Dev;
173 end Display;
174
175 procedure Handle (FA : in out Final_Alert_Type) is
176 begin
177 Set_Status (FA, Definitions.Handled);
178 Set_Serial (FA);
179 Display (FA);
180 end Handle;
181 end C393011_4;
182
183 with C393011_0,
184 -- Definitions
185 C393011_3;
186 -- New_Alert -- package Alert is not visible
187 with C393011_4;
188 with Report;
189 procedure C393011 is
190 use C393011_4;
191 use Definitions;
192
193 FA : Final_Alert_Type;
194
195 begin
196
197 Report.Test ("C393011", "Check that an extended type can be derived " &
198 "from an abstract type");
199
200 if (Definitions.Display_Device /= Definitions.Bit_Bucket)
201 or (Definitions.Next /= 1)
202 or (FA.Status /= Definitions.None)
203 or (FA.Serial_Num /= 0)
204 or (FA.Display_Dev /= TTY) then
205 Report.Failed ("Incorrect initial conditions");
206 end if;
207
208 Handle (FA);
209 if (Definitions.Display_Device /= Definitions.TTY)
210 or (Definitions.Next /= 2)
211 or (FA.Status /= Definitions.Handled)
212 or (FA.Serial_Num /= 1)
213 or (FA.Display_Dev /= TTY) then
214 Report.Failed ("Incorrect results from Handle");
215 end if;
216
217 Report.Result;
218
219 end C393011;
220