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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [ca/] [ca11a01.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- CA11A01.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 type extended in a public child inherits primitive
28
--      operations from its ancestor.
29
--
30
-- TEST DESCRIPTION:
31
--      Declare a root tagged type in a package specification. Declare two
32
--      primitive subprograms for the type (foundation code).
33
--
34
--      Add a public child to the above package.  Extend the root type with
35
--      a record extension in the specification.  Declare a new primitive
36
--      subprogram to write to the child extension.
37
--
38
--      Add a public grandchild to the above package.  Extend the extension of
39
--      the parent type with a record extension in the private part of the
40
--      specification.  Declare a new primitive subprogram for this grandchild
41
--      extension.
42
--
43
--      In the main program, "with" the grandchild.  Access the primitive
44
--      operations from grandparent and parent package.
45
--
46
-- TEST FILES:
47
--      This test depends on the following foundation code:
48
--
49
--         FA11A00.A
50
--
51
--
52
-- CHANGE HISTORY:
53
--      06 Dec 94   SAIC    ACVC 2.0
54
--
55
--!
56
 
57
package FA11A00.CA11A01_0 is     -- Color_Widget_Pkg
58
-- This public child declares an extension from its parent.  It
59
-- represents processing of widgets in a window system.
60
 
61
   type Widget_Color_Enum is (Black, Green, White);
62
 
63
   type Color_Widget is new Widget with           -- Record extension of
64
      record                                      -- parent tagged type.
65
         Color : Widget_Color_Enum;
66
      end record;
67
 
68
   -- Inherits procedure Set_Width from Widget.
69
   -- Inherits procedure Set_Height from Widget.
70
 
71
   -- To be inherited by its derivatives.
72
   procedure Set_Color (The_Widget : in out Color_Widget;
73
                        C          : in     Widget_Color_Enum);
74
 
75
   procedure Set_Color_Widget (The_Widget : in out Color_Widget;
76
                               The_Width  : in     Widget_Length;
77
                               The_Height : in     Widget_Length;
78
                               The_Color  : in     Widget_Color_Enum);
79
 
80
end FA11A00.CA11A01_0;     -- Color_Widget_Pkg
81
 
82
--=======================================================================--
83
 
84
package body FA11A00.CA11A01_0 is     -- Color_Widget_Pkg
85
 
86
   procedure Set_Color (The_Widget : in out Color_Widget;
87
                        C          : in     Widget_Color_Enum) is
88
   begin
89
      The_Widget.Color := C;
90
   end Set_Color;
91
   ---------------------------------------------------------------
92
   procedure Set_Color_Widget (The_Widget : in out Color_Widget;
93
                               The_Width  : in     Widget_Length;
94
                               The_Height : in     Widget_Length;
95
                               The_Color  : in     Widget_Color_Enum) is
96
   begin
97
      Set_Width  (The_Widget, The_Width);   -- Inherited from parent.
98
      Set_Height (The_Widget, The_Height);  -- Inherited from parent.
99
      Set_Color  (The_Widget, The_Color);
100
   end Set_Color_Widget;
101
 
102
end FA11A00.CA11A01_0;     -- Color_Widget_Pkg
103
 
104
--=======================================================================--
105
 
106
package FA11A00.CA11A01_0.CA11A01_1 is     -- Label_Widget_Pkg
107
-- This public grandchild extends the extension from its parent.  It
108
-- represents processing of widgets in a window system.
109
 
110
   -- Declaration used by private extension component.
111
   subtype Widget_Label_Str is string (1 .. 10);
112
 
113
   type Label_Widget is new Color_Widget with private;
114
                            -- Record extension of parent tagged type.
115
 
116
   -- Inherits (inherited) procedure Set_Width from Color_Widget.
117
   -- Inherits (inherited) procedure Set_Height from Color_Widget.
118
   -- Inherits procedure Set_Color from Color_Widget.
119
   -- Inherits procedure Set_Color_Widget from Color_Widget.
120
 
121
   procedure Set_Label_Widget (The_Widget : in out Label_Widget;
122
                               The_Width  : in     Widget_Length;
123
                               The_Height : in     Widget_Length;
124
                               The_Color  : in     Widget_Color_Enum;
125
                               The_Label  : in     Widget_Label_Str);
126
 
127
   -- The following function is needed to verify the value of the
128
   -- extension's private component.
129
 
130
   function Verify_Label (The_Widget : in Label_Widget;
131
                          The_Label  : in Widget_Label_Str) return Boolean;
132
 
133
private
134
   type Label_Widget is new Color_Widget with
135
      record
136
         Label : Widget_Label_Str;
137
      end record;
138
 
139
end FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg
140
 
141
--=======================================================================--
142
 
143
package body FA11A00.CA11A01_0.CA11A01_1 is     -- Label_Widget_Pkg
144
 
145
   procedure Set_Label (The_Widget : in out Label_Widget;
146
                        L          : in     Widget_Label_Str) is
147
   begin
148
      The_Widget.Label := L;
149
   end Set_Label;
150
   --------------------------------------------------------------
151
   procedure Set_Label_Widget (The_Widget : in out Label_Widget;
152
                               The_Width  : in     Widget_Length;
153
                               The_Height : in     Widget_Length;
154
                               The_Color  : in     Widget_Color_Enum;
155
                               The_Label  : in     Widget_Label_Str) is
156
   begin
157
      Set_Width  (The_Widget, The_Width);   -- Twice inherited.
158
      Set_Height (The_Widget, The_Height);  -- Twice inherited.
159
      Set_Color  (The_Widget, The_Color);   -- Inherited from parent.
160
      Set_Label  (The_Widget, The_Label);
161
   end Set_Label_Widget;
162
   --------------------------------------------------------------
163
   function Verify_Label (The_Widget : in Label_Widget;
164
                          The_Label  : in Widget_Label_Str) return Boolean is
165
   begin
166
      return (The_Widget.Label = The_Label);
167
   end Verify_Label;
168
 
169
end FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg
170
 
171
--=======================================================================--
172
 
173
with FA11A00.CA11A01_0.CA11A01_1;     -- Label_Widget_Pkg,
174
                                      -- implicitly with Widget_Pkg,
175
                                      -- implicitly with Color_Widget_Pkg
176
with Report;
177
 
178
procedure CA11A01 is
179
 
180
   package Widget_Pkg renames FA11A00;
181
   package Color_Widget_Pkg renames FA11A00.CA11A01_0;
182
   package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1;
183
 
184
   use Widget_Pkg;              -- All user-defined operators directly visible.
185
 
186
   Mail_Label     : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail";
187
 
188
   Default_Widget : Widget;
189
   Black_Widget   : Color_Widget_Pkg.Color_Widget;
190
   Mail_Widget    : Label_Widget_Pkg.Label_Widget;
191
 
192
begin
193
 
194
   Report.Test ("CA11A01", "Check that type extended in a public " &
195
                "child inherits primitive operations from its " &
196
                "ancestor");
197
 
198
   Set_Width (Default_Widget, 9);             -- Call from parent.
199
   Set_Height (Default_Widget, 10);           -- Call from parent.
200
 
201
   If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or
202
     Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then
203
        Report.Failed ("Incorrect result for Default_Widget");
204
   end if;
205
 
206
   Color_Widget_Pkg.Set_Color_Widget
207
     (Black_Widget, 17, 18, Color_Widget_Pkg.Black);   -- Explicitly declared.
208
 
209
   If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or
210
     Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or
211
       Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then
212
          Report.Failed ("Incorrect result for Black_Widget");
213
   end if;
214
 
215
   Label_Widget_Pkg.Set_Label_Widget
216
     (Mail_Widget, 15, 21, Color_Widget_Pkg.White,
217
       "Quick_Mail");                                  -- Explicitly declared.
218
 
219
   If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or
220
     Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or
221
       Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or
222
         not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then
223
            Report.Failed ("Incorrect result for Mail_Widget");
224
   end if;
225
 
226
   Report.Result;
227
 
228
end CA11A01;

powered by: WebSVN 2.1.0

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