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

Subversion Repositories openrisc

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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 720 jeremybenn
-- CC51002.A
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
--
26
-- OBJECTIVE:
27
--      Check that, for formal derived tagged types, the formal parameter
28
--      names and default expressions for a primitive subprogram in an
29
--      instance are determined by the primitive subprogram of the ancestor
30
--      type, but that the primitive subprogram body executed is that of the
31
--      actual type.
32
--
33
-- TEST DESCRIPTION:
34
--      Define a root tagged type in a library-level package and give it a
35
--      primitive subprogram. Provide a default expression for a non-tagged
36
--      parameter of the subprogram. Declare a library-level generic subprogram
37
--      with a formal derived type using the root type as ancestor. Call
38
--      the primitive subprogram of the root type using named association for
39
--      the tagged parameter, and provide no actual for the defaulted
40
--      parameter. Extend the root type in a second package and override the
41
--      root type's subprogram with one which has different parameter names
42
--      and no default expression for the non-tagged parameter. Instantiate
43
--      the generic subprogram for each of the tagged types in the class and
44
--      call the instances.
45
--
46
--
47
-- CHANGE HISTORY:
48
--      06 Dec 94   SAIC    ACVC 2.0
49
--
50
--!
51
 
52
package CC51002_0 is  -- Root message type and operations.
53
 
54
   type Recipients is (None, Root, Sysop, Local, Remote);
55
 
56
   type Msg_Type is tagged record                             -- Root type of
57
      Text : String (1 .. 10);                                -- class.
58
   end record;
59
 
60
   function Send (Msg : in Msg_Type;                          -- Primitive
61
                  To  : Recipients := Local) return Boolean;  -- subprogram.
62
 
63
   -- ...Other message operations.
64
 
65
end CC51002_0;
66
 
67
 
68
     --==================================================================--
69
 
70
 
71
package body CC51002_0 is
72
 
73
   -- The implementation of Send is purely artificial; the validity of
74
   -- its implementation in the context of the abstraction is irrelevant to
75
   -- the feature being tested.
76
 
77
   function Send (Msg : in Msg_Type;
78
                  To  : Recipients := Local) return Boolean is
79
   begin
80
      return (Msg.Text = "Greetings!" and To = Local);
81
   end Send;
82
 
83
end CC51002_0;
84
 
85
 
86
     --==================================================================--
87
 
88
 
89
with CC51002_0;  -- Root message type and operations.
90
generic          -- Message class function.
91
   type Msg_Block is new CC51002_0.Msg_Type with private;
92
function CC51002_1 (M : in Msg_Block) return Boolean;
93
 
94
 
95
     --==================================================================--
96
 
97
 
98
function CC51002_1 (M : in Msg_Block) return Boolean is
99
   Okay : Boolean := False;
100
begin
101
 
102
   -- The call to Send below uses the ancestor type's parameter name, which
103
   -- should be legal even if the actual subprogram called does not have a
104
   -- parameter of that name. Furthermore, it uses the ancestor type's default
105
   -- expression for the second parameter, which should be legal even if the
106
   -- the actual subprogram called has no such default expression.
107
 
108
   Okay := Send (Msg => M);
109
   -- ...Other processing.
110
   return Okay;
111
 
112
end CC51002_1;
113
 
114
 
115
     --==================================================================--
116
 
117
 
118
with CC51002_0;       -- Root message type and operations.
119
package CC51002_2 is  -- Extended message type and operations.
120
 
121
   type Sender_Type is (Inside, Outside);
122
 
123
   type Who_Msg_Type is new CC51002_0.Msg_Type with record   -- Derivative of
124
      From : Sender_Type;                                    -- root type of
125
   end record;                                               -- class.
126
 
127
 
128
   -- Note: this overriding version of Send has different parameter names
129
   -- from the root type's function. It also has no default expression.
130
 
131
   function Send (M : Who_Msg_Type;                          -- Overrides
132
                  R : CC51002_0.Recipients) return Boolean;  -- root type's
133
                                                             -- operation.
134
   -- ...Other extended message operations.
135
 
136
end CC51002_2;
137
 
138
 
139
     --==================================================================--
140
 
141
 
142
package body CC51002_2 is
143
 
144
   -- The implementation of Send is purely artificial; the validity of
145
   -- its implementation in the context of the abstraction is irrelevant to
146
   -- the feature being tested.
147
 
148
   function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is
149
      use type CC51002_0.Recipients;
150
   begin
151
      return (M.Text = "Willkommen"     and
152
              M.From = Outside          and
153
              R      = CC51002_0.Local);
154
   end Send;
155
 
156
end CC51002_2;
157
 
158
 
159
     --==================================================================--
160
 
161
 
162
with CC51002_0;  -- Root message type and operations.
163
with CC51002_1;  -- Message class function.
164
with CC51002_2;  -- Extended message type and operations.
165
 
166
with Report;
167
procedure CC51002 is
168
 
169
   function Send_Msg  is new CC51002_1 (CC51002_0.Msg_Type);
170
   function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type);
171
 
172
   Mess  : CC51002_0.Msg_Type     := (Text => "Greetings!");
173
   WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen",
174
                                      From => CC51002_2.Outside);
175
 
176
   TC_Okay_MStatus  : Boolean := False;
177
   TC_Okay_WMStatus : Boolean := False;
178
 
179
begin
180
   Report.Test ("CC51002", "Check that, for formal derived tagged types, " &
181
                "the formal parameter names and default expressions for "  &
182
                "a primitive subprogram in an instance are determined by " &
183
                "the primitive subprogram of the ancestor type, but that " &
184
                "the primitive subprogram body executed is that of the"    &
185
                "actual type");
186
 
187
   TC_Okay_MStatus := Send_Msg (Mess);
188
   if not TC_Okay_MStatus then
189
      Report.Failed ("Wrong result from call to root type's operation");
190
   end if;
191
 
192
   TC_Okay_WMStatus := Send_WMsg (WMess);
193
   if not TC_Okay_WMStatus then
194
      Report.Failed ("Wrong result from call to derived type's operation");
195
   end if;
196
 
197
   Report.Result;
198
end CC51002;

powered by: WebSVN 2.1.0

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