URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c380004.a] - Blame information for rev 720

Details | Compare with Previous | View Log


-- C380004.A
--
--                             Grant of Unlimited Rights
--
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
--     rights in the software and documentation contained herein. Unlimited
--     rights are the same as those granted by the U.S. Government for older
--     parts of the Ada Conformity Assessment Test Suite, and are defined
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--     intends to confer upon all recipients unlimited rights equal to those
--     held by the ACAA. These rights include rights to use, duplicate,
--     release or disclose the released technical data and computer software
--     in whole or in part, in any manner and for any purpose whatsoever, and
--     to have or permit others to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--    Check that per-object expressions are evaluated as specified for entry
--    families and protected components.  (Defect Report 8652/0002,
--    as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and
--    9.5.2(22/1)).
--
-- CHANGE HISTORY:
--     9 FEB 2001   PHL   Initial version.
--    29 JUN 2002   RLB   Readied for release.
--
--!
with Report;
use Report;
procedure C380004 is
 
    type Rec (D1, D2 : Positive) is
        record
            null;
        end record;
 
    F1_Poe : Integer;
 
    function Chk (Poe : Integer; Value : Integer; Message : String)
                 return Boolean is
    begin
        if Poe /= Value then
            Failed (Message & ": Poe is " & Integer'Image (Poe));
        end if;
        return True;
    end Chk;
 
    function F1 return Integer is
    begin
        F1_Poe := F1_Poe - Ident_Int (1);
        return F1_Poe;
    end F1;
 
    generic
        type T is limited private;
        with function Is_Ok (X : T;
                             Param1 : Integer;
                             Param2 : Integer;
                             Param3 : Integer) return Boolean;
    procedure Check;
 
    procedure Check is
    begin
 
        declare
            type Poe is new T;
            Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated");
            X : Poe;             -- F1 evaluated
            Y : Poe;             -- F1 evaluated
            Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated");
        begin
            if not Is_Ok (T (X), 16, 16, 17) or
               not Is_Ok (T (Y), 15, 15, 17) then
                Failed ("Discriminant values not correct - 0");
            end if;
        end;
 
        declare
            type Poe is new T;
        begin
            begin
                declare
                    X : Poe;
                begin
                    if not Is_Ok (T (X), 14, 14, 17) then
                        Failed ("Discriminant values not correct - 1");
                    end if;
                end;
            exception
                when others =>
                    Failed ("Unexpected exception - 1");
            end;
 
            declare
                type Acc_Poe is access Poe;
                X : Acc_Poe;
            begin
                X := new Poe;
                begin
                    if not Is_Ok (T (X.all), 13, 13, 17) then
                        Failed ("Discriminant values not correct - 2");
                    end if;
                end;
            exception
                when others =>
                    Failed ("Unexpected exception raised - 2");
            end;
 
            declare
                subtype Spoe is Poe;
                X : Spoe;
            begin
                if not Is_Ok (T (X), 12, 12, 17) then
                    Failed ("Discriminant values not correct - 3");
                end if;
            exception
                when others =>
                    Failed ("Unexpected exception raised - 3");
            end;
 
            declare
                type Arr is array (1 .. 2) of Poe;
                X : Arr;
            begin
                if Is_Ok (T (X (1)), 11, 11, 17) and then
                   Is_Ok (T (X (2)), 10, 10, 17) then
                    null;
                elsif Is_Ok (T (X (2)), 11, 11, 17) and then
                      Is_Ok (T (X (1)), 10, 10, 17) then
                    null;
                else
                    Failed ("Discriminant values not correct - 4");
                end if;
            exception
                when others =>
                    Failed ("Unexpected exception raised - 4");
            end;
 
            declare
                type Nrec is
                    record
                        C1, C2 : Poe;
                    end record;
                X : Nrec;
            begin
                if Is_Ok (T (X.C1), 8, 8, 17) and then
                   Is_Ok (T (X.C2), 9, 9, 17) then
                    null;
                elsif Is_Ok (T (X.C2), 8, 8, 17) and then
                      Is_Ok (T (X.C1), 9, 9, 17) then
                    null;
                else
                    Failed ("Discriminant values not correct - 5");
                end if;
            exception
                when others =>
                    Failed ("Unexpected exception raised - 5");
            end;
 
            declare
                type Drec is new Poe;
                X : Drec;
            begin
                if not Is_Ok (T (X), 7, 7, 17) then
                    Failed ("Discriminant values not correct - 6");
                end if;
            exception
                when others =>
                    Failed ("Unexpected exception raised - 6");
            end;
        end;
    end Check;
 
 
begin
    Test ("C380004",
          "Check evaluation of discriminant expressions " &
             "when the constraint depends on a discriminant, " &
             "and the discriminants have defaults - discriminant-dependent" &
             "entry families and protected components");
 
 
    Comment ("Discriminant-dependent entry families for task types");
 
    F1_Poe := 18;
 
    declare
        task type Poe (D3 : Positive := F1) is
            entry E (D3 .. F1);    -- F1 evaluated
            entry Is_Ok (D3 : Integer;
                         E_First : Integer;
                         E_Last : Integer;
                         Ok : out Boolean);
        end Poe;
        task body Poe is
        begin
            loop
                select
                    accept Is_Ok (D3 : Integer;
                                  E_First : Integer;
                                  E_Last : Integer;
                                  Ok : out Boolean) do
                        declare
                            Cnt : Natural;
                        begin
                            if Poe.D3 = D3 then
                                -- Can't think of a better way to check the
                                -- bounds of the entry family.
                                begin
                                    Cnt := E (E_First)'Count;
                                    Cnt := E (E_Last)'Count;
                                exception
                                    when Constraint_Error =>
                                        Ok := False;
                                        return;
                                end;
                                begin
                                    Cnt := E (E_First - 1)'Count;
                                    Ok := False;
                                    return;
                                exception
                                    when Constraint_Error =>
                                        null;
                                    when others =>
                                        Ok := False;
                                        return;
                                end;
                                begin
                                    Cnt := E (E_Last + 1)'Count;
                                    Ok := False;
                                    return;
                                exception
                                    when Constraint_Error =>
                                        null;
                                    when others =>
                                        Ok := False;
                                        return;
                                end;
                                Ok := True;
                            else
                                Ok := False;
                                return;
                            end if;
                        end;
                    end Is_Ok;
                or
                    terminate;
                end select;
            end loop;
        end Poe;
 
        function Is_Ok
                    (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
                    return Boolean is
            Ok : Boolean;
        begin
            C.Is_Ok (D3, E_First, E_Last, Ok);
            return Ok;
        end Is_Ok;
 
        procedure Chk is new Check (Poe, Is_Ok);
 
    begin
        Chk;
    end;
 
 
    Comment ("Discriminant-dependent entry families for protected types");
 
    F1_Poe := 18;
 
    declare
        protected type Poe (D3 : Integer := F1) is
            entry E (D3 .. F1);    -- F1 evaluated
            function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
                           return Boolean;
        end Poe;
        protected body Poe is
            entry E (for I in D3 .. F1) when True is
            begin
                null;
            end E;
            function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer)
                           return Boolean is
                Cnt : Natural;
            begin
                if Poe.D3 = D3 then
                    -- Can't think of a better way to check the
                    -- bounds of the entry family.
                    begin
                        Cnt := E (E_First)'Count;
                        Cnt := E (E_Last)'Count;
                    exception
                        when Constraint_Error =>
                            return False;
                    end;
                    begin
                        Cnt := E (E_First - 1)'Count;
                        return False;
                    exception
                        when Constraint_Error =>
                            null;
                        when others =>
                            return False;
                    end;
                    begin
                        Cnt := E (E_Last + 1)'Count;
                        return False;
                    exception
                        when Constraint_Error =>
                            null;
                        when others =>
                            return False;
                    end;
                    return True;
                else
                    return False;
                end if;
            end Is_Ok;
        end Poe;
 
        function Is_Ok
                    (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer)
                    return Boolean is
        begin
            return C.Is_Ok (D3, E_First, E_Last);
        end Is_Ok;
 
        procedure Chk is new Check (Poe, Is_Ok);
 
    begin
        Chk;
    end;
 
    Comment ("Protected components");
 
    F1_Poe := 18;
 
    declare
        protected type Poe (D3 : Integer := F1) is
            function C1_D1 return Integer;
            function C1_D2 return Integer;
        private
            C1 : Rec (D3, F1);    -- F1 evaluated
        end Poe;
        protected body Poe is
            function C1_D1 return Integer is
            begin
                return C1.D1;
            end C1_D1;
            function C1_D2 return Integer is
            begin
                return C1.D2;
            end C1_D2;
        end Poe;
 
        function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
                       return Boolean is
        begin
            return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
        end Is_Ok;
 
        procedure Chk is new Check (Poe, Is_Ok);
 
    begin
        Chk;
    end;
 
    Result;
 
exception
    when others =>
        Failed ("Unexpected exception");
        Result;
 
end C380004;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c380004.a] - Blame information for rev 720

Line No.	Rev	Author	Line
1	720	jeremybenn	`-- 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			`--!`
37			`with Report;`
38			`use Report;`
39			`procedure 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
184			`begin`
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
380			`exception`
381			`when others =>`
382			`Failed ("Unexpected exception");`
383			`Result;`
384
385			`end C380004;`