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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c4/] [c48009g.ada] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn 
-- C48009G.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 
--     FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT
27 
--     CONSTRAINT_ERROR IS RAISED IF T IS A CONSTRAINED ACCESS
28 
--     TYPE AND THE OBJECT DESIGNATED BY X DOES NOT HAVE DISCRIMINANTS
29 
--     OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING VALUES FOR T.
30 
 
31 
-- HISTORY:
32 
--     EG  08/30/84  CREATED ORIGINAL TEST.
33 
--     JET 01/05/87  UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT
34 
--                   OPTIMIZATION.
35 
 
36 
WITH REPORT;
37 
 
38 
PROCEDURE C48009G IS
39 
 
40 
     USE REPORT;
41 
 
42 
     GENERIC
43 
          TYPE G_TYPE IS PRIVATE;
44 
     FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN;
45 
 
46 
     FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN IS
47 
     BEGIN
48 
          IF (IDENT_INT(3) = 3) AND (X = Y) THEN
49 
               RETURN TRUE;
50 
          ELSE
51 
               RETURN FALSE;
52 
          END IF;
53 
     END EQUAL_G;
54 
 
55 
BEGIN
56 
 
57 
     TEST("C48009G","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " &
58 
                    "THAT CONSTRAINT_ERROR IS RAISED WHEN " &
59 
                    "APPROPRIATE - CONSTRAINED ACCESS TYPE");
60 
 
61 
     DECLARE
62 
 
63 
          TYPE INT IS RANGE 1 .. 5;
64 
 
65 
          TYPE UR(A : INT) IS
66 
               RECORD
67 
                    B : INTEGER;
68 
               END RECORD;
69 
          TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER;
70 
 
71 
          PACKAGE P IS
72 
               TYPE UP(A, B : INT) IS PRIVATE;
73 
               TYPE UL(A, B : INT) IS LIMITED PRIVATE;
74 
               CONS_UP : CONSTANT UP;
75 
          PRIVATE
76 
               TYPE UP(A, B : INT) IS
77 
                    RECORD
78 
                         C : INTEGER;
79 
                    END RECORD;
80 
               TYPE UL(A, B : INT) IS
81 
                    RECORD
82 
                         C : INTEGER;
83 
                    END RECORD;
84 
               CONS_UP : CONSTANT UP := (2, 2, (IDENT_INT(3)));
85 
          END P;
86 
 
87 
          TYPE A_UR IS ACCESS UR;
88 
          TYPE A_UA IS ACCESS UA;
89 
          TYPE A_UP IS ACCESS P.UP;
90 
          TYPE A_UL IS ACCESS P.UL;
91 
 
92 
          SUBTYPE CA_UR IS A_UR(2);
93 
          SUBTYPE CA_UA IS A_UA(2 .. 3);
94 
          SUBTYPE CA_UP IS A_UP(3, 2);
95 
          SUBTYPE CA_UL IS A_UL(2, 4);
96 
 
97 
          TYPE A_CA_UR IS ACCESS CA_UR;
98 
          TYPE A_CA_UA IS ACCESS CA_UA;
99 
          TYPE A_CA_UP IS ACCESS CA_UP;
100 
          TYPE A_CA_UL IS ACCESS CA_UL;
101 
 
102 
          V_A_CA_UR : A_CA_UR;
103 
          V_A_CA_UA : A_CA_UA;
104 
          V_A_CA_UP : A_CA_UP;
105 
          V_A_CA_UL : A_CA_UL;
106 
 
107 
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UR);
108 
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UA);
109 
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UP);
110 
          FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UL);
111 
 
112 
     BEGIN
113 
 
114 
          BEGIN
115 
               V_A_CA_UR := NEW CA_UR'(NEW UR'(1,(IDENT_INT(2))));
116 
 
117 
               IF EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
118 
                    FAILED ("NO EXCEPTION RAISED - UR");
119 
               END IF;
120 
 
121 
          EXCEPTION
122 
               WHEN CONSTRAINT_ERROR =>
123 
                    NULL;
124 
               WHEN OTHERS =>
125 
                    FAILED ("WRONG EXCEPTION RAISED - UR");
126 
          END;
127 
 
128 
          BEGIN
129 
               V_A_CA_UA := NEW CA_UA'(NEW UA'(1 => 2,
130 
                                               2 => IDENT_INT(3)));
131 
 
132 
               IF EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
133 
                    FAILED ("NO EXCEPTION RAISED - UA");
134 
               END IF;
135 
 
136 
          EXCEPTION
137 
               WHEN CONSTRAINT_ERROR =>
138 
                    NULL;
139 
               WHEN OTHERS =>
140 
                    FAILED ("WRONG EXCEPTION RAISED - UA");
141 
          END;
142 
 
143 
          BEGIN
144 
               V_A_CA_UP := NEW CA_UP'(NEW P.UP'(P.CONS_UP));
145 
 
146 
               IF EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
147 
                    FAILED ("NO EXCEPTION RAISED - UP");
148 
               END IF;
149 
 
150 
          EXCEPTION
151 
               WHEN CONSTRAINT_ERROR =>
152 
                    NULL;
153 
               WHEN OTHERS =>
154 
                    FAILED ("WRONG EXCEPTION RAISED - UP");
155 
          END;
156 
 
157 
          BEGIN
158 
               V_A_CA_UR := NEW CA_UR'(NULL);
159 
 
160 
               IF NOT EQUAL (V_A_CA_UR, V_A_CA_UR) THEN
161 
                    COMMENT ("NO EXCEPTION RAISED - UR");
162 
               END IF;
163 
 
164 
          EXCEPTION
165 
               WHEN OTHERS =>
166 
                    FAILED ("EXCEPTION RAISED - UR");
167 
          END;
168 
 
169 
          BEGIN
170 
               V_A_CA_UA := NEW CA_UA'(NULL);
171 
 
172 
               IF NOT EQUAL (V_A_CA_UA, V_A_CA_UA) THEN
173 
                    COMMENT ("NO EXCEPTION RAISED - UA");
174 
               END IF;
175 
 
176 
          EXCEPTION
177 
               WHEN OTHERS =>
178 
                    FAILED ("EXCEPTION RAISED - UA");
179 
          END;
180 
 
181 
          BEGIN
182 
               V_A_CA_UP := NEW CA_UP'(NULL);
183 
 
184 
               IF NOT EQUAL (V_A_CA_UP, V_A_CA_UP) THEN
185 
                    COMMENT ("NO EXCEPTION RAISED - UP");
186 
               END IF;
187 
 
188 
          EXCEPTION
189 
               WHEN OTHERS =>
190 
                    FAILED ("EXCEPTION RAISED - UP");
191 
          END;
192 
 
193 
          BEGIN
194 
               V_A_CA_UL := NEW CA_UL'(NULL);
195 
 
196 
               IF NOT EQUAL (V_A_CA_UL, V_A_CA_UL) THEN
197 
                    COMMENT ("NO EXCEPTION RAISED - UL");
198 
               END IF;
199 
 
200 
          EXCEPTION
201 
               WHEN OTHERS =>
202 
                    FAILED ("EXCEPTION RAISED - UL");
203 
          END;
204 
 
205 
     END;
206 
 
207 
     RESULT;
208 
 
209 
END C48009G;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.