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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn 
-- C380003.A
2 
--
3 
--                             Grant of Unlimited Rights
4 
--
5 
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
6 
--     rights in the software and documentation contained herein. Unlimited
7 
--     rights are the same as those granted by the U.S. Government for older
8 
--     parts of the Ada Conformity Assessment Test Suite, and are defined
9 
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10 
--     intends to confer upon all recipients unlimited rights equal to those
11 
--     held by the ACAA. These rights include rights to use, duplicate,
12 
--     release or disclose the released technical data and computer software
13 
--     in whole or in part, in any manner and for any purpose whatsoever, and
14 
--     to have or permit others to do so.
15 
--
16 
--                                    DISCLAIMER
17 
--
18 
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19 
--     DISCLOSED ARE AS IS. THE ACAA 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 
--
26 
-- OBJECTIVE:
27 
--    Check that per-object expressions are evaluated as specified for
28 
--    protected components.  (Defect Report 8652/0002, as reflected in
29 
--    Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)).
30 
--
31 
-- CHANGE HISTORY:
32 
--     9 FEB 2001   PHL   Initial version.
33 
--    29 JUN 2002   RLB   Readied for release.
34 
--
35 
--!
36 
with Report;
37 
use Report;
38 
procedure C380003 is
39 
 
40 
    subtype Sm is Integer range 1 .. 10;
41 
 
42 
    type Rec (D1, D2 : Sm) is
43 
        record
44 
            null;
45 
        end record;
46 
 
47 
begin
48 
    Test ("C380003",
49 
          "Check compatibility of discriminant expressions" &
50 
             " when the constraint depends on discriminants, " &
51 
             "and the discriminants have defaults - protected components");
52 
 
53 
    declare
54 
        protected type Cons (D3 : Integer := Ident_Int (11)) is
55 
            function C1_D1 return Integer;
56 
            function C1_D2 return Integer;
57 
        private
58 
            C1 : Rec (D3, 1);
59 
        end Cons;
60 
        protected body Cons is
61 
            function C1_D1 return Integer is
62 
            begin
63 
                return C1.D1;
64 
            end C1_D1;
65 
            function C1_D2 return Integer is
66 
            begin
67 
                return C1.D2;
68 
            end C1_D2;
69 
        end Cons;
70 
 
71 
        function Is_Ok
72 
                    (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer)
73 
                    return Boolean is
74 
        begin
75 
            return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2;
76 
        end Is_Ok;
77 
 
78 
    begin
79 
        begin
80 
            declare
81 
                X : Cons;
82 
            begin
83 
                Failed ("Discriminant check not performed - 1");
84 
                if not Is_Ok (X, 1, 1, 1) then
85 
                    Comment ("Shouldn't get here");
86 
                end if;
87 
            end;
88 
        exception
89 
            when Constraint_Error =>
90 
                null;
91 
            when others =>
92 
                Failed ("Unexpected exception - 1");
93 
        end;
94 
 
95 
        begin
96 
            declare
97 
                type Acc_Cons is access Cons;
98 
                X : Acc_Cons;
99 
            begin
100 
                X := new Cons;
101 
                Failed ("Discriminant check not performed - 2");
102 
                begin
103 
                    if not Is_Ok (X.all, 1, 1, 1) then
104 
                        Comment ("Irrelevant");
105 
                    end if;
106 
                end;
107 
            exception
108 
                when Constraint_Error =>
109 
                    null;
110 
                when others =>
111 
                    Failed ("Unexpected exception raised - 2");
112 
            end;
113 
        exception
114 
            when others =>
115 
                Failed ("Constraint checked too soon - 2");
116 
        end;
117 
 
118 
        begin
119 
            declare
120 
                subtype Scons is Cons;
121 
            begin
122 
                declare
123 
                    X : Scons;
124 
                begin
125 
                    Failed ("Discriminant check not performed - 3");
126 
                    if not Is_Ok (X, 1, 1, 1) then
127 
                        Comment ("Irrelevant");
128 
                    end if;
129 
                end;
130 
            exception
131 
                when Constraint_Error =>
132 
                    null;
133 
                when others =>
134 
                    Failed ("Unexpected exception raised - 3");
135 
            end;
136 
        exception
137 
            when others =>
138 
                Failed ("Constraint checked too soon - 3");
139 
        end;
140 
 
141 
        begin
142 
            declare
143 
                type Arr is array (1 .. 5) of Cons;
144 
            begin
145 
                declare
146 
                    X : Arr;
147 
                begin
148 
                    Failed ("Discriminant check not performed - 4");
149 
                    for I in Arr'Range loop
150 
                        if not Is_Ok (X (I), 1, 1, 1) then
151 
                            Comment ("Irrelevant");
152 
                        end if;
153 
                    end loop;
154 
                end;
155 
            exception
156 
                when Constraint_Error =>
157 
                    null;
158 
                when others =>
159 
                    Failed ("Unexpected exception raised - 4");
160 
            end;
161 
        exception
162 
            when others =>
163 
                Failed ("Constraint checked too soon - 4");
164 
        end;
165 
 
166 
        begin
167 
            declare
168 
                type Nrec is
169 
                    record
170 
                        C1 : Cons;
171 
                    end record;
172 
            begin
173 
                declare
174 
                    X : Nrec;
175 
                begin
176 
                    Failed ("Discriminant check not performed - 5");
177 
                    if not Is_Ok (X.C1, 1, 1, 1) then
178 
                        Comment ("Irrelevant");
179 
                    end if;
180 
                end;
181 
            exception
182 
                when Constraint_Error =>
183 
                    null;
184 
                when others =>
185 
                    Failed ("Unexpected exception raised - 5");
186 
            end;
187 
        exception
188 
            when others =>
189 
                Failed ("Constraint checked too soon - 5");
190 
        end;
191 
 
192 
        begin
193 
            declare
194 
                type Drec is new Cons;
195 
            begin
196 
                declare
197 
                    X : Drec;
198 
                begin
199 
                    Failed ("Discriminant check not performed - 6");
200 
                    if not Is_Ok (Cons (X), 1, 1, 1) then
201 
                        Comment ("Irrelevant");
202 
                    end if;
203 
                end;
204 
            exception
205 
                when Constraint_Error =>
206 
                    null;
207 
                when others =>
208 
                    Failed ("Unexpected exception raised - 6");
209 
            end;
210 
        exception
211 
            when others =>
212 
                Failed ("Constraint checked too soon - 6");
213 
        end;
214 
 
215 
    end;
216 
 
217 
    Result;
218 
 
219 
exception
220 
    when others =>
221 
        Failed ("Constraint check done too early");
222 
        Result;
223 
end C380003;

powered by: WebSVN 2.1.0

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