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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-coinho.adb] - Blame information for rev 724

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn 
------------------------------------------------------------------------------
2 
--                                                                          --
3 
--                         GNAT LIBRARY COMPONENTS                          --
4 
--                                                                          --
5 
--       A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S        --
6 
--                                                                          --
7 
--                                 B o d y                                  --
8 
--                                                                          --
9 
--             Copyright (C) 2011, Free Software Foundation, Inc.           --
10 
--                                                                          --
11 
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12 
-- terms of the  GNU General Public License as published  by the Free Soft- --
13 
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14 
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15 
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16 
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17 
--                                                                          --
18 
-- As a special exception under Section 7 of GPL version 3, you are granted --
19 
-- additional permissions described in the GCC Runtime Library Exception,   --
20 
-- version 3.1, as published by the Free Software Foundation.               --
21 
--                                                                          --
22 
-- You should have received a copy of the GNU General Public License and    --
23 
-- a copy of the GCC Runtime Library Exception along with this program;     --
24 
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25 
-- <http://www.gnu.org/licenses/>.                                          --
26 
------------------------------------------------------------------------------
27 
 
28 
with Ada.Unchecked_Deallocation;
29 
 
30 
package body Ada.Containers.Indefinite_Holders is
31 
 
32 
   procedure Free is
33 
     new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
34 
 
35 
   ---------
36 
   -- "=" --
37 
   ---------
38 
 
39 
   function "=" (Left, Right : Holder) return Boolean is
40 
   begin
41 
      if Left.Element = null and Right.Element = null then
42 
         return True;
43 
 
44 
      elsif Left.Element /= null and Right.Element /= null then
45 
         return Left.Element.all = Right.Element.all;
46 
 
47 
      else
48 
         return False;
49 
      end if;
50 
   end "=";
51 
 
52 
   ------------
53 
   -- Adjust --
54 
   ------------
55 
 
56 
   overriding procedure Adjust (Container : in out Holder) is
57 
   begin
58 
      if Container.Element /= null then
59 
         Container.Element := new Element_Type'(Container.Element.all);
60 
      end if;
61 
 
62 
      Container.Busy := 0;
63 
   end Adjust;
64 
 
65 
   ------------
66 
   -- Assign --
67 
   ------------
68 
 
69 
   procedure Assign (Target : in out Holder; Source : Holder) is
70 
   begin
71 
      if Target.Busy /= 0 then
72 
         raise Program_Error with "attempt to tamper with elements";
73 
      end if;
74 
 
75 
      if Target.Element /= Source.Element then
76 
         Free (Target.Element);
77 
 
78 
         if Source.Element /= null then
79 
            Target.Element := new Element_Type'(Source.Element.all);
80 
         end if;
81 
      end if;
82 
   end Assign;
83 
 
84 
   -----------
85 
   -- Clear --
86 
   -----------
87 
 
88 
   procedure Clear (Container : in out Holder) is
89 
   begin
90 
      if Container.Busy /= 0 then
91 
         raise Program_Error with "attempt to tamper with elements";
92 
      end if;
93 
 
94 
      Free (Container.Element);
95 
   end Clear;
96 
 
97 
   ----------
98 
   -- Copy --
99 
   ----------
100 
 
101 
   function Copy (Source : Holder) return Holder is
102 
   begin
103 
      if Source.Element = null then
104 
         return (AF.Controlled with null, 0);
105 
      else
