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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C32107C.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 OBJECTS OF A GENERIC FORMAL TYPE WHOSE ACTUAL PARAMETER IS A 
26
-- TYPE WITH DEFAULT VALUES, CHECK THAT OBJECT DECLARATIONS ARE 
27
-- ELABORATED IN THE ORDER OF THEIR OCCURRENCE, I.E., THAT EXPRESSIONS 
28
-- ASSOCIATED WITH ONE DECLARATION (INCLUDING DEFAULT EXPRESSIONS) ARE 
29
-- EVALUATED BEFORE ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. 
30
 
31
-- R.WILLIAMS 9/24/86
32
 
33
WITH REPORT; USE REPORT;
34
PROCEDURE C32107C IS
35
 
36
     BUMP : INTEGER := 0;
37
 
38
     G1, H1 : INTEGER;
39
 
40
     FUNCTION F RETURN INTEGER IS
41
     BEGIN
42
          BUMP := BUMP + 1;
43
          RETURN BUMP;
44
     END F;
45
 
46
     FUNCTION G RETURN INTEGER IS
47
     BEGIN
48
          BUMP := BUMP + 1;
49
          G1 := BUMP;
50
          RETURN BUMP;
51
     END G;
52
 
53
     FUNCTION H RETURN INTEGER IS
54
     BEGIN
55
          BUMP := BUMP + 1;
56
          H1 := BUMP;
57
          RETURN BUMP;
58
     END H;
59
 
60
BEGIN
61
     TEST ( "C32107C", "FOR OBJECTS OF A GENERIC FORMAL TYPE WHOSE " &
62
                       "ACTUAL PARAMETER IS A TYPE WITH DEFAULT " &
63
                       "VALUES, CHECK THAT OBJECT DECLARATIONS ARE " &
64
                       "ELABORATED IN THE ORDER OF THEIR " &
65
                       "OCCURRENCE, I.E., THAT EXPRESSIONS " &
66
                       "ASSOCIATED WITH ONE DECLARATION (INCLUDING " &
67
                       "DEFAULT EXPRESSIONS) ARE EVALUATED BEFORE " &
68
                       "ANY EXPRESSION BELONGING TO THE NEXT " &
69
                       "DECLARATION" );
70
 
71
     DECLARE -- (A).
72
          TYPE REC (D : INTEGER := F) IS
73
               RECORD
74
                    A : INTEGER := F;
75
               END RECORD;
76
 
77
          FUNCTION GET_A (R : REC) RETURN INTEGER IS
78
          BEGIN
79
               RETURN R.A;
80
          END GET_A;
81
 
82
          GENERIC
83
               TYPE T IS (<>);
84
               TYPE PRIV (D : T) IS PRIVATE;
85
               WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>;
86
          PROCEDURE P;
87
 
88
          PROCEDURE P IS
89
               P1 : PRIV (T'VAL (F));
90
               P2 : PRIV (T'VAL (F * 100));
91
               ORDER_CHECK : INTEGER;
92
 
93
          BEGIN
94
               ORDER_CHECK :=
95
                    T'POS (P1.D) + T'POS (P2.D) +
96
                    (GET_A (P1) * 10) + (GET_A (P2) * 1000);
97
               IF ORDER_CHECK /= 4321 THEN
98
                    FAILED ( "OBJECTS NOT ELABORATED IN PROPER " &
99
                             "ORDER VALUE OF ORDER_CHECK SHOULD BE " &
100
                             "4321 -- ACTUAL VALUE IS " &
101
                              INTEGER'IMAGE (ORDER_CHECK) & " - (A)" );
102
               END IF;
103
          END P;
104
 
105
          PROCEDURE PROC IS NEW P (INTEGER, REC);
106
 
107
     BEGIN
108
          PROC;
109
     END; -- (A).         
110
 
111
     BUMP := 0;
112
 
113
     DECLARE -- (B).
114
          TYPE REC (D1 : INTEGER := F; D2 : INTEGER := F) IS
115
               RECORD
116
                    A : INTEGER := F;
117
               END RECORD;
118
 
119
          FUNCTION GET_A (R : REC) RETURN INTEGER IS
120
          BEGIN
121
               RETURN R.A;
122
          END GET_A;
123
 
124
          GENERIC
125
               TYPE T IS (<>);
126
               TYPE PRIV (D1 : T; D2 : T) IS PRIVATE;
127
               WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>;
128
          PROCEDURE P;
129
 
130
          PROCEDURE P IS
131
               P1 : PRIV (T'VAL (F * 1000), T'VAL (F * 10000));
132
               P2 : PRIV (T'VAL (F), T'VAL (F * 10));
133
               ORDER_CHECK : INTEGER;
134
 
135
          BEGIN
136
               ORDER_CHECK :=
137
               T'POS (P1.D1) + T'POS (P1.D2) +
138
               T'POS (P2.D1) + T'POS (P2.D2) +
139
               (GET_A (P1) * 100);
140
               IF (GET_A (P2) = 6) AND
141
                  (ORDER_CHECK = 12345 OR ORDER_CHECK = 21345 OR
142
                   ORDER_CHECK = 21354 OR ORDER_CHECK = 12354) THEN
143
                    COMMENT ( "ORDER_CHECK HAS VALUE " &
144
                               INTEGER'IMAGE (ORDER_CHECK) &
145
                              " - (B)" );
146
               ELSE
147
                    FAILED ( "OBJECTS NOT ELABORATED IN PROPER " &
148
                             "ORDER VALUE OF ORDER_CHECK SHOULD BE " &
149
                             "6 12345, 6 21345, 6 21354, OR " &
150
                             "6 12354 -- ACTUAL VALUE IS " &
151
                              INTEGER'IMAGE (GET_A (P2)) &
152
                              INTEGER'IMAGE (ORDER_CHECK) & " - (B)" );
153
               END IF;
154
 
155
          END P;
156
 
157
          PROCEDURE PROC IS NEW P (INTEGER, REC);
158
 
159
     BEGIN
160
          PROC;
161
     END; -- (B).         
162
 
163
     RESULT;
164
END C32107C;

powered by: WebSVN 2.1.0

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