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

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

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