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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C390011.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 tagged types declared within generic package declarations
28
--     generate distinct tags for each instance of the generic.
29
--
30
-- TEST DESCRIPTION:
31
--     This test defines a very simple generic package (with the expectation
32
--     that it should be easily be shared), and a few instances of that
33
--     package.  In true user-like fashion, two of the instances are identical
34
--     (to wit: IIO is new Integer_IO(Integer)).  The tags generated for each
35
--     of them are placed into a list.  The last action of the test is to
36
--     check that everything in the list is unique.
37
--
38
--     Almost as an aside, this test defines functions that return T'Base and
39
--     T'Class, and then exercises these functions.
40
--
41
--     (JPR) persistent objects really need a function like:
42
--        function Get_Object return T'class;
43
--
44
--
45
-- CHANGE HISTORY:
46
--      20 OCT 95   SAIC   Initial version
47
--      23 APR 96   SAIC   Commentary Corrections 2.1
48
--
49
--!
50
 
51
----------------------------------------------------------------- C390011_0
52
 
53
with Ada.Tags;
54
package C390011_0 is
55
 
56
  procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String );
57
 
58
  procedure Check_List_For_Duplicates;
59
 
60
end C390011_0;
61
 
62
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
63
 
64
with Report;
65
package body C390011_0 is
66
 
67
  use type Ada.Tags.Tag;
68
  type SP is access String;
69
 
70
  type List_Item;
71
  type List_P is access List_Item;
72
  type List_Item is record
73
    The_Tag  : Ada.Tags.Tag;
74
    Exp_Name : SP;
75
    Ext_Tag  : SP;
76
    Next : List_P;
77
  end record;
78
 
79
  The_List : List_P;
80
 
81
  procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is
82
  begin  -- prepend the tag information to the list
83
    The_List := new List_Item'( The_Tag  => T,
84
                                Exp_Name => new String'(X_Name),
85
                                Ext_Tag  => new String'(X_Tag),
86
                                Next     => The_List );
87
  end Add_Tag_To_List;
88
 
89
  procedure Check_List_For_Duplicates is
90
    Finger : List_P;
91
    Thumb  : List_P := The_List;
92
  begin  --
93
    while Thumb /= null loop
94
      Finger := Thumb.Next;
95
      while Finger /= null loop
96
        -- Check that the tag is unique
97
        if Finger.The_Tag = Thumb.The_Tag then
98
          Report.Failed("Duplicate Tag");
99
        end if;
100
 
101
        -- Check that the Expanded name is unique
102
        if Finger.Exp_Name.all = Thumb.Exp_Name.all then
103
          Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats");
104
        end if;
105
 
106
        -- Check that the External Tag is unique
107
 
108
        if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then
109
          Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats");
110
        end if;
111
        Finger := Finger.Next;
112
      end loop;
113
      Thumb  := Thumb.Next;
114
   end loop;
115
  end Check_List_For_Duplicates;
116
 
117
begin
118
  -- some things I just don't trust...
119
  if The_List /= null then
120
    Report.Failed("Implicit default for The_List not null");
121
  end if;
122
end C390011_0;
123
 
124
----------------------------------------------------------------- C390011_1
125
 
126
generic
127
  type Index is (<>);
128
  type Item is private;
129
package C390011_1 is
130
 
131
  type List is array(Index range <>) of Item;
132
  type ListP is access all List;
133
 
134
  type Table is tagged record
135
    Data: ListP;
136
  end record;
137
 
138
  function Sort( T: in Table'Class ) return Table'Class;
139
 
140
  function Stable_Table return Table'Class;
141
 
142
  function Table_End( T: Table ) return Index'Base;
143
 
144
end C390011_1;
145
 
146
-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
147
 
148
package body C390011_1 is
149
 
150
    -- In a user program this package would DO something
151
 
152
  function Sort( T: in Table'Class ) return Table'Class is
153
  begin
154
   return T;
155
  end Sort;
156
 
157
  Empty : Table'Class := Table'( Data => null );
158
 
159
  function Stable_Table return Table'Class is
160
  begin
161
    return Empty;
162
  end Stable_Table;
163
 
164
  function Table_End( T: Table ) return Index'Base is
165
  begin
166
    return Index'Base( T.Data.all'Last );
167
  end Table_End;
168
 
169
end C390011_1;
170
 
171
----------------------------------------------------------------- C390011_2
172
 
173
with C390011_1;
174
package C390011_2 is new C390011_1( Index => Character, Item => Float );
175
 
176
----------------------------------------------------------------- C390011_3
177
 
178
with C390011_1;
179
package C390011_3 is new C390011_1( Index => Character, Item => Float );
180
 
181
----------------------------------------------------------------- C390011_4
182
 
183
with C390011_1;
184
package C390011_4 is new C390011_1( Index => Integer, Item => Character );
185
 
186
----------------------------------------------------------------- C390011_5
187
 
188
with C390011_3;
189
with C390011_4;
190
package C390011_5 is
191
 
192
  type Table_3 is new C390011_3.Table with record
193
    Serial_Number : Integer;
194
  end record;
195
 
196
  type Table_4 is new C390011_4.Table with record
197
    Serial_Number : Integer;
198
  end record;
199
 
200
end C390011_5;
201
 
202
-- no package body C390011_5 required
203
 
204
------------------------------------------------------------------- C390011
205
 
206
with Report;
207
with C390011_0;
208
with C390011_2;
209
with C390011_3;
210
with C390011_4;
211
with C390011_5;
212
with Ada.Tags;
213
procedure C390011 is
214
 
215
begin  -- Main test procedure.
216
 
217
  Report.Test ("C390011", "Check that tagged types declared within " &
218
                          "generic package declarations generate distinct " &
219
                          "tags for each instance of the generic. " &
220
                          "Check that 'Base may be used as a subtype mark. " &
221
                          "Check that T'Base and T'Class are allowed as " &
222
                          "the subtype mark in a function result" );
223
 
224
  -- build the tag information table
225
  C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag,
226
                       X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag),
227
                       X_Tag  => Ada.Tags.External_Tag(C390011_2.Table'Tag) );
228
 
229
  C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag,
230
                       X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag),
231
                       X_Tag  => Ada.Tags.External_Tag(C390011_3.Table'Tag) );
232
 
233
  C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag,
234
                       X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag),
235
                       X_Tag  => Ada.Tags.External_Tag(C390011_4.Table'Tag) );
236
 
237
  C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag,
238
                     X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag),
239
                     X_Tag  => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) );
240
 
241
  C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag,
242
                     X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag),
243
                     X_Tag  => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) );
244
 
245
  -- preform the check for distinct tags
246
  C390011_0.Check_List_For_Duplicates;
247
 
248
  Report.Result;
249
 
250
end C390011;

powered by: WebSVN 2.1.0

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