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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c8/] [c85018b.ada] - Blame information for rev 316

Go to most recent revision | Details | Compare with Previous | View Log


-- C85018B.ADA
 
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     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 GOVERNMENT 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 WHEN AN ENTRY FAMILY MEMBER IS RENAMED THE FORMAL
--     PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN
--     FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY.
 
-- HISTORY:
--     RJW 06/03/86 CREATED ORIGINAL TEST.
--     DHH 10/15/87 CORRECTED RANGE ERRORS.
--     GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY (INDEX CONSTRAINT).
--     PWN 10/24/96 RESTORED CHECKS WITH ADA 95 RESULTS NOW EXPECTED.
--     PWN 12/11/96 ADJUSTED VALUES FOR ADA 95 COMPATIBILITY.
--     PWB.CTA 2/17/97 CHANGED CALL TO ENT2 TO NOT EXPECT EXCEPTION
 
WITH REPORT; USE REPORT;
 
PROCEDURE C85018B IS
 
BEGIN
 
     TEST( "C85018B", "CHECK THAT WHEN AN ENTRY FAMILY MEMBER IS " &
                      "RENAMED THE FORMAL PARAMETER CONSTRAINTS "  &
                      "FOR THE NEW NAME ARE IGNORED IN FAVOR OF " &
                      "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED " &
                      "ENTITY" );
 
     DECLARE
          TYPE INT IS RANGE 1 .. 10;
          SUBTYPE INT1 IS INT RANGE 1 .. 5;
          SUBTYPE INT2 IS INT RANGE 6 .. 10;
 
          OBJ1 : INT1 := 5;
          OBJ2 : INT2 := 6;
 
          SUBTYPE SHORTCHAR IS CHARACTER RANGE 'A' .. 'C';
 
          TASK T IS
               ENTRY ENT1 (SHORTCHAR)
                    (A : INT1; OK : BOOLEAN);
          END T;
 
          PROCEDURE ENT2 (A : INT2; OK : BOOLEAN)
               RENAMES T.ENT1 ('C');
 
          TASK BODY T IS
          BEGIN
               LOOP
                    SELECT
                         ACCEPT ENT1 ('C')
                                     (A : INT1; OK : BOOLEAN) DO
                              IF NOT OK THEN
                                   FAILED ( "WRONG CALL EXECUTED " &
                                            "WITH INTEGER TYPE" );
                              END IF;
                         END;
                    OR
                         TERMINATE;
                    END SELECT;
               END LOOP;
          END T;
     BEGIN
          BEGIN
               ENT2 (OBJ1, TRUE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR  =>
                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
                             "INTEGER TYPE" );
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "INTEGER TYPE - 1" );
          END;
 
          BEGIN
               ENT2 (OBJ2, TRUE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "INTEGER TYPE - 2" );
          END;
     END;
 
     DECLARE
          TYPE REAL IS DIGITS 3;
          SUBTYPE REAL1 IS REAL RANGE -2.0 .. 0.0;
          SUBTYPE REAL2 IS REAL RANGE  0.0 .. 2.0;
 
          OBJ1 : REAL1 := -0.25;
          OBJ2 : REAL2 :=  0.25;
 
          SUBTYPE SHORTINT IS INTEGER RANGE 9 .. 11;
 
          TASK T IS
               ENTRY ENT1 (SHORTINT)
                    (A : REAL1; OK : BOOLEAN);
          END T;
 
          PROCEDURE ENT2 (A : REAL2; OK : BOOLEAN)
               RENAMES T.ENT1 (10);
 
          TASK BODY T IS
          BEGIN
               LOOP
                    SELECT
                         ACCEPT ENT1 (10)
                                     (A : REAL1; OK : BOOLEAN) DO
                              IF NOT OK THEN
                                   FAILED ( "WRONG CALL EXECUTED " &
                                            "WITH FLOATING POINT " &
                                            "TYPE" );
                              END IF;
                         END;
                    OR
                         TERMINATE;
                    END SELECT;
               END LOOP;
          END T;
     BEGIN
          BEGIN
               ENT2 (OBJ1, TRUE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR  =>
                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
                             "FLOATING POINT " &
                             "TYPE" );
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "FLOATING POINT " &
                             "TYPE - 1" );
          END;
 
          BEGIN
               ENT2 (OBJ2, FALSE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "FLOATING POINT " &
                             "TYPE - 2" );
          END;
     END;
 
     DECLARE
          TYPE COLOR IS (RED, YELLOW, BLUE, GREEN);
 
          TYPE FIXED IS DELTA  0.125 RANGE -1.0 .. 1.0;
          SUBTYPE FIXED1 IS FIXED RANGE  0.0 .. 0.5;
          SUBTYPE FIXED2 IS FIXED RANGE -0.5 .. 0.0;
 
          OBJ1 : FIXED1 :=  0.125;
          OBJ2 : FIXED2 := -0.125;
 
          TASK T IS
               ENTRY ENT1 (COLOR)
                    (A : FIXED1; OK : BOOLEAN);
          END T;
 
          PROCEDURE ENT2 (A : FIXED2; OK : BOOLEAN)
               RENAMES T.ENT1 (BLUE);
 
          TASK BODY T IS
          BEGIN
               LOOP
                    SELECT
                         ACCEPT ENT1 (BLUE)
                                     (A : FIXED1; OK : BOOLEAN) DO
                              IF NOT OK THEN
                                   FAILED ( "WRONG CALL EXECUTED " &
                                            "WITH FIXED POINT " &
                                            "TYPE" );
                              END IF;
                         END;
                    OR
                         TERMINATE;
                    END SELECT;
               END LOOP;
          END T;
     BEGIN
          BEGIN
               ENT2 (OBJ1, TRUE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR  =>
                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
                             "FIXED POINT " &
                             "TYPE" );
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "FIXED POINT " &
                             "TYPE - 1" );
          END;
 
          BEGIN
               ENT2 (OBJ2, FALSE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    NULL;
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "FIXED POINT " &
                             "TYPE - 2" );
          END;
     END;
 
     DECLARE
          TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER;
          SUBTYPE STA1 IS TA(1 .. 5);
          SUBTYPE STA2 IS TA(6 .. 10);
 
          OBJ1 : STA1 := (1, 2, 3, 4, 5);
          OBJ2 : STA2 := (6, 7, 8, 9, 10);
 
          TASK T IS
               ENTRY ENT1 (BOOLEAN)
                    (A : STA1; OK : BOOLEAN);
          END T;
 
          PROCEDURE ENT2 (A : STA2; OK : BOOLEAN)
               RENAMES T.ENT1 (FALSE);
 
          TASK BODY T IS
          BEGIN
               LOOP
                    SELECT
                         ACCEPT ENT1 (FALSE)
                                     (A : STA1; OK : BOOLEAN) DO
                              IF NOT OK THEN
                                   FAILED ( "WRONG CALL EXECUTED " &
                                            "WITH CONSTRAINED " &
                                            "ARRAY" );
                              END IF;
                         END;
                    OR
                         TERMINATE;
                    END SELECT;
               END LOOP;
          END T;
     BEGIN
          BEGIN
               ENT2 (OBJ1, TRUE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR  =>
                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
                             "CONSTRAINED ARRAY" );
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "CONSTRAINED ARRAY - 1" );
          END;
 
          BEGIN
               ENT2 (OBJ2, TRUE);
          EXCEPTION
               WHEN CONSTRAINT_ERROR =>
                    FAILED ( "CONSTRAINT_ERROR RAISED WITH " &
                             "CONSTRAINED ARRAY" );
               WHEN OTHERS =>
                    FAILED ( "OTHER EXCEPTION RAISED WITH " &
                             "CONSTRAINED ARRAY - 2" );
          END;
     END;
 
     RESULT;
 
