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