1-- C380004.A
2--
3--                             Grant of Unlimited Rights
4--
5--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
6--     rights in the software and documentation contained herein. Unlimited
7--     rights are the same as those granted by the U.S. Government for older
8--     parts of the Ada Conformity Assessment Test Suite, and are defined
9--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10--     intends to confer upon all recipients unlimited rights equal to those
11--     held by the ACAA. These rights include rights to use, duplicate,
12--     release or disclose the released technical data and computer software
13--     in whole or in part, in any manner and for any purpose whatsoever, and
14--     to have or permit others to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS. THE ACAA 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-- OBJECTIVE:
27--    Check that per-object expressions are evaluated as specified for entry
28--    families and protected components.  (Defect Report 8652/0002,
29--    as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and
30--    9.5.2(22/1)).
31--
32-- CHANGE HISTORY:
33--     9 FEB 2001   PHL   Initial version.
34--    29 JUN 2002   RLB   Readied for release.
35--
36--!
37with Report;
38use Report;
39procedure C380004 is
40
41    type Rec (D1, D2 : Positive) is
42        record
43            null;
44        end record;
45
46    F1_Poe : Integer;
47
48    function Chk (Poe : Integer; Value : Integer; Message : String)
49                 return Boolean is
50    begin
51        if Poe /= Value then
52            Failed (Message & ": Poe is " & Integer'Image (Poe));
53        end if;
54        return True;
55    end Chk;
56
57    function F1 return Integer is
58    begin
59        F1_Poe := F1_Poe - Ident_Int (1);
60        return F1_Poe;
61    end F1;
62
63    generic
64        type T is limited private;
65        with function Is_Ok (X : T;
66                             Param1 : Integer;
67                             Param2 : Integer;
68                             Param3 : Integer) return Boolean;
69    procedure Check;
70
71    procedure Check is
72    begin
73
74        declare
75            type Poe is new T;
76            Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated");
77            X : Poe;             -- F1 evaluated
78            Y : Poe;             -- F1 evaluated
79            Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated");
80        begin
81            if not Is_Ok (T (X), 16, 16, 17) or
82               not Is_Ok (T (Y), 15, 15, 17) then
83                Failed ("Discriminant values not correct - 0");
84            end if;
85        end;
86
87        declare
88            type Poe is new T;
89        begin
90            begin
91                declare
92                    X : Poe;
93                begin
94                    if not Is_Ok (T (X), 14, 14, 17) then
95                        Failed ("Discriminant values not correct - 1");
96                    end if;
97                end;
98            exception
99                when others =>
100                    Failed ("Unexpected exception - 1");
101            end;
102
103            declare
104                type Acc_Poe is access Poe;
105                X : Acc_Poe;
106            begin
107                X := new Poe;
108                begin
109                    if not Is_Ok (T (X.all), 13, 13, 17) then
110                        Failed ("Discriminant values not correct - 2");
111                    end if;
112                end;
113            exception
114                when others =>
115                    Failed ("Unexpected exception raised - 2");
116            end;
117
118            declare
119                subtype Spoe is Poe;
120                X : Spoe;
121            begin
122                if not Is_Ok (T (X), 12, 12, 17) then
123                    Failed ("Discriminant values not correct - 3");
124                end if;
125            exception
126                when others =>
127                    Failed ("Unexpected exception raised - 3");
128            end;
129
130            declare
131                type Arr is array (1 .. 2) of Poe;
132                X : Arr;
133            begin
134                if Is_Ok (T (X (1)), 11, 11, 17) and then
135                   Is_Ok (T (X (2)), 10, 10, 17) then
136                    null;
137                elsif Is_Ok (T (X (2)), 11, 11, 17) and then
138                      Is_Ok (T (X (1)), 10, 10, 17) then
139                    null;
140                else
141                    Failed ("Discriminant values not correct - 4");
142                end if;
143            exception
144                when others =>
145                    Failed ("Unexpected exception raised - 4");
146            end;
147
148            declare
149                type Nrec is
150                    record
151                        C1, C2 : Poe;
152                    end record;
153                X : Nrec;
154            begin
155                if Is_Ok (T (X.C1), 8, 8, 17) and then
156                   Is_Ok (T (X.C2), 9, 9, 17) then
157                    null;
158                elsif Is_Ok (T (X.C2), 8, 8, 17) and then
159                      Is_Ok (T (X.C1), 9, 9, 17) then
160                    null;
161                else
162                    Failed ("Discriminant values not correct - 5");
163                end if;
164            exception
165                when others =>
166                    Failed ("Unexpected exception raised - 5");
167            end;
168
169            declare
170                type Drec is new Poe;
171                X : Drec;
172            begin
173                if not Is_Ok (T (X), 7, 7, 17) then
174                    Failed ("Discriminant values not correct - 6");
175                end if;
176            exception
177                when others =>
178                    Failed ("Unexpected exception raised - 6");
179            end;
180        end;
181    end Check;
182
183
184begin
185    Test ("C380004",
186          "Check evaluation of discriminant expressions " &
187             "when the constraint depends on a discriminant, " &
188             "and the discriminants have defaults - discriminant-dependent" &
189             "entry families and protected components");
190
191
192    Comment ("Discriminant-dependent entry families for task types");
193
194    F1_Poe := 18;
195
196    declare
197        task type Poe (D3 : Positive := F1) is
198            entry E (D3 .. F1);    -- F1 evaluated
199            entry Is_Ok (D3 : Integer;
200                         E_First : Integer;
201                         E_Last : Integer;
202                         Ok : out Boolean);
203        end Poe;
204        task body Poe is
205        begin
206            loop
207                select
208                    accept Is_Ok (D3 : Integer;
209                                  E_First : Integer;
210                                  E_Last : Integer;
211                                  Ok : out Boolean) do
212                        declare
213                            Cnt : Natural;
214                        begin
215                            if Poe.D3 = D3 then
216                                -- Can't think of a better way to check the
217                                -- bounds of the entry family.
218                                begin
219                                    Cnt := E (E_First)'Count;
220                                    Cnt := E (E_Last)'Count;
221                                exception
222                                    when Constraint_Error =>
223                                        Ok := False;
224                                        return;
225                                end;
226                                begin
227                                    Cnt := E (E_First - 1)'Count;
228                                    Ok := False;
229                                    return;
230                                exception
231                                    when Constraint_Error =>
232                                        null;
233                                    when others =>
234                                        Ok := False;
235                                        return;
236                                end;
237                                begin
238                                    Cnt := E (E_Last + 1)'Count;
239                                    Ok := False;
240                                    return;
241                                exception
242                                    when Constraint_Error =>
243                                        null;
244                                    when others =>
245                                        Ok := False;
246                                        return;
247                                end;
248                                Ok := True;
249                            else
250                                Ok := False;
251                                return;
252                            end if;
253                        end;
254                    end Is_Ok;
255                or
256                    terminate;
257                end select;
258            end loop;
259        end Poe;
260
261        function Is_Ok
262                    (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
263                    return Boolean is
264            Ok : Boolean;
265        begin
266            C.Is_Ok (D3, E_First, E_Last, Ok);
267            return Ok;
268        end Is_Ok;
269
270        procedure Chk is new Check (Poe, Is_Ok);
271
272    begin
273        Chk;
274    end;
275
276
277    Comment ("Discriminant-dependent entry families for protected types");
278
279    F1_Poe := 18;
280
281    declare
282        protected type Poe (D3 : Integer := F1) is
283            entry E (D3 .. F1);    -- F1 evaluated
284            function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
285                           return Boolean;
286        end Poe;
287        protected body Poe is
288            entry E (for I in D3 .. F1) when True is
289            begin
290                null;
291            end E;
292            function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
293                           return Boolean is
294                Cnt : Natural;
295            begin
296                if Poe.D3 = D3 then
297                    -- Can't think of a better way to check the
298                    -- bounds of the entry family.
299                    begin
300                        Cnt := E (E_First)'Count;
301                        Cnt := E (E_Last)'Count;
302                    exception
303                        when Constraint_Error =>
304                            return False;
305                    end;
306                    begin
307                        Cnt := E (E_First - 1)'Count;
308                        return False;
309                    exception
310                        when Constraint_Error =>
311                            null;
312                        when others =>
313                            return False;
314                    end;
315                    begin
316                        Cnt := E (E_Last + 1)'Count;
317                        return False;
318                    exception
319                        when Constraint_Error =>
320                            null;
321                        when others =>
322                            return False;
323                    end;
324                    return True;
325                else
326                    return False;
327                end if;
328            end Is_Ok;
329        end Poe;
330
331        function Is_Ok
332                    (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
333                    return Boolean is
334        begin
335            return C.Is_Ok (D3, E_First, E_Last);
336        end Is_Ok;
337
338        procedure Chk is new Check (Poe, Is_Ok);
339
340    begin
341        Chk;
342    end;
343
344    Comment ("Protected components");
345
346    F1_Poe := 18;
347
348    declare
349        protected type Poe (D3 : Integer := F1) is
350            function C1_D1 return Integer;
351            function C1_D2 return Integer;
352        private
353            C1 : Rec (D3, F1);    -- F1 evaluated
354        end Poe;
355        protected body Poe is
356            function C1_D1 return Integer is
357            begin
358                return C1.D1;
359            end C1_D1;
360            function C1_D2 return Integer is
361            begin
362                return C1.D2;
363            end C1_D2;
364        end Poe;
365
366        function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
367                       return Boolean is
368        begin
369            return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
370        end Is_Ok;
371
372        procedure Chk is new Check (Poe, Is_Ok);
373
374    begin
375        Chk;
376    end;
377
378    Result;
379
380exception
381    when others =>
382        Failed ("Unexpected exception");
383        Result;
384
385end C380004;
386