106 
         return (AF.Controlled with new Element_Type'(Source.Element.all), 0);
107 
      end if;
108 
   end Copy;
109 
 
110 
   -------------
111 
   -- Element --
112 
   -------------
113 
 
114 
   function Element (Container : Holder) return Element_Type is
115 
   begin
116 
      if Container.Element = null then
117 
         raise Constraint_Error with "container is empty";
118 
      else
119 
         return Container.Element.all;
120 
      end if;
121 
   end Element;
122 
 
123 
   --------------
124 
   -- Finalize --
125 
   --------------
126 
 
127 
   overriding procedure Finalize (Container : in out Holder) is
128 
   begin
129 
      if Container.Busy /= 0 then
130 
         raise Program_Error with "attempt to tamper with elements";
131 
      end if;
132 
 
133 
      Free (Container.Element);
134 
   end Finalize;
135 
 
136 
   --------------
137 
   -- Is_Empty --
138 
   --------------
139 
 
140 
   function Is_Empty (Container : Holder) return Boolean is
141 
   begin
142 
      return Container.Element = null;
143 
   end Is_Empty;
144 
 
145 
   ----------
146 
   -- Move --
147 
   ----------
148 
 
149 
   procedure Move (Target : in out Holder; Source : in out Holder) is
150 
   begin
151 
      if Target.Busy /= 0 then
152 
         raise Program_Error with "attempt to tamper with elements";
153 
      end if;
154 
 
155 
      if Source.Busy /= 0 then
156 
         raise Program_Error with "attempt to tamper with elements";
157 
      end if;
158 
 
159 
      if Target.Element /= Source.Element then
160 
         Free (Target.Element);
161 
         Target.Element := Source.Element;
162 
         Source.Element := null;
163 
      end if;
164 
   end Move;
165 
 
166 
   -------------------
167 
   -- Query_Element --
168 
   -------------------
169 
 
170 
   procedure Query_Element
171 
     (Container : Holder;
172 
      Process   : not null access procedure (Element : Element_Type))
173 
   is
174 
      B : Natural renames Container'Unrestricted_Access.Busy;
175 
 
176 
   begin
177 
      if Container.Element = null then
178 
         raise Constraint_Error with "container is empty";
179 
      end if;
180 
 
181 
      B := B + 1;
182 
 
183 
      begin
184 
         Process (Container.Element.all);
185 
      exception
186 
         when others =>
187 
            B := B - 1;
188 
            raise;
189 
      end;
190 
 
191 
      B := B - 1;
192 
   end Query_Element;
193 
 
194 
   ----------
195 
   -- Read --
196 
   ----------
197 
 
198 
   procedure Read
199 
     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
200 
      Container : out Holder)
201 
   is
202 
   begin
203 
      Clear (Container);
204 
 
205 
      if not Boolean'Input (Stream) then
206 
         Container.Element := new Element_Type'(Element_Type'Input (Stream));
207 
      end if;
208 
   end Read;
209 
 
210 
   ---------------------
211 
   -- Replace_Element --
212 
   ---------------------
213 
 
214 
   procedure Replace_Element
215 
     (Container : in out Holder;
216 
      New_Item  : Element_Type)
217 
   is
218 
   begin
219 
      if Container.Busy /= 0 then
220 
         raise Program_Error with "attempt to tamper with elements";
221 
      end if;
222 
 
223 
      Free (Container.Element);
224 
      Container.Element := new Element_Type'(New_Item);
225 
   end Replace_Element;
226 
 
227 
   ---------------
228 
   -- To_Holder --
229 
   ---------------
230 
 
231 
   function To_Holder (New_Item : Element_Type) return Holder is
232 
   begin
233 
      return (AF.Controlled with new Element_Type'(New_Item), 0);
234 
   end To_Holder;
235 
 
236 
   --------------------
237 
   -- Update_Element --
238 
   --------------------
239 
 
240 
   procedure Update_Element
241 
     (Container : Holder;
242 
      Process   : not null access procedure (Element : in out Element_Type))
243 
   is
244 
      B : Natural renames Container'Unrestricted_Access.Busy;
245 
 
246 
   begin
247 
      if Container.Element = null then
248 
         raise Constraint_Error with "container is empty";
249 
      end if;
250 
 
251 
      B := B + 1;
252 
 
253 
      begin
254 
         Process (Container.Element.all);
255 
      exception
256 
         when others =>
257 
            B := B - 1;
258 
            raise;
259 
      end;
260 
 
261 
      B := B - 1;
262 
   end Update_Element;
263 
 
264 
   -----------
265 
   -- Write --
266 
   -----------
267 
 
268 
   procedure Write
269 
     (Stream    : not null access Ada.Streams.Root_Stream_Type'Class;
270 
      Container : Holder)
271 
   is
272 
   begin
273 
      Boolean'Output (Stream, Container.Element = null);
274 
 
275 
      if Container.Element /= null then
276 
         Element_Type'Output (Stream, Container.Element.all);
277 
      end if;
278 
   end Write;
279 
 
280 
end Ada.Containers.Indefinite_Holders;

powered by: WebSVN 2.1.0

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