END C85018B;

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c8/] [c85018b.ada] - Blame information for rev 316

Line No.	Rev	Author	Line
1	294	jeremybenn	`-- C85018B.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 WHEN AN ENTRY FAMILY MEMBER IS RENAMED THE FORMAL`
27			`-- PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN`
28			`-- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY.`
29
30			`-- HISTORY:`
31			`-- RJW 06/03/86 CREATED ORIGINAL TEST.`
32			`-- DHH 10/15/87 CORRECTED RANGE ERRORS.`
33			`-- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY (INDEX CONSTRAINT).`
34			`-- PWN 10/24/96 RESTORED CHECKS WITH ADA 95 RESULTS NOW EXPECTED.`
35			`-- PWN 12/11/96 ADJUSTED VALUES FOR ADA 95 COMPATIBILITY.`
36			`-- PWB.CTA 2/17/97 CHANGED CALL TO ENT2 TO NOT EXPECT EXCEPTION`
37
38			`WITH REPORT; USE REPORT;`
39
40			`PROCEDURE C85018B IS`
41
42			`BEGIN`
43
44			`TEST( "C85018B", "CHECK THAT WHEN AN ENTRY FAMILY MEMBER IS " &`
45			`"RENAMED THE FORMAL PARAMETER CONSTRAINTS " &`
46			`"FOR THE NEW NAME ARE IGNORED IN FAVOR OF " &`
47			`"THE CONSTRAINTS ASSOCIATED WITH THE RENAMED " &`
48			`"ENTITY" );`
49
50			`DECLARE`
51			`TYPE INT IS RANGE 1 .. 10;`
52			`SUBTYPE INT1 IS INT RANGE 1 .. 5;`
53			`SUBTYPE INT2 IS INT RANGE 6 .. 10;`
54
55			`OBJ1 : INT1 := 5;`
56			`OBJ2 : INT2 := 6;`
57
58			`SUBTYPE SHORTCHAR IS CHARACTER RANGE 'A' .. 'C';`
59
60			`TASK T IS`
61			`ENTRY ENT1 (SHORTCHAR)`
62			`(A : INT1; OK : BOOLEAN);`
63			`END T;`
64
65			`PROCEDURE ENT2 (A : INT2; OK : BOOLEAN)`
66			`RENAMES T.ENT1 ('C');`
67
68			`TASK BODY T IS`
69			`BEGIN`
70			`LOOP`
71			`SELECT`
72			`ACCEPT ENT1 ('C')`
73			`(A : INT1; OK : BOOLEAN) DO`
74			`IF NOT OK THEN`
75			`FAILED ( "WRONG CALL EXECUTED " &`
76			`"WITH INTEGER TYPE" );`
77			`END IF;`
78			`END;`
79			`OR`
80			`TERMINATE;`
81			`END SELECT;`
82			`END LOOP;`
83			`END T;`
84			`BEGIN`
85			`BEGIN`
86			`ENT2 (OBJ1, TRUE);`
87			`EXCEPTION`
88			`WHEN CONSTRAINT_ERROR =>`
89			`FAILED ( "CONSTRAINT_ERROR RAISED WITH " &`
90			`"INTEGER TYPE" );`
91			`WHEN OTHERS =>`
92			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
93			`"INTEGER TYPE - 1" );`
94			`END;`
95
96			`BEGIN`
97			`ENT2 (OBJ2, TRUE);`
98			`EXCEPTION`
99			`WHEN CONSTRAINT_ERROR =>`
100			`NULL;`
101			`WHEN OTHERS =>`
102			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
103			`"INTEGER TYPE - 2" );`
104			`END;`
105			`END;`
106
107			`DECLARE`
108			`TYPE REAL IS DIGITS 3;`
109			`SUBTYPE REAL1 IS REAL RANGE -2.0 .. 0.0;`
110			`SUBTYPE REAL2 IS REAL RANGE 0.0 .. 2.0;`
111
112			`OBJ1 : REAL1 := -0.25;`
113			`OBJ2 : REAL2 := 0.25;`
114
115			`SUBTYPE SHORTINT IS INTEGER RANGE 9 .. 11;`
116
117			`TASK T IS`
118			`ENTRY ENT1 (SHORTINT)`
119			`(A : REAL1; OK : BOOLEAN);`
120			`END T;`
121
122			`PROCEDURE ENT2 (A : REAL2; OK : BOOLEAN)`
123			`RENAMES T.ENT1 (10);`
124
125			`TASK BODY T IS`
126			`BEGIN`
127			`LOOP`
128			`SELECT`
129			`ACCEPT ENT1 (10)`
130			`(A : REAL1; OK : BOOLEAN) DO`
131			`IF NOT OK THEN`
132			`FAILED ( "WRONG CALL EXECUTED " &`
133			`"WITH FLOATING POINT " &`
134			`"TYPE" );`
135			`END IF;`
136			`END;`
137			`OR`
138			`TERMINATE;`
139			`END SELECT;`
140			`END LOOP;`
141			`END T;`
142			`BEGIN`
143			`BEGIN`
144			`ENT2 (OBJ1, TRUE);`
145			`EXCEPTION`
146			`WHEN CONSTRAINT_ERROR =>`
147			`FAILED ( "CONSTRAINT_ERROR RAISED WITH " &`
148			`"FLOATING POINT " &`
149			`"TYPE" );`
150			`WHEN OTHERS =>`
151			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
152			`"FLOATING POINT " &`
153			`"TYPE - 1" );`
154			`END;`
155
156			`BEGIN`
157			`ENT2 (OBJ2, FALSE);`
158			`EXCEPTION`
159			`WHEN CONSTRAINT_ERROR =>`
160			`NULL;`
161			`WHEN OTHERS =>`
162			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
163			`"FLOATING POINT " &`
164			`"TYPE - 2" );`
165			`END;`
166			`END;`
167
168			`DECLARE`
169			`TYPE COLOR IS (RED, YELLOW, BLUE, GREEN);`
170
171			`TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0;`
172			`SUBTYPE FIXED1 IS FIXED RANGE 0.0 .. 0.5;`
173			`SUBTYPE FIXED2 IS FIXED RANGE -0.5 .. 0.0;`
174
175			`OBJ1 : FIXED1 := 0.125;`
176			`OBJ2 : FIXED2 := -0.125;`
177
178			`TASK T IS`
179			`ENTRY ENT1 (COLOR)`
180			`(A : FIXED1; OK : BOOLEAN);`
181			`END T;`
182
183			`PROCEDURE ENT2 (A : FIXED2; OK : BOOLEAN)`
184			`RENAMES T.ENT1 (BLUE);`
185
186			`TASK BODY T IS`
187			`BEGIN`
188			`LOOP`
189			`SELECT`
190			`ACCEPT ENT1 (BLUE)`
191			`(A : FIXED1; OK : BOOLEAN) DO`
192			`IF NOT OK THEN`
193			`FAILED ( "WRONG CALL EXECUTED " &`
194			`"WITH FIXED POINT " &`
195			`"TYPE" );`
196			`END IF;`
197			`END;`
198			`OR`
199			`TERMINATE;`
200			`END SELECT;`
201			`END LOOP;`
202			`END T;`
203			`BEGIN`
204			`BEGIN`
205			`ENT2 (OBJ1, TRUE);`
206			`EXCEPTION`
207			`WHEN CONSTRAINT_ERROR =>`
208			`FAILED ( "CONSTRAINT_ERROR RAISED WITH " &`
209			`"FIXED POINT " &`
210			`"TYPE" );`
211			`WHEN OTHERS =>`
212			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
213			`"FIXED POINT " &`
214			`"TYPE - 1" );`
215			`END;`
216
217			`BEGIN`
218			`ENT2 (OBJ2, FALSE);`
219			`EXCEPTION`
220			`WHEN CONSTRAINT_ERROR =>`
221			`NULL;`
222			`WHEN OTHERS =>`
223			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
224			`"FIXED POINT " &`
225			`"TYPE - 2" );`
226			`END;`
227			`END;`
228
229			`DECLARE`
230			`TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER;`
231			`SUBTYPE STA1 IS TA(1 .. 5);`
232			`SUBTYPE STA2 IS TA(6 .. 10);`
233
234			`OBJ1 : STA1 := (1, 2, 3, 4, 5);`
235			`OBJ2 : STA2 := (6, 7, 8, 9, 10);`
236
237			`TASK T IS`
238			`ENTRY ENT1 (BOOLEAN)`
239			`(A : STA1; OK : BOOLEAN);`
240			`END T;`
241
242			`PROCEDURE ENT2 (A : STA2; OK : BOOLEAN)`
243			`RENAMES T.ENT1 (FALSE);`
244
245			`TASK BODY T IS`
246			`BEGIN`
247			`LOOP`
248			`SELECT`
249			`ACCEPT ENT1 (FALSE)`
250			`(A : STA1; OK : BOOLEAN) DO`
251			`IF NOT OK THEN`
252			`FAILED ( "WRONG CALL EXECUTED " &`
253			`"WITH CONSTRAINED " &`
254			`"ARRAY" );`
255			`END IF;`
256			`END;`
257			`OR`
258			`TERMINATE;`
259			`END SELECT;`
260			`END LOOP;`
261			`END T;`
262			`BEGIN`
263			`BEGIN`
264			`ENT2 (OBJ1, TRUE);`
265			`EXCEPTION`
266			`WHEN CONSTRAINT_ERROR =>`
267			`FAILED ( "CONSTRAINT_ERROR RAISED WITH " &`
268			`"CONSTRAINED ARRAY" );`
269			`WHEN OTHERS =>`
270			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
271			`"CONSTRAINED ARRAY - 1" );`
272			`END;`
273
274			`BEGIN`
275			`ENT2 (OBJ2, TRUE);`
276			`EXCEPTION`
277			`WHEN CONSTRAINT_ERROR =>`
278			`FAILED ( "CONSTRAINT_ERROR RAISED WITH " &`
279			`"CONSTRAINED ARRAY" );`
280			`WHEN OTHERS =>`
281			`FAILED ( "OTHER EXCEPTION RAISED WITH " &`
282			`"CONSTRAINED ARRAY - 2" );`
283			`END;`
284			`END;`
285
286			`RESULT;`
287
288			`END C85018B;`