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/] [c3/] [c393011.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C393011.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
-- TEST OBJECTIVE:
27
--      Check that an abstract extended type can be derived from an abstract
28
--      type, and that a a non-abstract type may then be derived from the
29
--      second abstract type.
30
--
31
-- TEST DESCRIPTION:
32
--      Define an abstract type with three primitive operations, two of them
33
--      abstract.  Derive an extended type from it, inheriting the non-
34
--      abstract operation, overriding one of the abstract operations with
35
--      a non-abstract operation, and overriding the other abstract operation
36
--      with an abstract operation.  The extended type is therefore abstract;
37
--      derive an extended type from it.  Override the abstract operation with
38
--      a non-abstract operation; inherit one operation from the original
39
--      abstract type, and inherit one operation from the intermediate
40
--      abstract type.
41
--
42
--
43
-- CHANGE HISTORY:
44
--      06 Dec 94   SAIC    ACVC 2.0
45
--
46
--!
47
 
48
 Package C393011_0 is
49
     -- Definitions
50
 
51
   type Status_Enum is (None, Unhandled, Pending, Handled);
52
   type Serial_Type is new Integer range 0 .. Integer'Last;
53
   subtype Priority_Type is Integer range 0..10;
54
 
55
   type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen);
56
 
57
   Next : Serial_Type := 1;
58
   Display_Device : Display_Enum := Bit_Bucket;
59
 
60
 end C393011_0;
61
 -- Definitions;
62
 
63
 --=======================================================================--
64
 
65
 with C393011_0;
66
   -- Definitions
67
 
68
 Package C393011_1 is
69
      -- Alert
70
 
71
   package Definitions renames C393011_0;
72
 
73
   type Alert_Type is abstract tagged record
74
     Status     : Definitions.Status_Enum := Definitions.None;
75
     Serial_Num : Definitions.Serial_Type := 0;
76
     Priority   : Definitions.Priority_Type;
77
   end record;
78
                             -- Alert_Type is an abstract type with
79
                             -- two operations to be overridden
80
 
81
   procedure Set_Status ( A : in out Alert_Type;          -- not abstract
82
                         To : Definitions.Status_Enum);
83
 
84
   procedure Set_Serial ( A : in out Alert_Type) is abstract;
85
   procedure Display    ( A : Alert_Type)        is abstract;
86
 
87
 end C393011_1;
88
  -- Alert
89
 
90
 --=======================================================================--
91
 
92
 with C393011_0;
93
 package body C393011_1 is
94
           -- Alert
95
   procedure Set_Status ( A : in out Alert_Type;
96
                         To : Definitions.Status_Enum) is
97
     begin
98
       A.Status := To;
99
     end Set_Status;
100
 
101
 end C393011_1;
102
  -- Alert;
103
 
104
 --=======================================================================--
105
 
106
 with C393011_0,
107
   -- Definitions,
108
      C393011_1,
109
   -- Alert,
110
      Calendar;
111
 
112
 Package C393011_3 is
113
      -- New_Alert
114
 
115
   type New_Alert_Type is abstract new C393011_1.Alert_Type with record
116
     Display_Dev : C393011_0.Display_Enum := C393011_0.TTY;
117
   end record;
118
 
119
   -- procedure Set_Status is inherited
120
 
121
   procedure Set_Serial ( A : in out New_Alert_Type);   -- override/see body
122
 
123
   procedure Display    ( A : New_Alert_Type) is abstract;
124
                          -- override is abstract
125
                          -- still can't declare objects of New_Alert_Type
126
 
127
 end C393011_3;
128
  -- New_Alert
129
 
130
 --=======================================================================--
131
 
132
 with C393011_0;
133
 Package Body C393011_3 is
134
           -- New_Alert
135
 
136
   package Definitions renames C393011_0;
137
 
138
   procedure Set_Serial (A : in out New_Alert_Type) is
139
     use type Definitions.Serial_Type;
140
     begin
141
       A.Serial_Num := Definitions.Next;
142
       Definitions.Next := Definitions."+"( Definitions.Next, 1);
143
     end Set_Serial;
144
 
145
 End C393011_3;
146
  -- New_Alert;
147
 
148
 --=======================================================================--
149
 
150
 with C393011_0,
151
   -- Definitions
152
      C393011_3;
153
   -- New_Alert  -- package Alert is not visible
154
 package C393011_4 is
155
 
156
   package New_Alert renames C393011_3;
157
   package Definitions renames C393011_0;
158
 
159
   type Final_Alert_Type is new New_Alert.New_Alert_Type with null record;
160
   -- inherits Set_Status including body
161
   -- inherits Set_Serial including body
162
   -- must override Display since inherited Display is abstract
163
   procedure Display(FA : in     Final_Alert_Type);
164
   procedure Handle (FA : in out Final_Alert_Type);
165
 
166
 end C393011_4;
167
 
168
 package body C393011_4 is
169
 
170
   procedure Display    (FA : in Final_Alert_Type) is
171
     begin
172
       Definitions.Display_Device := FA.Display_Dev;
173
     end Display;
174
 
175
   procedure Handle (FA : in out Final_Alert_Type) is
176
     begin
177
       Set_Status (FA, Definitions.Handled);
178
       Set_Serial (FA);
179
       Display (FA);
180
     end Handle;
181
 end C393011_4;
182
 
183
 with C393011_0,
184
   -- Definitions
185
      C393011_3;
186
   -- New_Alert  -- package Alert is not visible
187
 with C393011_4;
188
 with Report;
189
 procedure C393011 is
190
   use C393011_4;
191
   use Definitions;
192
 
193
   FA : Final_Alert_Type;
194
 
195
 begin
196
 
197
   Report.Test ("C393011", "Check that an extended type can be derived " &
198
                           "from an abstract type");
199
 
200
   if (Definitions.Display_Device /= Definitions.Bit_Bucket)
201
       or (Definitions.Next /= 1)
202
       or (FA.Status /= Definitions.None)
203
       or (FA.Serial_Num /= 0)
204
       or (FA.Display_Dev /= TTY) then
205
     Report.Failed ("Incorrect initial conditions");
206
   end if;
207
 
208
   Handle (FA);
209
   if (Definitions.Display_Device /= Definitions.TTY)
210
       or (Definitions.Next /= 2)
211
       or (FA.Status /= Definitions.Handled)
212
       or (FA.Serial_Num /= 1)
213
       or (FA.Display_Dev /= TTY) then
214
     Report.Failed ("Incorrect results from Handle");
215
   end if;
216
 
217
   Report.Result;
218
 
219
 end C393011;
220
 

powered by: WebSVN 2.1.0

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