gcc/ada/i-c.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                         I N T E R F A C E S . C                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 package body Interfaces.C is
  36
  37    -----------------------
  38    -- Is_Nul_Terminated --
  39    -----------------------
  40
  41    --  Case of char_array
  42
  43    function Is_Nul_Terminated (Item : char_array) return Boolean is
  44    begin
  45       for J in Item'Range loop
  46          if Item (J) = nul then
  47             return True;
  48          end if;
  49       end loop;
  50
  51       return False;
  52    end Is_Nul_Terminated;
  53
  54    --  Case of wchar_array
  55
  56    function Is_Nul_Terminated (Item : wchar_array) return Boolean is
  57    begin
  58       for J in Item'Range loop
  59          if Item (J) = wide_nul then
  60             return True;
  61          end if;
  62       end loop;
  63
  64       return False;
  65    end Is_Nul_Terminated;
  66
  67    ------------
  68    -- To_Ada --
  69    ------------
  70
  71    --  Convert char to Character
  72
  73    function To_Ada (Item : char) return Character is
  74    begin
  75       return Character'Val (char'Pos (Item));
  76    end To_Ada;
  77
  78    --  Convert char_array to String (function form)
  79
  80    function To_Ada
  81      (Item     : char_array;
  82       Trim_Nul : Boolean := True)
  83       return     String
  84    is
  85       Count : Natural;
  86       From  : size_t;
  87
  88    begin
  89       if Trim_Nul then
  90          From := Item'First;
  91
  92          loop
  93             if From > Item'Last then
  94                raise Terminator_Error;
  95             elsif Item (From) = nul then
  96                exit;
  97             else
  98                From := From + 1;
  99             end if;
 100          end loop;
 101
 102          Count := Natural (From - Item'First);
 103
 104       else
 105          Count := Item'Length;
 106       end if;
 107
 108       declare
 109          R : String (1 .. Count);
 110
 111       begin
 112          for J in R'Range loop
 113             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 114          end loop;
 115
 116          return R;
 117       end;
 118    end To_Ada;
 119
 120    --  Convert char_array to String (procedure form)
 121
 122    procedure To_Ada
 123      (Item       : char_array;
 124       Target     : out String;
 125       Count      : out Natural;
 126       Trim_Nul   : Boolean := True)
 127    is
 128       From : size_t;
 129       To   : Positive;
 130
 131    begin
 132       if Trim_Nul then
 133          From := Item'First;
 134          loop
 135             if From > Item'Last then
 136                raise Terminator_Error;
 137             elsif Item (From) = nul then
 138                exit;
 139             else
 140                From := From + 1;
 141             end if;
 142          end loop;
 143
 144          Count := Natural (From - Item'First);
 145
 146       else
 147          Count := Item'Length;
 148       end if;
 149
 150       if Count > Target'Length then
 151          raise Constraint_Error;
 152
 153       else
 154          From := Item'First;
 155          To   := Target'First;
 156
 157          for J in 1 .. Count loop
 158             Target (To) := Character (Item (From));
 159             From := From + 1;
 160             To   := To + 1;
 161          end loop;
 162       end if;
 163
 164    end To_Ada;
 165
 166    --  Convert wchar_t to Wide_Character
 167
 168    function To_Ada (Item : wchar_t) return Wide_Character is
 169    begin
 170       return Wide_Character (Item);
 171    end To_Ada;
 172
 173    --  Convert wchar_array to Wide_String (function form)
 174
 175    function To_Ada
 176      (Item     : wchar_array;
 177       Trim_Nul : Boolean := True)
 178       return     Wide_String
 179    is
 180       Count : Natural;
 181       From  : size_t;
 182
 183    begin
 184       if Trim_Nul then
 185          From := Item'First;
 186
 187          loop
 188             if From > Item'Last then
 189                raise Terminator_Error;
 190             elsif Item (From) = wide_nul then
 191                exit;
 192             else
 193                From := From + 1;
 194             end if;
 195          end loop;
 196
 197          Count := Natural (From - Item'First);
 198
 199       else
 200          Count := Item'Length;
 201       end if;
 202
 203       declare
 204          R : Wide_String (1 .. Count);
 205
 206       begin
 207          for J in R'Range loop
 208             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 209          end loop;
 210
 211          return R;
 212       end;
 213    end To_Ada;
 214
 215    --  Convert wchar_array to Wide_String (procedure form)
 216
 217    procedure To_Ada
 218      (Item       : wchar_array;
 219       Target     : out Wide_String;
 220       Count      : out Natural;
 221       Trim_Nul   : Boolean := True)
 222    is
 223       From   : size_t;
 224       To     : Positive;
 225
 226    begin
 227       if Trim_Nul then
 228          From := Item'First;
 229          loop
 230             if From > Item'Last then
 231                raise Terminator_Error;
 232             elsif Item (From) = wide_nul then
 233                exit;
 234             else
 235                From := From + 1;
 236             end if;
 237          end loop;
 238
 239          Count := Natural (From - Item'First);
 240
 241       else
 242          Count := Item'Length;
 243       end if;
 244
 245       if Count > Target'Length then
 246          raise Constraint_Error;
 247
 248       else
 249          From := Item'First;
 250          To   := Target'First;
 251
 252          for J in 1 .. Count loop
 253             Target (To) := To_Ada (Item (From));
 254             From := From + 1;
 255             To   := To + 1;
 256          end loop;
 257       end if;
 258
 259    end To_Ada;
 260
 261    ----------
 262    -- To_C --
 263    ----------
 264
 265    --  Convert Character to char
 266
 267    function To_C (Item : Character) return char is
 268    begin
 269       return char'Val (Character'Pos (Item));
 270    end To_C;
 271
 272    --  Convert String to char_array (function form)
 273
 274    function To_C
 275      (Item       : String;
 276       Append_Nul : Boolean := True)
 277       return       char_array
 278    is
 279    begin
 280       if Append_Nul then
 281          declare
 282             R : char_array (0 .. Item'Length);
 283
 284          begin
 285             for J in Item'Range loop
 286                R (size_t (J - Item'First)) := To_C (Item (J));
 287             end loop;
 288
 289             R (R'Last) := nul;
 290             return R;
 291          end;
 292
 293       else -- Append_Nul is False
 294
 295          --  A nasty case, if the string is null, we must return
 296          --  a null char_array. The lower bound of this array is
 297          --  required to be zero (RM B.3(50)) but that is of course
 298          --  impossible given that size_t is unsigned. This needs
 299          --  ARG resolution, but for now GNAT returns bounds 1 .. 0
 300
 301          if Item'Length = 0 then
 302             declare
 303                R : char_array (1 .. 0);
 304
 305             begin
 306                return R;
 307             end;
 308
 309          else
 310             declare
 311                R : char_array (0 .. Item'Length - 1);
 312
 313             begin
 314                for J in Item'Range loop
 315                   R (size_t (J - Item'First)) := To_C (Item (J));
 316                end loop;
 317
 318                return R;
 319             end;
 320          end if;
 321       end if;
 322    end To_C;
 323
 324    --  Convert String to char_array (procedure form)
 325
 326    procedure To_C
 327      (Item       : String;
 328       Target     : out char_array;
 329       Count      : out size_t;
 330       Append_Nul : Boolean := True)
 331    is
 332       To : size_t;
 333
 334    begin
 335       if Target'Length < Item'Length then
 336          raise Constraint_Error;
 337
 338       else
 339          To := Target'First;
 340          for From in Item'Range loop
 341             Target (To) := char (Item (From));
 342             To := To + 1;
 343          end loop;
 344
 345          if Append_Nul then
 346             if To > Target'Last then
 347                raise Constraint_Error;
 348             else
 349                Target (To) := nul;
 350                Count := Item'Length + 1;
 351             end if;
 352
 353          else
 354             Count := Item'Length;
 355          end if;
 356       end if;
 357    end To_C;
 358
 359    --  Convert Wide_Character to wchar_t
 360
 361    function To_C (Item : Wide_Character) return wchar_t is
 362    begin
 363       return wchar_t (Item);
 364    end To_C;
 365
 366    --  Convert Wide_String to wchar_array (function form)
 367
 368    function To_C
 369      (Item       : Wide_String;
 370       Append_Nul : Boolean := True)
 371       return       wchar_array
 372    is
 373    begin
 374       if Append_Nul then
 375          declare
 376             R : wchar_array (0 .. Item'Length);
 377
 378          begin
 379             for J in Item'Range loop
 380                R (size_t (J - Item'First)) := To_C (Item (J));
 381             end loop;
 382
 383             R (R'Last) := wide_nul;
 384             return R;
 385          end;
 386
 387       else
 388          --  A nasty case, if the string is null, we must return
 389          --  a null char_array. The lower bound of this array is
 390          --  required to be zero (RM B.3(50)) but that is of course
 391          --  impossible given that size_t is unsigned. This needs
 392          --  ARG resolution, but for now GNAT returns bounds 1 .. 0
 393
 394          if Item'Length = 0 then
 395             declare
 396                R : wchar_array (1 .. 0);
 397
 398             begin
 399                return R;
 400             end;
 401
 402          else
 403             declare
 404                R : wchar_array (0 .. Item'Length - 1);
 405
 406             begin
 407                for J in size_t range 0 .. Item'Length - 1 loop
 408                   R (J) := To_C (Item (Integer (J) + Item'First));
 409                end loop;
 410
 411                return R;
 412             end;
 413          end if;
 414       end if;
 415    end To_C;
 416
 417    --  Convert Wide_String to wchar_array (procedure form)
 418
 419    procedure To_C
 420      (Item       : Wide_String;
 421       Target     : out wchar_array;
 422       Count      : out size_t;
 423       Append_Nul : Boolean := True)
 424    is
 425       To : size_t;
 426
 427    begin
 428       if Target'Length < Item'Length then
 429          raise Constraint_Error;
 430
 431       else
 432          To := Target'First;
 433          for From in Item'Range loop
 434             Target (To) := To_C (Item (From));
 435             To := To + 1;
 436          end loop;
 437
 438          if Append_Nul then
 439             if To > Target'Last then
 440                raise Constraint_Error;
 441             else
 442                Target (To) := wide_nul;
 443                Count := Item'Length + 1;
 444             end if;
 445
 446          else
 447             Count := Item'Length;
 448          end if;
 449       end if;
 450    end To_C;
 451
 452 end Interfaces.C;