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/] [c3/] [c37403a.ada] - Blame information for rev 294

Details | Compare with Previous | View Log


-- C37403A.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.
--*
-- CHECK THAT WHEN A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR 
-- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT DO 
-- NOT HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' REGARDLESS OF THE MODE 
-- OF THE PARAMETER.
 
-- R.WILLIAMS 9/1/86
 
WITH REPORT; USE REPORT;
PROCEDURE C37403A IS
 
BEGIN
     TEST ( "C37403A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " &
                       "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " &
                       "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " &
                       "DO NOT HAVE DEFAULTS, 'CONSTRAINED IS " &
                       "'TRUE' REGARDLESS OF THE MODE OF THE " &
                       "PARAMETER" );
 
 
     DECLARE
 
          SUBTYPE INT IS INTEGER RANGE 1.. 10;
 
          TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>)
               OF INTEGER;
 
          TYPE SQUARE (SIDE : INT) IS
               RECORD
                    MAT : MATRIX (1 .. SIDE, 1 .. SIDE);
               END RECORD;
 
          S1 : SQUARE (2) := (2, ((1, 2), (3, 4)));
 
          S2 : SQUARE (2) := S1;
 
          S3 : SQUARE (2);
 
          SC : CONSTANT SQUARE := (SIDE => 1, MAT => (1 => (1 => 1)));
 
          PROCEDURE P (PIN1, PIN2 : IN     SQUARE;
                       PINOUT     : IN OUT SQUARE;
                       POUT       : OUT    SQUARE) IS
 
          BEGIN
               IF PIN1'CONSTRAINED THEN
                    NULL;
               ELSE
                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
                             "OF IN MODE - 1" );
               END IF;
 
               IF PIN2'CONSTRAINED THEN
                    NULL;
               ELSE
                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
                             "OF IN MODE - 2" );
               END IF;
 
               IF PINOUT'CONSTRAINED THEN
                    NULL;
               ELSE
                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
                             "OBJECT OF IN OUT MODE - 1" );
               END IF;
 
               IF POUT'CONSTRAINED THEN
                    NULL;
               ELSE
                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
                             "OBJECT OF OUT MODE - 1" );
               END IF;
 
               POUT := (2, ((1, 2), (3, 4)));
          END P;
 
          TASK T IS
               ENTRY Q (PIN1, PIN2  : IN     SQUARE;
                        PINOUT      : IN OUT SQUARE;
                        POUT        : OUT    SQUARE);
          END T;
 
          TASK BODY T IS
          BEGIN
               ACCEPT Q (PIN1, PIN2  : IN     SQUARE;
                         PINOUT      : IN OUT SQUARE;
                         POUT        : OUT    SQUARE) DO
 
                    BEGIN
                         IF PIN1'CONSTRAINED THEN
                              NULL;
                         ELSE
                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
                                       "OBJECT OF IN MODE - 3" );
                         END IF;
 
                         IF PIN2'CONSTRAINED THEN
                              NULL;
                         ELSE
                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
                                       "OBJECT OF IN MODE - 4" );
                         END IF;
 
                         IF PINOUT'CONSTRAINED THEN
                              NULL;
                         ELSE
                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
                                       "OBJECT OF " &
                                       "IN OUT MODE - 2" );
                         END IF;
 
                         IF POUT'CONSTRAINED THEN
                              NULL;
                         ELSE
                              FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
                                       "OBJECT OF " &
                                       "OUT MODE - 2" );
                         END IF;
 
                         POUT := (2, ((1, 2), (3, 4)));
                    END;
               END Q;
          END T;
 
          GENERIC
               PIN1, PIN2 : IN     SQUARE;
               PINOUT     : IN OUT SQUARE;
          PACKAGE R IS END R;
 
          PACKAGE BODY R IS
          BEGIN
               IF PIN1'CONSTRAINED THEN
                    NULL;
               ELSE
                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
                             "OF IN MODE - 5" );
               END IF;
 
               IF PIN2'CONSTRAINED THEN
                    NULL;
               ELSE
                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &
                             "OF IN MODE - 6" );
               END IF;
 
               IF PINOUT'CONSTRAINED THEN
                    NULL;
               ELSE
                    FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &
                             "OBJECT OF IN OUT MODE - 3" );
               END IF;
 
          END R;
 
          PACKAGE S IS NEW R (S1, SC, S2);
 
     BEGIN
          P (S1, SC, S2, S3);
          T.Q (S1, SC, S2, S3);
     END;
 
     RESULT;
END C37403A;

