gcc/ada/i-cstrin.adb

   1 ------------------------------------------------------------------------------
   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 --                            $Revision: 1.21 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2000 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with System; use System;
  37 with System.Address_To_Access_Conversions;
  38
  39 package body Interfaces.C.Strings is
  40
  41    package Char_Access is new Address_To_Access_Conversions (char);
  42
  43    -----------------------
  44    -- Local Subprograms --
  45    -----------------------
  46
  47    function Peek (From : chars_ptr) return char;
  48    pragma Inline (Peek);
  49    --  Given a chars_ptr value, obtain referenced character
  50
  51    procedure Poke (Value : char; Into : chars_ptr);
  52    pragma Inline (Poke);
  53    --  Given a chars_ptr, modify referenced Character value
  54
  55    function "+" (Left : chars_ptr; Right : size_t) return chars_ptr;
  56    pragma Inline ("+");
  57    --  Address arithmetic on chars_ptr value
  58
  59    function Position_Of_Nul (Into : char_array) return size_t;
  60    --  Returns position of the first Nul in Into or Into'Last + 1 if none
  61
  62    function C_Malloc (Size : size_t) return chars_ptr;
  63    pragma Import (C, C_Malloc, "__gnat_malloc");
  64
  65    procedure C_Free (Address : chars_ptr);
  66    pragma Import (C, C_Free, "__gnat_free");
  67
  68    ---------
  69    -- "+" --
  70    ---------
  71
  72    function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is
  73    begin
  74       return Left + chars_ptr (Right);
  75    end "+";
  76
  77    ----------
  78    -- Free --
  79    ----------
  80
  81    procedure Free (Item : in out chars_ptr) is
  82    begin
  83       if Item = Null_Ptr then
  84          return;
  85       end if;
  86
  87       C_Free (Item);
  88       Item := Null_Ptr;
  89    end Free;
  90
  91    --------------------
  92    -- New_Char_Array --
  93    --------------------
  94
  95    function New_Char_Array (Chars : in char_array) return chars_ptr is
  96       Index   : size_t;
  97       Pointer : chars_ptr;
  98
  99    begin
 100       --  Get index of position of null. If Index > Chars'last,
 101       --  nul is absent and must be added explicitly.
 102
 103       Index := Position_Of_Nul (Into => Chars);
 104       Pointer := C_Malloc ((Index - Chars'First + 1));
 105
 106       --  If nul is present, transfer string up to and including it.
 107
 108       if Index <= Chars'Last then
 109          Update (Item   => Pointer,
 110                  Offset => 0,
 111                  Chars  => Chars (Chars'First .. Index),
 112                  Check  => False);
 113       else
 114          --  If original string has no nul, transfer whole string and add
 115          --  terminator explicitly.
 116
 117          Update (Item   => Pointer,
 118                  Offset => 0,
 119                  Chars  => Chars,
 120                  Check  => False);
 121          Poke (nul, into => Pointer + size_t '(Chars'Length));
 122       end if;
 123
 124       return Pointer;
 125    end New_Char_Array;
 126
 127    ----------------
 128    -- New_String --
 129    ----------------
 130
 131    function New_String (Str : in String) return chars_ptr is
 132    begin
 133       return New_Char_Array (To_C (Str));
 134    end New_String;
 135
 136    ----------
 137    -- Peek --
 138    ----------
 139
 140    function Peek (From : chars_ptr) return char is
 141       use Char_Access;
 142    begin
 143       return To_Pointer (Address (To_Address (From))).all;
 144    end Peek;
 145
 146    ----------
 147    -- Poke --
 148    ----------
 149
 150    procedure Poke (Value : char; Into : chars_ptr) is
 151       use Char_Access;
 152    begin
 153       To_Pointer (Address (To_Address (Into))).all := Value;
 154    end Poke;
 155
 156    ---------------------
 157    -- Position_Of_Nul --
 158    ---------------------
 159
 160    function Position_Of_Nul (Into : char_array) return size_t is
 161    begin
 162       for J in Into'Range loop
 163          if Into (J) = nul then
 164             return J;
 165          end if;
 166       end loop;
 167
 168       return Into'Last + 1;
 169    end Position_Of_Nul;
 170
 171    ------------
 172    -- Strlen --
 173    ------------
 174
 175    function Strlen (Item : in chars_ptr) return size_t is
 176       Item_Index : size_t := 0;
 177
 178    begin
 179       if Item = Null_Ptr then
 180          raise Dereference_Error;
 181       end if;
 182
 183       loop
 184          if Peek (Item + Item_Index) = nul then
 185             return Item_Index;
 186          end if;
 187
 188          Item_Index := Item_Index + 1;
 189       end loop;
 190    end Strlen;
 191
 192    ------------------
 193    -- To_Chars_Ptr --
 194    ------------------
 195
 196    function To_Chars_Ptr
 197      (Item      : in char_array_access;
 198       Nul_Check : in Boolean := False)
 199       return      chars_ptr
 200    is
 201    begin
 202       if Item = null then
 203          return Null_Ptr;
 204       elsif Nul_Check
 205         and then Position_Of_Nul (Into => Item.all) > Item'Last
 206       then
 207          raise Terminator_Error;
 208       else
 209          return To_Integer (Item (Item'First)'Address);
 210       end if;
 211    end To_Chars_Ptr;
 212
 213    ------------
 214    -- Update --
 215    ------------
 216
 217    procedure Update
 218      (Item   : in chars_ptr;
 219       Offset : in size_t;
 220       Chars  : in char_array;
 221       Check  : Boolean := True)
 222    is
 223       Index : chars_ptr := Item + Offset;
 224
 225    begin
 226       if Check and then Offset + Chars'Length  > Strlen (Item) then
 227          raise Update_Error;
 228       end if;
 229
 230       for J in Chars'Range loop
 231          Poke (Chars (J), Into => Index);
 232          Index := Index + size_t'(1);
 233       end loop;
 234    end Update;
 235
 236    procedure Update
 237      (Item   : in chars_ptr;
 238       Offset : in size_t;
 239       Str    : in String;
 240       Check  : in Boolean := True)
 241    is
 242    begin
 243       Update (Item, Offset, To_C (Str), Check);
 244    end Update;
 245
 246    -----------
 247    -- Value --
 248    -----------
 249
 250    function Value (Item : in chars_ptr) return char_array is
 251       Result : char_array (0 .. Strlen (Item));
 252
 253    begin
 254       if Item = Null_Ptr then
 255          raise Dereference_Error;
 256       end if;
 257
 258       --  Note that the following loop will also copy the terminating Nul
 259
 260       for J in Result'Range loop
 261          Result (J) := Peek (Item + J);
 262       end loop;
 263
 264       return Result;
 265    end Value;
 266
 267    function Value
 268      (Item   : in chars_ptr;
 269       Length : in size_t)
 270       return   char_array
 271    is
 272    begin
 273       if Item = Null_Ptr then
 274          raise Dereference_Error;
 275       end if;
 276
 277       --  ACATS cxb3010 checks that Constraint_Error gets raised when Length
 278       --  is 0. Seems better to check that Length is not null before declaring
 279       --  an array with size_t bounds of 0 .. Length - 1 anyway.
 280
 281       if Length = 0 then
 282          raise Constraint_Error;
 283       end if;
 284
 285       declare
 286          Result : char_array (0 .. Length - 1);
 287
 288       begin
 289          for J in Result'Range loop
 290             Result (J) := Peek (Item + J);
 291
 292             if Result (J) = nul then
 293                return Result (0 .. J);
 294             end if;
 295          end loop;
 296
 297          return Result;
 298       end;
 299    end Value;
 300
 301    function Value (Item : in chars_ptr) return String is
 302    begin
 303       return To_Ada (Value (Item));
 304    end Value;
 305
 306    --  As per AI-00177, this is equivalent to
 307    --          To_Ada (Value (Item, Length) & nul);
 308
 309    function Value (Item : in chars_ptr; Length : in size_t) return String is
 310       Result : char_array (0 .. Length);
 311
 312    begin
 313       if Item = Null_Ptr then
 314          raise Dereference_Error;
 315       end if;
 316
 317       for J in 0 .. Length - 1 loop
 318          Result (J) := Peek (Item + J);
 319
 320          if Result (J) = nul then
 321             return To_Ada (Result (0 .. J));
 322          end if;
 323       end loop;
 324
 325       Result (Length) := nul;
 326       return To_Ada (Result);
 327    end Value;
 328
 329 end Interfaces.C.Strings;