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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C34005C.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 DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A
27
--     NON-LIMITED, NON-DISCRETE TYPE:
28
--     CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR
29
--     THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS
30
--     CONSTRAINED.
31
--     CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO
32
--     IMPOSED ON THE DERIVED SUBTYPE.
33
 
34
-- HISTORY:
35
--     JRK 9/10/86  CREATED ORIGINAL TEST.
36
 
37
WITH REPORT; USE REPORT;
38
 
39
PROCEDURE C34005C IS
40
 
41
     SUBTYPE COMPONENT IS FLOAT;
42
 
43
     PACKAGE PKG IS
44
 
45
          FIRST : CONSTANT := 0;
46
          LAST  : CONSTANT := 100;
47
 
48
          SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST;
49
 
50
          TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT;
51
 
52
          FUNCTION CREATE ( F, L  : INDEX;
53
                            C     : COMPONENT;
54
                            DUMMY : PARENT   -- TO RESOLVE OVERLOADING.
55
                          ) RETURN PARENT;
56
 
57
     END PKG;
58
 
59
     USE PKG;
60
 
61
     TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7));
62
 
63
     SUBTYPE SUBPARENT IS PARENT (5 .. 7);
64
 
65
     TYPE S IS NEW SUBPARENT;
66
 
67
     X : T := (OTHERS => 2.0);
68
     Y : S := (OTHERS => 2.0);
69
 
70
     PACKAGE BODY PKG IS
71
 
72
          FUNCTION CREATE
73
             ( F, L  : INDEX;
74
               C     : COMPONENT;
75
               DUMMY : PARENT
76
             ) RETURN PARENT
77
          IS
78
               A : PARENT (F .. L);
79
               B : COMPONENT := C;
80
          BEGIN
81
               FOR I IN F .. L LOOP
82
                    A (I) := B;
83
                    B := B + 1.0;
84
               END LOOP;
85
               RETURN A;
86
          END CREATE;
87
 
88
     END PKG;
89
 
90
BEGIN
91
     TEST ("C34005C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " &
92
                      "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " &
93
                      "WHEN THE DERIVED TYPE DEFINITION IS " &
94
                      "CONSTRAINED.  ALSO CHECK THAT ANY CONSTRAINT " &
95
                      "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " &
96
                      "ON THE DERIVED SUBTYPE.  CHECK FOR DERIVED " &
97
                      "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " &
98
                      "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE");
99
 
100
     -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT.
101
 
102
     BEGIN
103
          IF CREATE (2, 3, 4.0, X) /= (4.0, 5.0) OR
104
             CREATE (2, 3, 4.0, Y) /= (4.0, 5.0) THEN
105
               FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " &
106
                       "SUBTYPE");
107
          END IF;
108
     EXCEPTION
109
          WHEN CONSTRAINT_ERROR =>
110
               FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR");
111
          WHEN OTHERS =>
112
               FAILED ("CALL TO CREATE RAISED EXCEPTION");
113
     END;
114
 
115
     IF X & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) OR
116
        Y & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) THEN
117
          FAILED ("INCORRECT &");
118
     END IF;
119
 
120
     -- CHECK THE DERIVED SUBTYPE CONSTRAINT.
121
 
122
     IF T'FIRST /= 5 OR T'LAST /= 7 OR
123
        S'FIRST /= 5 OR S'LAST /= 7 THEN
124
          FAILED ("INCORRECT 'FIRST OR 'LAST");
125
     END IF;
126
 
127
     BEGIN
128
          X := (1.0, 2.0, 3.0);
129
          Y := (1.0, 2.0, 3.0);
130
          IF PARENT (X) /= PARENT (Y) THEN  -- USE X AND Y.
131
               FAILED ("INCORRECT CONVERSION TO PARENT");
132
          END IF;
133
     EXCEPTION
134
          WHEN OTHERS =>
135
               FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT");
136
     END;
137
 
138
     BEGIN
139
          X := (1.0, 2.0);
140
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1.0, 2.0)");
141
          IF X = (1.0, 2.0) THEN  -- USE X.
142
               COMMENT ("X ALTERED -- X := (1.0, 2.0)");
143
          END IF;
144
     EXCEPTION
145
          WHEN CONSTRAINT_ERROR =>
146
               NULL;
147
          WHEN OTHERS =>
148
               FAILED ("WRONG EXCEPTION RAISED -- X := (1.0, 2.0)");
149
     END;
150
 
151
     BEGIN
152
          X := (1.0, 2.0, 3.0, 4.0);
153
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
154
                  "X := (1.0, 2.0, 3.0, 4.0)");
155
          IF X = (1.0, 2.0, 3.0, 4.0) THEN  -- USE X.
156
               COMMENT ("X ALTERED -- X := (1.0, 2.0, 3.0, 4.0)");
157
          END IF;
158
     EXCEPTION
159
          WHEN CONSTRAINT_ERROR =>
160
               NULL;
161
          WHEN OTHERS =>
162
               FAILED ("WRONG EXCEPTION RAISED -- " &
163
                       "X := (1.0, 2.0, 3.0, 4.0)");
164
     END;
165
 
166
     BEGIN
167
          Y := (1.0, 2.0);
168
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1.0, 2.0)");
169
          IF Y = (1.0, 2.0) THEN  -- USE Y.
170
               COMMENT ("Y ALTERED -- Y := (1.0, 2.0)");
171
          END IF;
172
     EXCEPTION
173
          WHEN CONSTRAINT_ERROR =>
174
               NULL;
175
          WHEN OTHERS =>
176
               FAILED ("WRONG EXCEPTION RAISED -- Y := (1.0, 2.0)");
177
     END;
178
 
179
     BEGIN
180
          Y := (1.0, 2.0, 3.0, 4.0);
181
          FAILED ("CONSTRAINT_ERROR NOT RAISED -- " &
182
                  "Y := (1.0, 2.0, 3.0, 4.0)");
183
          IF Y = (1.0, 2.0, 3.0, 4.0) THEN  -- USE Y.
184
               COMMENT ("Y ALTERED -- Y := (1.0, 2.0, 3.0, 4.0)");
185
          END IF;
186
     EXCEPTION
187
          WHEN CONSTRAINT_ERROR =>
188
               NULL;
189
          WHEN OTHERS =>
190
               FAILED ("WRONG EXCEPTION RAISED -- " &
191
                       "Y := (1.0, 2.0, 3.0, 4.0)");
192
     END;
193
 
194
     RESULT;
195
END C34005C;

powered by: WebSVN 2.1.0

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