File : 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-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 -- --
19 -- --
20 -- --
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
32 package 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
826 end Interfaces.C;