OpenCores
URL https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk

Subversion Repositories openrisc_2011-10-31

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [i-cstrin.adb] - Blame information for rev 410

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

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                 I N T E R F A C E S . C . S T R I N G S                  --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, 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
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with System; use System;
33
with System.Storage_Elements; use System.Storage_Elements;
34
 
35
with Ada.Unchecked_Conversion;
36
 
37
package body Interfaces.C.Strings is
38
 
39
   --  Note that the type chars_ptr has a pragma No_Strict_Aliasing in the
40
   --  spec, to prevent any assumptions about aliasing for values of this type,
41
   --  since arbitrary addresses can be converted, and it is quite likely that
42
   --  this type will in fact be used for aliasing values of other types.
43
 
44
   function To_chars_ptr is
45
      new Ada.Unchecked_Conversion (Address, chars_ptr);
46
 
47
   function To_Address is
48
      new Ada.Unchecked_Conversion (chars_ptr, Address);
49
 
50
   -----------------------
51
   -- Local Subprograms --
52
   -----------------------
53
 
54
   function Peek (From : chars_ptr) return char;
55
   pragma Inline (Peek);
56
   --  Given a chars_ptr value, obtain referenced character
57
 
58
   procedure Poke (Value : char; Into : chars_ptr);
59
   pragma Inline (Poke);
60
   --  Given a chars_ptr, modify referenced Character value
61
 
62
   function "+" (Left : chars_ptr; Right : size_t) return chars_ptr;
63
   pragma Inline ("+");
64
   --  Address arithmetic on chars_ptr value
65
 
66
   function Position_Of_Nul (Into : char_array) return size_t;
67
   --  Returns position of the first Nul in Into or Into'Last + 1 if none
68
 
69
   --  We can't use directly System.Memory because the categorization is not
70
   --  compatible, so we directly import here the malloc and free routines.
71
 
72
   function Memory_Alloc (Size : size_t) return chars_ptr;
73
   pragma Import (C, Memory_Alloc, "__gnat_malloc");
74
 
75
   procedure Memory_Free (Address : chars_ptr);
76
   pragma Import (C, Memory_Free, "__gnat_free");
77
 
78
   ---------
79
   -- "+" --
80
   ---------
81
 
82
   function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is
83
   begin
84
      return To_chars_ptr (To_Address (Left) + Storage_Offset (Right));
85
   end "+";
86
 
87
   ----------
88
   -- Free --
89
   ----------
90
 
91
   procedure Free (Item : in out chars_ptr) is
92
   begin
93
      if Item = Null_Ptr then
94
         return;
95
      end if;
96
 
97
      Memory_Free (Item);
98
      Item := Null_Ptr;
99
   end Free;
100
 
101
   --------------------
102
   -- New_Char_Array --
103
   --------------------
104
 
105
   function New_Char_Array (Chars : char_array) return chars_ptr is
106
      Index   : size_t;
107
      Pointer : chars_ptr;
108
 
109
   begin
110
      --  Get index of position of null. If Index > Chars'Last,
111
      --  nul is absent and must be added explicitly.
112
 
113
      Index := Position_Of_Nul (Into => Chars);
