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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc54001.a] - Blame information for rev 816

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 149 jeremybenn
-- CC54001.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 a general access-to-constant type may be passed as an
28
--      actual to a generic formal access-to-constant type.
29
--
30
-- TEST DESCRIPTION:
31
--      The generic implements a stack of access objects as an array. The
32
--      designated type of the formal access type is itself a formal private
33
--      type declared in the same generic formal part.
34
--
35
--      The generic is instantiated with an unconstrained subtype of String,
36
--      which results in a stack which can accommodate strings of varying
37
--      lengths (ragged array). Furthermore, the access objects to be pushed
38
--      onto the stack are created both statically and dynamically, utilizing
39
--      allocators and the 'Access attribute.
40
--
41
--
42
-- CHANGE HISTORY:
43
--      06 Dec 94   SAIC    ACVC 2.0
44
--      10 Apr 96   SAIC    ACVC 2.1: Added pragma Elaborate to context clause
45
--                          preceding CC54001_1.
46
--
47
--!
48
 
49
generic
50
   Size : in Positive;
51
   type Element_Type (<>) is private;
52
   type Element_Ptr       is access constant Element_Type;
53
package CC54001_0 is -- Generic stack of pointers.
54
 
55
   type Stack_Type is private;
56
 
57
   procedure Push (Stack    : in out Stack_Type;
58
                   Elem_Ptr : in     Element_Ptr);
59
 
60
   procedure Pop  (Stack    : in out Stack_Type;
61
                   Elem_Ptr :    out Element_Ptr);
62
 
63
   -- ... Other operations.
64
 
65
private
66
 
67
   subtype Index is Positive range 1 .. (Size + 1);
68
   type Stack_Type is array (Index) of Element_Ptr;  -- Last element unused.
69
 
70
   Top : Index := 1;
71
 
72
end CC54001_0;
73
 
74
 
75
     --===================================================================--
76
 
77
 
78
package body CC54001_0 is
79
 
80
   procedure Push (Stack    : in out Stack_Type;
81
                   Elem_Ptr : in     Element_Ptr) is
82
   begin
83
      Stack(Top) := Elem_Ptr;
84
      Top := Top + 1;  -- Artificial: no Constraint_Error protection.
85
   end Push;
86
 
87
 
88
   procedure Pop (Stack    : in out Stack_Type;
89
                  Elem_Ptr :    out Element_Ptr) is
90
   begin
91
      Top := Top - 1;  -- Artificial: no Constraint_Error protection.
92
      Elem_Ptr := Stack(Top);
93
   end Pop;
94
 
95
end CC54001_0;
96
 
97
 
98
     --===================================================================--
99
 
100
 
101
with CC54001_0;      -- Generic stack of pointers.
102
pragma Elaborate (CC54001_0);
103
 
104
package CC54001_1 is
105
 
106
   subtype Message     is String;
107
   type    Message_Ptr is access constant Message;
108
 
109
   Message_Count : constant := 4;
110
 
111
   Message_0 : aliased constant Message := "Hello";
112
   Message_1 : aliased constant Message := "Doctor";
113
   Message_2 : aliased constant Message := "Name";
114
   Message_3 : aliased constant Message := "Continue";
115
 
116
 
117
   package Stack_of_Messages is new CC54001_0
118
     (Element_Type => Message,
119
      Element_Ptr  => Message_Ptr,
120
      Size         => Message_Count);
121
 
122
   Message_Stack : Stack_Of_Messages.Stack_Type;
123
 
124
 
125
   procedure Create_Message_Stack;
126
 
127
end CC54001_1;
128
 
129
 
130
     --===================================================================--
131
 
132
 
133
package body CC54001_1 is
134
 
135
   procedure Create_Message_Stack is
136
      -- Push access objects onto stack. Note that some are statically
137
      -- allocated, and some are dynamically allocated (using an aliased
138
      -- object to initialize).
139
   begin
140
      Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static.
141
      Stack_Of_Messages.Push (Message_Stack,
142
                              new Message'(Message_1));         -- Dynamic.
143
      Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static.
144
      Stack_Of_Messages.Push (Message_Stack,                    -- Dynamic.
145
                              new Message'(Message_3));
146
   end Create_Message_Stack;
147
 
148
end CC54001_1;
149
 
150
 
151
     --===================================================================--
152
 
153
 
154
with CC54001_1;
155
 
156
with Report;
157
procedure CC54001 is
158
 
159
   package Messages renames CC54001_1.Stack_Of_Messages;
160
 
161
   Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr;
162
 
163
begin
164
   Report.Test ("CC54001", "Check that a general access-to-constant type "   &
165
                           "may be passed as an actual to a generic formal " &
166
                           "access-to-constant type");
167
 
168
   CC54001_1.Create_Message_Stack;
169
 
170
   Messages.Pop (CC54001_1.Message_Stack, Msg3);  -- Pop items off stack in the
171
   Messages.Pop (CC54001_1.Message_Stack, Msg2);  -- reverse order that they
172
   Messages.Pop (CC54001_1.Message_Stack, Msg1);  -- were pushed.
173
   Messages.Pop (CC54001_1.Message_Stack, Msg0);
174
 
175
   if Msg0.all /= CC54001_1.Message_0 or else
176
      Msg1.all /= CC54001_1.Message_1 or else
177
      Msg2.all /= CC54001_1.Message_2 or else
178
      Msg3.all /= CC54001_1.Message_3
179
   then
180
      Report.Failed ("Items popped off of stack do not match those pushed");
181
   end if;
182
 
183
   Report.Result;
184
end CC54001;

powered by: WebSVN 2.1.0

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