Line No.	Rev	Author	Line
1	294	jeremybenn	`-- C37403A.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			`-- CHECK THAT WHEN A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR`
26			`-- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT DO`
27			`-- NOT HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' REGARDLESS OF THE MODE`
28			`-- OF THE PARAMETER.`
29
30			`-- R.WILLIAMS 9/1/86`
31
32			`WITH REPORT; USE REPORT;`
33			`PROCEDURE C37403A IS`
34
35			`BEGIN`
36			`TEST ( "C37403A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " &`
37			`"SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " &`
38			`"UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " &`
39			`"DO NOT HAVE DEFAULTS, 'CONSTRAINED IS " &`
40			`"'TRUE' REGARDLESS OF THE MODE OF THE " &`
41			`"PARAMETER" );`
42
43
44			`DECLARE`
45
46			`SUBTYPE INT IS INTEGER RANGE 1.. 10;`
47
48			`TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>)`
49			`OF INTEGER;`
50
51			`TYPE SQUARE (SIDE : INT) IS`
52			`RECORD`
53			`MAT : MATRIX (1 .. SIDE, 1 .. SIDE);`
54			`END RECORD;`
55
56			`S1 : SQUARE (2) := (2, ((1, 2), (3, 4)));`
57
58			`S2 : SQUARE (2) := S1;`
59
60			`S3 : SQUARE (2);`
61
62			`SC : CONSTANT SQUARE := (SIDE => 1, MAT => (1 => (1 => 1)));`
63
64			`PROCEDURE P (PIN1, PIN2 : IN SQUARE;`
65			`PINOUT : IN OUT SQUARE;`
66			`POUT : OUT SQUARE) IS`
67
68			`BEGIN`
69			`IF PIN1'CONSTRAINED THEN`
70			`NULL;`
71			`ELSE`
72			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &`
73			`"OF IN MODE - 1" );`
74			`END IF;`
75
76			`IF PIN2'CONSTRAINED THEN`
77			`NULL;`
78			`ELSE`
79			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &`
80			`"OF IN MODE - 2" );`
81			`END IF;`
82
83			`IF PINOUT'CONSTRAINED THEN`
84			`NULL;`
85			`ELSE`
86			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &`
87			`"OBJECT OF IN OUT MODE - 1" );`
88			`END IF;`
89
90			`IF POUT'CONSTRAINED THEN`
91			`NULL;`
92			`ELSE`
93			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &`
94			`"OBJECT OF OUT MODE - 1" );`
95			`END IF;`
96
97			`POUT := (2, ((1, 2), (3, 4)));`
98			`END P;`
99
100			`TASK T IS`
101			`ENTRY Q (PIN1, PIN2 : IN SQUARE;`
102			`PINOUT : IN OUT SQUARE;`
103			`POUT : OUT SQUARE);`
104			`END T;`
105
106			`TASK BODY T IS`
107			`BEGIN`
108			`ACCEPT Q (PIN1, PIN2 : IN SQUARE;`
109			`PINOUT : IN OUT SQUARE;`
110			`POUT : OUT SQUARE) DO`
111
112			`BEGIN`
113			`IF PIN1'CONSTRAINED THEN`
114			`NULL;`
115			`ELSE`
116			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &`
117			`"OBJECT OF IN MODE - 3" );`
118			`END IF;`
119
120			`IF PIN2'CONSTRAINED THEN`
121			`NULL;`
122			`ELSE`
123			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &`
124			`"OBJECT OF IN MODE - 4" );`
125			`END IF;`
126
127			`IF PINOUT'CONSTRAINED THEN`
128			`NULL;`
129			`ELSE`
130			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &`
131			`"OBJECT OF " &`
132			`"IN OUT MODE - 2" );`
133			`END IF;`
134
135			`IF POUT'CONSTRAINED THEN`
136			`NULL;`
137			`ELSE`
138			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &`
139			`"OBJECT OF " &`
140			`"OUT MODE - 2" );`
141			`END IF;`
142
143			`POUT := (2, ((1, 2), (3, 4)));`
144			`END;`
145			`END Q;`
146			`END T;`
147
148			`GENERIC`
149			`PIN1, PIN2 : IN SQUARE;`
150			`PINOUT : IN OUT SQUARE;`
151			`PACKAGE R IS END R;`
152
153			`PACKAGE BODY R IS`
154			`BEGIN`
155			`IF PIN1'CONSTRAINED THEN`
156			`NULL;`
157			`ELSE`
158			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &`
159			`"OF IN MODE - 5" );`
160			`END IF;`
161
162			`IF PIN2'CONSTRAINED THEN`
163			`NULL;`
164			`ELSE`
165			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " &`
166			`"OF IN MODE - 6" );`
167			`END IF;`
168
169			`IF PINOUT'CONSTRAINED THEN`
170			`NULL;`
171			`ELSE`
172			`FAILED ( "'CONSTRAINED IS 'FALSE' FOR " &`
173			`"OBJECT OF IN OUT MODE - 3" );`
174			`END IF;`
175
176			`END R;`
177
178			`PACKAGE S IS NEW R (S1, SC, S2);`
179
180			`BEGIN`
181			`P (S1, SC, S2, S3);`
182			`T.Q (S1, SC, S2, S3);`
183			`END;`
184
185			`RESULT;`
186			`END C37403A;`

Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c37403a.ada] - Blame information for rev 294