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