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-2005 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    --  Case of char16_array
  67
  68    function Is_Nul_Terminated (Item : char16_array) return Boolean is
  69    begin
  70       for J in Item'Range loop
  71          if Item (J) = char16_nul then
  72             return True;
  73          end if;
  74       end loop;
  75
  76       return False;
  77    end Is_Nul_Terminated;
  78
  79    --  Case of char32_array
  80
  81    function Is_Nul_Terminated (Item : char32_array) return Boolean is
  82    begin
  83       for J in Item'Range loop
  84          if Item (J) = char32_nul then
  85             return True;
  86          end if;
  87       end loop;
  88
  89       return False;
  90    end Is_Nul_Terminated;
  91
  92    ------------
  93    -- To_Ada --
  94    ------------
  95
  96    --  Convert char to Character
  97
  98    function To_Ada (Item : char) return Character is
  99    begin
 100       return Character'Val (char'Pos (Item));
 101    end To_Ada;
 102
 103    --  Convert char_array to String (function form)
 104
 105    function To_Ada
 106      (Item     : char_array;
 107       Trim_Nul : Boolean := True) return String
 108    is
 109       Count : Natural;
 110       From  : size_t;
 111
 112    begin
 113       if Trim_Nul then
 114          From := Item'First;
 115
 116          loop
 117             if From > Item'Last then
 118                raise Terminator_Error;
 119             elsif Item (From) = nul then
 120                exit;
 121             else
 122                From := From + 1;
 123             end if;
 124          end loop;
 125
 126          Count := Natural (From - Item'First);
 127
 128       else
 129          Count := Item'Length;
 130       end if;
 131
 132       declare
 133          R : String (1 .. Count);
 134
 135       begin
 136          for J in R'Range loop
 137             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 138          end loop;
 139
 140          return R;
 141       end;
 142    end To_Ada;
 143
 144    --  Convert char_array to String (procedure form)
 145
 146    procedure To_Ada
 147      (Item     : char_array;
 148       Target   : out String;
 149       Count    : out Natural;
 150       Trim_Nul : Boolean := True)
 151    is
 152       From : size_t;
 153       To   : Positive;
 154
 155    begin
 156       if Trim_Nul then
 157          From := Item'First;
 158          loop
 159             if From > Item'Last then
 160                raise Terminator_Error;
 161             elsif Item (From) = nul then
 162                exit;
 163             else
 164                From := From + 1;
 165             end if;
 166          end loop;
 167
 168          Count := Natural (From - Item'First);
 169
 170       else
 171          Count := Item'Length;
 172       end if;
 173
 174       if Count > Target'Length then
 175          raise Constraint_Error;
 176
 177       else
 178          From := Item'First;
 179          To   := Target'First;
 180
 181          for J in 1 .. Count loop
 182             Target (To) := Character (Item (From));
 183             From := From + 1;
 184             To   := To + 1;
 185          end loop;
 186       end if;
 187
 188    end To_Ada;
 189
 190    --  Convert wchar_t to Wide_Character
 191
 192    function To_Ada (Item : wchar_t) return Wide_Character is
 193    begin
 194       return Wide_Character (Item);
 195    end To_Ada;
 196
 197    --  Convert wchar_array to Wide_String (function form)
 198
 199    function To_Ada
 200      (Item     : wchar_array;
 201       Trim_Nul : Boolean := True) return Wide_String
 202    is
 203       Count : Natural;
 204       From  : size_t;
 205
 206    begin
 207       if Trim_Nul then
 208          From := Item'First;
 209
 210          loop
 211             if From > Item'Last then
 212                raise Terminator_Error;
 213             elsif Item (From) = wide_nul then
 214                exit;
 215             else
 216                From := From + 1;
 217             end if;
 218          end loop;
 219
 220          Count := Natural (From - Item'First);
 221
 222       else
 223          Count := Item'Length;
 224       end if;
 225
 226       declare
 227          R : Wide_String (1 .. Count);
 228
 229       begin
 230          for J in R'Range loop
 231             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 232          end loop;
 233
 234          return R;
 235       end;
 236    end To_Ada;
 237
 238    --  Convert wchar_array to Wide_String (procedure form)
 239
 240    procedure To_Ada
 241      (Item     : wchar_array;
 242       Target   : out Wide_String;
 243       Count    : out Natural;
 244       Trim_Nul : Boolean := True)
 245    is
 246       From : size_t;
 247       To   : Positive;
 248
 249    begin
 250       if Trim_Nul then
 251          From := Item'First;
 252          loop
 253             if From > Item'Last then
 254                raise Terminator_Error;
 255             elsif Item (From) = wide_nul then
 256                exit;
 257             else
 258                From := From + 1;
 259             end if;
 260          end loop;
 261
 262          Count := Natural (From - Item'First);
 263
 264       else
 265          Count := Item'Length;
 266       end if;
 267
 268       if Count > Target'Length then
 269          raise Constraint_Error;
 270
 271       else
 272          From := Item'First;
 273          To   := Target'First;
 274
 275          for J in 1 .. Count loop
 276             Target (To) := To_Ada (Item (From));
 277             From := From + 1;
 278             To   := To + 1;
 279          end loop;
 280       end if;
 281    end To_Ada;
 282
 283    --  Convert char16_t to Wide_Character
 284
 285    function To_Ada (Item : char16_t) return Wide_Character is
 286    begin
 287       return Wide_Character'Val (char16_t'Pos (Item));
 288    end To_Ada;
 289
 290    --  Convert char16_array to Wide_String (function form)
 291
 292    function To_Ada
 293      (Item     : char16_array;
 294       Trim_Nul : Boolean := True) return Wide_String
 295    is
 296       Count : Natural;
 297       From  : size_t;
 298
 299    begin
 300       if Trim_Nul then
 301          From := Item'First;
 302
 303          loop
 304             if From > Item'Last then
 305                raise Terminator_Error;
 306             elsif Item (From) = char16_t'Val (0) then
 307                exit;
 308             else
 309                From := From + 1;
 310             end if;
 311          end loop;
 312
 313          Count := Natural (From - Item'First);
 314
 315       else
 316          Count := Item'Length;
 317       end if;
 318
 319       declare
 320          R : Wide_String (1 .. Count);
 321
 322       begin
 323          for J in R'Range loop
 324             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 325          end loop;
 326
 327          return R;
 328       end;
 329    end To_Ada;
 330
 331    --  Convert char16_array to Wide_String (procedure form)
 332
 333    procedure To_Ada
 334      (Item     : char16_array;
 335       Target   : out Wide_String;
 336       Count    : out Natural;
 337       Trim_Nul : Boolean := True)
 338    is
 339       From : size_t;
 340       To   : Positive;
 341
 342    begin
 343       if Trim_Nul then
 344          From := Item'First;
 345          loop
 346             if From > Item'Last then
 347                raise Terminator_Error;
 348             elsif Item (From) = char16_t'Val (0) then
 349                exit;
 350             else
 351                From := From + 1;
 352             end if;
 353          end loop;
 354
 355          Count := Natural (From - Item'First);
 356
 357       else
 358          Count := Item'Length;
 359       end if;
 360
 361       if Count > Target'Length then
 362          raise Constraint_Error;
 363
 364       else
 365          From := Item'First;
 366          To   := Target'First;
 367
 368          for J in 1 .. Count loop
 369             Target (To) := To_Ada (Item (From));
 370             From := From + 1;
 371             To   := To + 1;
 372          end loop;
 373       end if;
 374    end To_Ada;
 375
 376    --  Convert char32_t to Wide_Wide_Character
 377
 378    function To_Ada (Item : char32_t) return Wide_Wide_Character is
 379    begin
 380       return Wide_Wide_Character'Val (char32_t'Pos (Item));
 381    end To_Ada;
 382
 383    --  Convert char32_array to Wide_Wide_String (function form)
 384
 385    function To_Ada
 386      (Item     : char32_array;
 387       Trim_Nul : Boolean := True) return Wide_Wide_String
 388    is
 389       Count : Natural;
 390       From  : size_t;
 391
 392    begin
 393       if Trim_Nul then
 394          From := Item'First;
 395
 396          loop
 397             if From > Item'Last then
 398                raise Terminator_Error;
 399             elsif Item (From) = char32_t'Val (0) then
 400                exit;
 401             else
 402                From := From + 1;
 403             end if;
 404          end loop;
 405
 406          Count := Natural (From - Item'First);
 407
 408       else
 409          Count := Item'Length;
 410       end if;
 411
 412       declare
 413          R : Wide_Wide_String (1 .. Count);
 414
 415       begin
 416          for J in R'Range loop
 417             R (J) := To_Ada (Item (size_t (J) + (Item'First - 1)));
 418          end loop;
 419
 420          return R;
 421       end;
 422    end To_Ada;
 423
 424    --  Convert char32_array to Wide_Wide_String (procedure form)
 425
 426    procedure To_Ada
 427      (Item     : char32_array;
 428       Target   : out Wide_Wide_String;
 429       Count    : out Natural;
 430       Trim_Nul : Boolean := True)
 431    is
 432       From : size_t;
 433       To   : Positive;
 434
 435    begin
 436       if Trim_Nul then
 437          From := Item'First;
 438          loop
 439             if From > Item'Last then
 440                raise Terminator_Error;
 441             elsif Item (From) = char32_t'Val (0) then
 442                exit;
 443             else
 444                From := From + 1;
 445             end if;
 446          end loop;
 447
 448          Count := Natural (From - Item'First);
 449
 450       else
 451          Count := Item'Length;
 452       end if;
 453
 454       if Count > Target'Length then
 455          raise Constraint_Error;
 456
 457       else
 458          From := Item'First;
 459          To   := Target'First;
 460
 461          for J in 1 .. Count loop
 462             Target (To) := To_Ada (Item (From));
 463             From := From + 1;
 464             To   := To + 1;
 465          end loop;
 466       end if;
 467    end To_Ada;
 468
 469    ----------
 470    -- To_C --
 471    ----------
 472
 473    --  Convert Character to char
 474
 475    function To_C (Item : Character) return char is
 476    begin
 477       return char'Val (Character'Pos (Item));
 478    end To_C;
 479
 480    --  Convert String to char_array (function form)
 481
 482    function To_C
 483      (Item       : String;
 484       Append_Nul : Boolean := True) return char_array
 485    is
 486    begin
 487       if Append_Nul then
 488          declare
 489             R : char_array (0 .. Item'Length);
 490
 491          begin
 492             for J in Item'Range loop
 493                R (size_t (J - Item'First)) := To_C (Item (J));
 494             end loop;
 495
 496             R (R'Last) := nul;
 497             return R;
 498          end;
 499
 500       --  Append_Nul False
 501
 502       else
 503          --  A nasty case, if the string is null, we must return a null
 504          --  char_array. The lower bound of this array is required to be zero
 505          --  (RM B.3(50)) but that is of course impossible given that size_t
 506          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 507          --  Constraint_Error.
 508
 509          if Item'Length = 0 then
 510             raise Constraint_Error;
 511
 512          --  Normal case
 513
 514          else
 515             declare
 516                R : char_array (0 .. Item'Length - 1);
 517
 518             begin
 519                for J in Item'Range loop
 520                   R (size_t (J - Item'First)) := To_C (Item (J));
 521                end loop;
 522
 523                return R;
 524             end;
 525          end if;
 526       end if;
 527    end To_C;
 528
 529    --  Convert String to char_array (procedure form)
 530
 531    procedure To_C
 532      (Item       : String;
 533       Target     : out char_array;
 534       Count      : out size_t;
 535       Append_Nul : Boolean := True)
 536    is
 537       To : size_t;
 538
 539    begin
 540       if Target'Length < Item'Length then
 541          raise Constraint_Error;
 542
 543       else
 544          To := Target'First;
 545          for From in Item'Range loop
 546             Target (To) := char (Item (From));
 547             To := To + 1;
 548          end loop;
 549
 550          if Append_Nul then
 551             if To > Target'Last then
 552                raise Constraint_Error;
 553             else
 554                Target (To) := nul;
 555                Count := Item'Length + 1;
 556             end if;
 557
 558          else
 559             Count := Item'Length;
 560          end if;
 561       end if;
 562    end To_C;
 563
 564    --  Convert Wide_Character to wchar_t
 565
 566    function To_C (Item : Wide_Character) return wchar_t is
 567    begin
 568       return wchar_t (Item);
 569    end To_C;
 570
 571    --  Convert Wide_String to wchar_array (function form)
 572
 573    function To_C
 574      (Item       : Wide_String;
 575       Append_Nul : Boolean := True) return wchar_array
 576    is
 577    begin
 578       if Append_Nul then
 579          declare
 580             R : wchar_array (0 .. Item'Length);
 581
 582          begin
 583             for J in Item'Range loop
 584                R (size_t (J - Item'First)) := To_C (Item (J));
 585             end loop;
 586
 587             R (R'Last) := wide_nul;
 588             return R;
 589          end;
 590
 591       else
 592          --  A nasty case, if the string is null, we must return a null
 593          --  wchar_array. The lower bound of this array is required to be zero
 594          --  (RM B.3(50)) but that is of course impossible given that size_t
 595          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 596          --  Constraint_Error.
 597
 598          if Item'Length = 0 then
 599             raise Constraint_Error;
 600
 601          else
 602             declare
 603                R : wchar_array (0 .. Item'Length - 1);
 604
 605             begin
 606                for J in size_t range 0 .. Item'Length - 1 loop
 607                   R (J) := To_C (Item (Integer (J) + Item'First));
 608                end loop;
 609
 610                return R;
 611             end;
 612          end if;
 613       end if;
 614    end To_C;
 615
 616    --  Convert Wide_String to wchar_array (procedure form)
 617
 618    procedure To_C
 619      (Item       : Wide_String;
 620       Target     : out wchar_array;
 621       Count      : out size_t;
 622       Append_Nul : Boolean := True)
 623    is
 624       To : size_t;
 625
 626    begin
 627       if Target'Length < Item'Length then
 628          raise Constraint_Error;
 629
 630       else
 631          To := Target'First;
 632          for From in Item'Range loop
 633             Target (To) := To_C (Item (From));
 634             To := To + 1;
 635          end loop;
 636
 637          if Append_Nul then
 638             if To > Target'Last then
 639                raise Constraint_Error;
 640             else
 641                Target (To) := wide_nul;
 642                Count := Item'Length + 1;
 643             end if;
 644
 645          else
 646             Count := Item'Length;
 647          end if;
 648       end if;
 649    end To_C;
 650
 651    --  Convert Wide_Character to char16_t
 652
 653    function To_C (Item : Wide_Character) return char16_t is
 654    begin
 655       return char16_t'Val (Wide_Character'Pos (Item));
 656    end To_C;
 657
 658    --  Convert Wide_String to char16_array (function form)
 659
 660    function To_C
 661      (Item       : Wide_String;
 662       Append_Nul : Boolean := True) return char16_array
 663    is
 664    begin
 665       if Append_Nul then
 666          declare
 667             R : char16_array (0 .. Item'Length);
 668
 669          begin
 670             for J in Item'Range loop
 671                R (size_t (J - Item'First)) := To_C (Item (J));
 672             end loop;
 673
 674             R (R'Last) := char16_t'Val (0);
 675             return R;
 676          end;
 677
 678       else
 679          --  A nasty case, if the string is null, we must return a null
 680          --  char16_array. The lower bound of this array is required to be zero
 681          --  (RM B.3(50)) but that is of course impossible given that size_t
 682          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 683          --  Constraint_Error.
 684
 685          if Item'Length = 0 then
 686             raise Constraint_Error;
 687
 688          else
 689             declare
 690                R : char16_array (0 .. Item'Length - 1);
 691
 692             begin
 693                for J in size_t range 0 .. Item'Length - 1 loop
 694                   R (J) := To_C (Item (Integer (J) + Item'First));
 695                end loop;
 696
 697                return R;
 698             end;
 699          end if;
 700       end if;
 701    end To_C;
 702
 703    --  Convert Wide_String to char16_array (procedure form)
 704
 705    procedure To_C
 706      (Item       : Wide_String;
 707       Target     : out char16_array;
 708       Count      : out size_t;
 709       Append_Nul : Boolean := True)
 710    is
 711       To : size_t;
 712
 713    begin
 714       if Target'Length < Item'Length then
 715          raise Constraint_Error;
 716
 717       else
 718          To := Target'First;
 719          for From in Item'Range loop
 720             Target (To) := To_C (Item (From));
 721             To := To + 1;
 722          end loop;
 723
 724          if Append_Nul then
 725             if To > Target'Last then
 726                raise Constraint_Error;
 727             else
 728                Target (To) := char16_t'Val (0);
 729                Count := Item'Length + 1;
 730             end if;
 731
 732          else
 733             Count := Item'Length;
 734          end if;
 735       end if;
 736    end To_C;
 737
 738    --  Convert Wide_Character to char32_t
 739
 740    function To_C (Item : Wide_Wide_Character) return char32_t is
 741    begin
 742       return char32_t'Val (Wide_Wide_Character'Pos (Item));
 743    end To_C;
 744
 745    --  Convert Wide_Wide_String to char32_array (function form)
 746
 747    function To_C
 748      (Item       : Wide_Wide_String;
 749       Append_Nul : Boolean := True) return char32_array
 750    is
 751    begin
 752       if Append_Nul then
 753          declare
 754             R : char32_array (0 .. Item'Length);
 755
 756          begin
 757             for J in Item'Range loop
 758                R (size_t (J - Item'First)) := To_C (Item (J));
 759             end loop;
 760
 761             R (R'Last) := char32_t'Val (0);
 762             return R;
 763          end;
 764
 765       else
 766          --  A nasty case, if the string is null, we must return a null
 767          --  char32_array. The lower bound of this array is required to be zero
 768          --  (RM B.3(50)) but that is of course impossible given that size_t
 769          --  is unsigned. According to Ada 2005 AI-258, the result is to raise
 770          --  Constraint_Error.
 771
 772          if Item'Length = 0 then
 773             raise Constraint_Error;
 774
 775          else
 776             declare
 777                R : char32_array (0 .. Item'Length - 1);
 778
 779             begin
 780                for J in size_t range 0 .. Item'Length - 1 loop
 781                   R (J) := To_C (Item (Integer (J) + Item'First));
 782                end loop;
 783
 784                return R;
 785             end;
 786          end if;
 787       end if;
 788    end To_C;
 789
 790    --  Convert Wide_Wide_String to char32_array (procedure form)
 791
 792    procedure To_C
 793      (Item       : Wide_Wide_String;
 794       Target     : out char32_array;
 795       Count      : out size_t;
 796       Append_Nul : Boolean := True)
 797    is
 798       To : size_t;
 799
 800    begin
 801       if Target'Length < Item'Length then
 802          raise Constraint_Error;
 803
 804       else
 805          To := Target'First;
 806          for From in Item'Range loop
 807             Target (To) := To_C (Item (From));
 808             To := To + 1;
 809          end loop;
 810
 811          if Append_Nul then
 812             if To > Target'Last then
 813                raise Constraint_Error;
 814             else
 815                Target (To) := char32_t'Val (0);
 816                Count := Item'Length + 1;
 817             end if;
 818
 819          else
 820             Count := Item'Length;
 821          end if;
 822       end if;
 823    end To_C;
 824
 825 end Interfaces.C;