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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [s-wchwts.adb] - Blame information for rev 414

Go to most recent revision | Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--                       S Y S T E M . W C H _ W T S                        --
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
with System.WCh_Con; use System.WCh_Con;
33
with System.WCh_Cnv; use System.WCh_Cnv;
34
 
35
package body System.WCh_WtS is
36
 
37
   -----------------------
38
   -- Local Subprograms --
39
   -----------------------
40
 
41
   procedure Store_UTF_32_Character
42
     (U  : UTF_32_Code;
43
      S  : out String;
44
      P  : in out Integer;
45
      EM : WC_Encoding_Method);
46
   --  Stores the string representation of the wide or wide wide character
47
   --  whose code is given as U, starting at S (P + 1). P is incremented to
48
   --  point to the last character stored. Raises CE if character cannot be
49
   --  stored using the given encoding method.
50
 
51
   ----------------------------
52
   -- Store_UTF_32_Character --
53
   ----------------------------
54
 
55
   procedure Store_UTF_32_Character
56
     (U  : UTF_32_Code;
57
      S  : out String;
58
      P  : in out Integer;
59
      EM : WC_Encoding_Method)
60
   is
61
      procedure Out_Char (C : Character);
62
      pragma Inline (Out_Char);
63
      --  Procedure to increment P and store C at S (P)
64
 
65
      procedure Store_Chars is new UTF_32_To_Char_Sequence (Out_Char);
66
 
67
      --------------
68
      -- Out_Char --
69
      --------------
70
 
71
      procedure Out_Char (C : Character) is
72
      begin
73
         P := P + 1;
74
         S (P) := C;
75
      end Out_Char;
76
 
77
   begin
78
      Store_Chars (U, EM);
79
   end Store_UTF_32_Character;
80
 
81
   ---------------------------
82
   -- Wide_String_To_String --
83
   ---------------------------
84
 
85
   function Wide_String_To_String
86
     (S  : Wide_String;
87
      EM : WC_Encoding_Method) return String
88
   is
89
      R  : String (S'First .. S'First + 5 * S'Length); -- worst case length!
90
      RP : Natural;
91
 
92
   begin
93
      RP := R'First - 1;
94
      for SP in S'Range loop
95
         Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM);
96
      end loop;
97
 
98
      return R (R'First .. RP);
99
   end Wide_String_To_String;
100
 
101
   --------------------------------
102
   -- Wide_Wide_String_To_String --
103
   --------------------------------
104
 
105
   function Wide_Wide_String_To_String
106
     (S  : Wide_Wide_String;
107
      EM : WC_Encoding_Method) return String
108
   is
109
      R  : String (S'First .. S'First + 7 * S'Length); -- worst case length!
110
      RP : Natural;
111
 
112
   begin
113
      RP := R'First - 1;
114
 
115
      for SP in S'Range loop
116
         Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM);
117
      end loop;
118
 
119
      return R (R'First .. RP);
120
   end Wide_Wide_String_To_String;
121
 
122
end System.WCh_WtS;

powered by: WebSVN 2.1.0

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