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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- C854002.A
2
--
3
--                             Grant of Unlimited Rights
4
--
5
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and
6
--     F08630-91-C-0015, the U.S. Government obtained unlimited rights in the
7
--     software and documentation contained herein.  Unlimited rights are
8
--     defined in DFAR 252.227-7013(a)(19).  By making this public release,
9
--     the Government intends to confer upon all recipients unlimited rights
10
--     equal to those held by the Government.  These rights include rights to
11
--     use, duplicate, release or disclose the released technical data and
12
--     computer software in whole or in part, in any manner and for any purpose
13
--     whatsoever, and to have or permit others to do so.
14
--
15
--                                    DISCLAIMER
16
--
17
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
18
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
19
--     WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE
20
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
21
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
22
--     PARTICULAR PURPOSE OF SAID MATERIAL.
23
--*
24
--
25
-- OBJECTIVE
26
--     Check the requirements of the new 8.5.4(8.A) from Technical
27
--     Corrigendum 1 (originally discussed as AI95-00064).
28
--     This paragraph requires an elaboration check on renamings-as-body:
29
--     even if the body of the ultimately-called subprogram has been
30
--     elaborated, the check should fail if the renaming-as-body
31
--     itself has not yet been elaborated.
32
--
33
-- TEST DESCRIPTION
34
--     We declare two functions F and G, and ensure that they are
35
--     elaborated before anything else, by using pragma Pure.  Then we
36
--     declare two renamings-as-body: the renaming of F is direct, and
37
--     the renaming of G is via an access-to-function object.  We call
38
--     the renamings during elaboration, and check that they raise
39
--     Program_Error.  We then call them again after elaboration; this
40
--     time, they should work.
41
--
42
-- CHANGE HISTORY:
43
--      29 JUN 1999   RAD   Initial Version
44
--      23 SEP 1999   RLB   Improved comments, renamed, issued.
45
--      28 JUN 2002   RLB   Added pragma Elaborate_All for Report.
46
--!
47
 
48
package C854002_1 is
49
    pragma Pure;
50
    -- Empty.
51
end C854002_1;
52
 
53
package C854002_1.Pure is
54
    pragma Pure;
55
    function F return String;
56
    function G return String;
57
end C854002_1.Pure;
58
 
59
with C854002_1.Pure;
60
package C854002_1.Renamings is
61
 
62
    F_Result: constant String := C854002_1.Pure.F; -- Make sure we can call F.
63
    function Renamed_F return String;
64
 
65
    G_Result: constant String := C854002_1.Pure.G;
66
    type String_Function is access function return String;
67
    G_Pointer: String_Function := null;
68
        -- Will be set to C854002_1.Pure.G'Access in the body.
69
    function Renamed_G return String;
70
 
71
end C854002_1.Renamings;
72
 
73
package C854002_1.Caller is
74
 
75
    -- These procedures call the renamings; when called during elaboration,
76
    -- we pass Should_Fail => True, which checks that Program_Error is
77
    -- raised.  Later, we use Should_Fail => False.
78
 
79
    procedure Call_Renamed_F(Should_Fail: Boolean);
80
    procedure Call_Renamed_G(Should_Fail: Boolean);
81
 
82
end C854002_1.Caller;
83
 
84
with Report; use Report; pragma Elaborate_All (Report);
85
with C854002_1.Renamings;
86
package body C854002_1.Caller is
87
 
88
    Some_Error: exception;
89
 
90
    procedure Call_Renamed_F(Should_Fail: Boolean) is
91
    begin
92
        if Should_Fail then
93
            begin
94
                Failed(C854002_1.Renamings.Renamed_F);
95
                raise Some_Error;
96
                    -- This raise statement is necessary, because the
97
                    -- Report package has a bug -- if Failed is called
98
                    -- before Test, then the failure is ignored, and the
99
                    -- test prints "PASSED".
100
                    -- Presumably, this raise statement will cause the
101
                    -- program to crash, thus avoiding the PASSED message.
102
            exception
103
                when Program_Error =>
104
                    Comment("Program_Error -- OK");
105
            end;
106
        else
107
            if C854002_1.Renamings.F_Result /= C854002_1.Renamings.Renamed_F then
108
                Failed("Bad result from renamed F");
109
            end if;
110
        end if;
111
    end Call_Renamed_F;
112
 
113
    procedure Call_Renamed_G(Should_Fail: Boolean) is
114
    begin
115
        if Should_Fail then
116
            begin
117
                Failed(C854002_1.Renamings.Renamed_G);
118
                raise Some_Error;
119
            exception
120
                when Program_Error =>
121
                    Comment("Program_Error -- OK");
122
            end;
123
        else
124
            if C854002_1.Renamings.G_Result /= C854002_1.Renamings.Renamed_G then
125
                Failed("Bad result from renamed G");
126
            end if;
127
        end if;
128
    end Call_Renamed_G;
129
 
130
begin
131
    -- At this point, the bodies of Renamed_F and Renamed_G have not yet
132
    -- been elaborated, so calling them should raise Program_Error:
133
    Call_Renamed_F(Should_Fail => True);
134
    Call_Renamed_G(Should_Fail => True);
135
end C854002_1.Caller;
136
 
137
package body C854002_1.Pure is
138
 
139
    function F return String is
140
    begin
141
        return "This is function F";
142
    end F;
143
 
144
    function G return String is
145
    begin
146
        return "This is function G";
147
    end G;
148
 
149
end C854002_1.Pure;
150
 
151
with C854002_1.Pure;
152
with C854002_1.Caller; pragma Elaborate(C854002_1.Caller);
153
    -- This pragma ensures that this package body (Renamings)
154
    -- will be elaborated after Caller, so that when Caller calls
155
    -- the renamings during its elaboration, the renamings will
156
    -- not have been elaborated (although what the rename have been).
157
package body C854002_1.Renamings is
158
 
159
    function Renamed_F return String renames C854002_1.Pure.F;
160
 
161
    package Dummy is end; -- So we can insert statements here.
162
    package body Dummy is
163
    begin
164
        G_Pointer := C854002_1.Pure.G'Access;
165
    end Dummy;
166
 
167
    function Renamed_G return String renames G_Pointer.all;
168
 
169
end C854002_1.Renamings;
170
 
171
with Report; use Report;
172
with C854002_1.Caller;
173
procedure C854002 is
174
begin
175
    Test("C854002",
176
         "An elaboration check is performed for a call to a subprogram"
177
         & " whose body is given as a renaming-as-body");
178
 
179
    -- By the time we get here, all library units have been elaborated,
180
    -- so the following calls should not raise Program_Error:
181
    C854002_1.Caller.Call_Renamed_F(Should_Fail => False);
182
    C854002_1.Caller.Call_Renamed_G(Should_Fail => False);
183
 
184
    Result;
185
end C854002;

powered by: WebSVN 2.1.0

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