OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [i-c.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
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
 
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;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.