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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C58005H.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 CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE
26
-- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER.
27
 
28
-- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH
29
-- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES.
30
 
31
-- SPS 3/10/83
32
-- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations.
33
--               The objects must be used, and must be tied somehow to the
34
--               calls to Failed.
35
 
36
WITH REPORT;
37
USE REPORT;
38
PROCEDURE C58005H IS
39
 
40
     PACKAGE PACK IS
41
          TYPE PV (D : NATURAL) IS PRIVATE;
42
          TYPE LP (D : NATURAL) IS LIMITED PRIVATE;
43
     PRIVATE
44
          TYPE PV (D : NATURAL) IS RECORD
45
               NULL;
46
          END RECORD;
47
          TYPE LP (D : NATURAL) IS RECORD
48
               NULL;
49
          END RECORD;
50
     END PACK;
51
 
52
     USE PACK;
53
 
54
     TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL;
55
     TYPE REC (D : NATURAL) IS RECORD
56
          NULL;
57
     END RECORD;
58
 
59
     TYPE ACC_REC IS ACCESS REC;
60
     TYPE ACC_ARR IS ACCESS ARR;
61
     TYPE ACC_PV IS ACCESS PV;
62
     TYPE ACC_LP IS ACCESS LP;
63
 
64
     SUBTYPE ACC_REC1 IS ACC_REC (D => 1);
65
     SUBTYPE ACC_REC2 IS ACC_REC (D => 2);
66
 
67
     SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10);
68
     SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5);
69
 
70
     SUBTYPE ACC_PV1 IS ACC_PV (D => 1);
71
     SUBTYPE ACC_PV2 IS ACC_PV (D => 2);
72
 
73
     SUBTYPE ACC_LP1 IS ACC_LP (D => 1);
74
     SUBTYPE ACC_LP2 IS ACC_LP (D => 2);
75
 
76
     VAR1 : ACC_REC1 := NEW REC(1);
77
     VAR2 : ACC_REC2 := NEW REC(2);
78
     VAA1 : ACC_ARR1 := NEW ARR(1 .. 10);
79
     VAA2 : ACC_ARR2 := NEW ARR(2 .. 5);
80
     VAP1 : ACC_PV1 := NEW PV(1);
81
     VAP2 : ACC_PV2 := NEW PV(2);
82
     VAL1 : ACC_LP1 := NEW LP(1);
83
     VAL2 : ACC_LP2 := NEW LP(2);
84
 
85
     FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS
86
     BEGIN
87
          RETURN X;
88
     END FREC;
89
 
90
     FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS
91
     BEGIN
92
          RETURN X;
93
     END FARR;
94
 
95
     FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS
96
     BEGIN
97
          RETURN X;
98
     END FPV;
99
 
100
     FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS
101
     BEGIN
102
          RETURN X;
103
     END FLP;
104
 
105
     PACKAGE BODY PACK IS
106
          FUNCTION LF (X : LP) RETURN INTEGER IS
107
          BEGIN
108
               RETURN IDENT_INT(3);
109
          END LF;
110
     BEGIN
111
          NULL;
112
     END PACK;
113
 
114
BEGIN
115
 
116
     TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " &
117
                      "OF FUNCTIONS");
118
 
119
     BEGIN
120
          VAR2 := FREC (VAR1);
121
          IF VAR2.D /= REPORT.IDENT_INT(2) THEN
122
              FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1");
123
          ELSE
124
              FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2");
125
          END IF;
126
     EXCEPTION
127
          WHEN CONSTRAINT_ERROR => NULL;
128
          WHEN OTHERS =>
129
               FAILED ("WRONG EXCEPTION RAISED - REC");
130
     END;
131
 
132
     BEGIN
133
          VAA2 := FARR (VAA1);
134
          IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN
135
              FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1");
136
          ELSE
137
              FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2");
138
          END IF;
139
     EXCEPTION
140
          WHEN CONSTRAINT_ERROR => NULL;
141
          WHEN OTHERS =>
142
               FAILED ("WRONG EXCEPTION RAISED - ARR");
143
     END;
144
 
145
     BEGIN
146
          VAP2 := FPV (VAP1);
147
          IF VAP2.D /= REPORT.IDENT_INT(2) THEN
148
              FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1");
149
          ELSE
150
              FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2");
151
          END IF;
152
     EXCEPTION
153
          WHEN CONSTRAINT_ERROR => NULL;
154
          WHEN OTHERS =>
155
               FAILED ("WRONG EXCEPTION RAISED - PV");
156
     END;
157
 
158
     BEGIN
159
          VAL2 := FLP (VAL1);
160
          IF VAL2.D /= REPORT.IDENT_INT(2) THEN
161
              FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1");
162
          ELSE
163
              FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2");
164
          END IF;
165
     EXCEPTION
166
          WHEN CONSTRAINT_ERROR => NULL;
167
          WHEN OTHERS =>
168
               FAILED ("WRONG EXCEPTION RAISED - LP");
169
     END;
170
 
171
     RESULT;
172
END C58005H;

powered by: WebSVN 2.1.0

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