114
      Pointer := Memory_Alloc ((Index - Chars'First + 1));
115
 
116
      --  If nul is present, transfer string up to and including nul
117
 
118
      if Index <= Chars'Last then
119
         Update (Item   => Pointer,
120
                 Offset => 0,
121
                 Chars  => Chars (Chars'First .. Index),
122
                 Check  => False);
123
      else
124
         --  If original string has no nul, transfer whole string and add
125
         --  terminator explicitly.
126
 
127
         Update (Item   => Pointer,
128
                 Offset => 0,
129
                 Chars  => Chars,
130
                 Check  => False);
131
         Poke (nul, Into => Pointer + size_t'(Chars'Length));
132
      end if;
133
 
134
      return Pointer;
135
   end New_Char_Array;
136
 
137
   ----------------
138
   -- New_String --
139
   ----------------
140
 
141
   function New_String (Str : String) return chars_ptr is
142
   begin
143
      return New_Char_Array (To_C (Str));
144
   end New_String;
145
 
146
   ----------
147
   -- Peek --
148
   ----------
149
 
150
   function Peek (From : chars_ptr) return char is
151
   begin
152
      return char (From.all);
153
   end Peek;
154
 
155
   ----------
156
   -- Poke --
157
   ----------
158
 
159
   procedure Poke (Value : char; Into : chars_ptr) is
160
   begin
161
      Into.all := Character (Value);
162
   end Poke;
163
 
164
   ---------------------
165
   -- Position_Of_Nul --
166
   ---------------------
167
 
168
   function Position_Of_Nul (Into : char_array) return size_t is
169
   begin
170
      for J in Into'Range loop
171
         if Into (J) = nul then
172
            return J;
173
         end if;
174
      end loop;
175
 
176
      return Into'Last + 1;
177
   end Position_Of_Nul;
178
 
179
   ------------
180
   -- Strlen --
181
   ------------
182
 
183
   function Strlen (Item : chars_ptr) return size_t is
184
      Item_Index : size_t := 0;
185
 
186
   begin
187
      if Item = Null_Ptr then
188
         raise Dereference_Error;
189
      end if;
190
 
191
      loop
192
         if Peek (Item + Item_Index) = nul then
193
            return Item_Index;
194
         end if;
195
 
196
         Item_Index := Item_Index + 1;
197
      end loop;
198
   end Strlen;
199
 
200
   ------------------
201
   -- To_Chars_Ptr --
202
   ------------------
203
 
204
   function To_Chars_Ptr
205
     (Item      : char_array_access;
206
      Nul_Check : Boolean := False) return chars_ptr
207
   is
208
   begin
209
      if Item = null then
210
         return Null_Ptr;
211
      elsif Nul_Check
212
        and then Position_Of_Nul (Into => Item.all) > Item'Last
213
      then
214
         raise Terminator_Error;
215
      else
216
         return To_chars_ptr (Item (Item'First)'Address);
217
      end if;
218
   end To_Chars_Ptr;
219
 
220
   ------------
221
   -- Update --
222
   ------------
223
 
224
   procedure Update
225
     (Item   : chars_ptr;
226
      Offset : size_t;
227
      Chars  : char_array;
228
      Check  : Boolean := True)
229
   is
230
      Index : chars_ptr := Item + Offset;
231
 
232
   begin
233
      if Check and then Offset + Chars'Length  > Strlen (Item) then
234
         raise Update_Error;
235
      end if;
236
 
237
      for J in Chars'Range loop
238
         Poke (Chars (J), Into => Index);
239
         Index := Index + size_t'(1);
240
      end loop;
241
   end Update;
242
 
243
   procedure Update
244
     (Item   : chars_ptr;
245
      Offset : size_t;
246
      Str    : String;
247
      Check  : Boolean := True)
248
   is
249
   begin
250
      --  Note: in RM 95, the Append_Nul => False parameter is omitted. But
251
      --  this has the unintended consequence of truncating the string after
252
      --  an update. As discussed in Ada 2005 AI-242, this was unintended,
253
      --  and should be corrected. Since this is a clear error, it seems
254
      --  appropriate to apply the correction in Ada 95 mode as well.
255
 
256
      Update (Item, Offset, To_C (Str, Append_Nul => False), Check);
257
   end Update;
258
 
259
   -----------
260
   -- Value --
261
   -----------
262
 
263
   function Value (Item : chars_ptr) return char_array is
264
      Result : char_array (0 .. Strlen (Item));
265
 
266
   begin
267
      if Item = Null_Ptr then
268
         raise Dereference_Error;
269
      end if;
270
 
271
      --  Note that the following loop will also copy the terminating Nul
272
 
273
      for J in Result'Range loop
274
         Result (J) := Peek (Item + J);
275
      end loop;
276
 
277
      return Result;
278
   end Value;
279
 
280
   function Value
281
     (Item   : chars_ptr;
282
      Length : size_t) return char_array
283
   is
284
   begin
285
      if Item = Null_Ptr then
286
         raise Dereference_Error;
287
      end if;
288
 
289
      --  ACATS cxb3010 checks that Constraint_Error gets raised when Length
290
      --  is 0. Seems better to check that Length is not null before declaring
291
      --  an array with size_t bounds of 0 .. Length - 1 anyway.
292
 
293
      if Length = 0 then
294
         raise Constraint_Error;
295
      end if;
296
 
297
      declare
298
         Result : char_array (0 .. Length - 1);
299
 
300
      begin
301
         for J in Result'Range loop
302
            Result (J) := Peek (Item + J);
303
 
304
            if Result (J) = nul then
305
               return Result (0 .. J);
306
            end if;
307
         end loop;
308
 
309
         return Result;
310
      end;
311
   end Value;
312
 
313
   function Value (Item : chars_ptr) return String is
314
   begin
315
      return To_Ada (Value (Item));
316
   end Value;
317
 
318
   function Value (Item : chars_ptr; Length : size_t) return String is
319
      Result : char_array (0 .. Length);
320
 
321
   begin
322
      --  As per AI-00177, this is equivalent to:
323
 
324
      --    To_Ada (Value (Item, Length) & nul);
325
 
326
      if Item = Null_Ptr then
327
         raise Dereference_Error;
328
      end if;
329
 
330
      for J in 0 .. Length - 1 loop
331
         Result (J) := Peek (Item + J);
332
 
333
         if Result (J) = nul then
334
            return To_Ada (Result (0 .. J));
335
         end if;
336
      end loop;
337
 
338
      Result (Length) := nul;
339
      return To_Ada (Result);
340
   end Value;
341
 
342
end Interfaces.C.Strings;

powered by: WebSVN 2.1.0

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