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/] [g-encstr.adb] - Blame information for rev 281

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 281 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--                    G N A T . E N C O D E _ S T R I N G                   --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--                       Copyright (C) 2007, AdaCore                        --
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,  51  Franklin  Street,  Fifth  Floor, --
20
-- Boston, MA 02110-1301, 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
with Interfaces; use Interfaces;
35
 
36
with System.WCh_Con; use System.WCh_Con;
37
with System.WCh_Cnv; use System.WCh_Cnv;
38
 
39
package body GNAT.Encode_String is
40
 
41
   -----------------------
42
   -- Local Subprograms --
43
   -----------------------
44
 
45
   procedure Bad;
46
   pragma No_Return (Bad);
47
   --  Raise error for bad character code
48
 
49
   procedure Past_End;
50
   pragma No_Return (Past_End);
51
   --  Raise error for off end of string
52
 
53
   ---------
54
   -- Bad --
55
   ---------
56
 
57
   procedure Bad is
58
   begin
59
      raise Constraint_Error with
60
        "character cannot be encoded with given Encoding_Method";
61
   end Bad;
62
 
63
   ------------------------
64
   -- Encode_Wide_String --
65
   ------------------------
66
 
67
   function Encode_Wide_String (S : Wide_String) return String is
68
      Long : constant Natural := WC_Longest_Sequences (Encoding_Method);
69
      Result : String (1 .. S'Length * Long);
70
      Length : Natural;
71
   begin
72
      Encode_Wide_String (S, Result, Length);
73
      return Result (1 .. Length);
74
   end Encode_Wide_String;
75
 
76
   procedure Encode_Wide_String
77
     (S      : Wide_String;
78
      Result : out String;
79
      Length : out Natural)
80
   is
81
      Ptr : Natural;
82
 
83
   begin
84
      Ptr := S'First;
85
      for J in S'Range loop
86
         Encode_Wide_Character (S (J), Result, Ptr);
87
      end loop;
88
 
89
      Length := Ptr - S'First;
90
   end Encode_Wide_String;
91
 
92
   -----------------------------
93
   -- Encode_Wide_Wide_String --
94
   -----------------------------
95
 
96
   function Encode_Wide_Wide_String (S : Wide_Wide_String) return String is
97
      Long : constant Natural := WC_Longest_Sequences (Encoding_Method);
98
      Result : String (1 .. S'Length * Long);
99
      Length : Natural;
100
   begin
101
      Encode_Wide_Wide_String (S, Result, Length);
102
      return Result (1 .. Length);
103
   end Encode_Wide_Wide_String;
104
 
105
   procedure Encode_Wide_Wide_String
106
     (S      : Wide_Wide_String;
107
      Result : out String;
108
      Length : out Natural)
109
   is
110
      Ptr : Natural;
111
 
112
   begin
113
      Ptr := S'First;
114
      for J in S'Range loop
115
         Encode_Wide_Wide_Character (S (J), Result, Ptr);
116
      end loop;
117
 
118
      Length := Ptr - S'First;
119
   end Encode_Wide_Wide_String;
120
 
121
   ---------------------------
122
   -- Encode_Wide_Character --
123
   ---------------------------
124
 
125
   procedure Encode_Wide_Character
126
     (Char   : Wide_Character;
127
      Result : in out String;
128
      Ptr    : in out Natural)
129
   is
130
   begin
131
      Encode_Wide_Wide_Character
132
        (Wide_Wide_Character'Val (Wide_Character'Pos (Char)), Result, Ptr);
133
 
134
   exception
135
      when Constraint_Error =>
136
         Bad;
137
   end Encode_Wide_Character;
138
 
139
   --------------------------------
140
   -- Encode_Wide_Wide_Character --
141
   --------------------------------
142
 
143
   procedure Encode_Wide_Wide_Character
144
     (Char   : Wide_Wide_Character;
145
      Result : in out String;
146
      Ptr    : in out Natural)
147
   is
148
      U : Unsigned_32;
149
 
150
      procedure Out_Char (C : Character);
151
      pragma Inline (Out_Char);
152
      --  Procedure to store one character for instantiation below
153
 
154
      --------------
155
      -- Out_Char --
156
      --------------
157
 
158
      procedure Out_Char (C : Character) is
159
      begin
160
         if Ptr > Result'Last then
161
            Past_End;
162
         else
163
            Result (Ptr) := C;
164
            Ptr := Ptr + 1;
165
         end if;
166
      end Out_Char;
167
 
168
   --  Start of processing for Encode_Wide_Wide_Character;
169
 
170
   begin
171
      --  Efficient code for UTF-8 case
172
 
173
      if Encoding_Method = WCEM_UTF8 then
174
 
175
         --  Note: for details of UTF8 encoding see RFC 3629
176
 
177
         U := Unsigned_32 (Wide_Wide_Character'Pos (Char));
178
 
179
         --  16#00_0000#-16#00_007F#: 0xxxxxxx
180
 
181
         if U <= 16#00_007F# then
182
            Out_Char (Character'Val (U));
183
 
184
         --  16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx
185
 
186
         elsif U <= 16#00_07FF# then
187
            Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6)));
188
            Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
189
 
190
         --  16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx
191
 
192
         elsif U <= 16#00_FFFF# then
193
            Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12)));
194
            Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
195
                                                          and 2#00111111#)));
196
            Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
197
 
198
         --  16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
199
 
200
         elsif U <= 16#10_FFFF# then
201
            Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18)));
202
            Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
203
                                                          and 2#00111111#)));
204
            Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
205
                                                       and 2#00111111#)));
206
            Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
207
 
208
         --  16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx
209
         --                               10xxxxxx 10xxxxxx
210
 
211
         elsif U <= 16#03FF_FFFF# then
212
            Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24)));
213
            Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18)
214
                                                       and 2#00111111#)));
215
            Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12)
216
                                                       and 2#00111111#)));
217
            Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6)
218
                                                       and 2#00111111#)));
219
            Out_Char (Character'Val (2#10000000# or (U and 2#00111111#)));
220
 
221
         --  All other cases are invalid character codes, not this includes:
222
 
223
         --  16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
224
         --                               10xxxxxx 10xxxxxx 10xxxxxx
225
 
226
         --  since Wide_Wide_Character values cannot exceed 16#3F_FFFF#
227
 
228
         else
229
            Bad;
230
         end if;
231
 
232
      --  All encoding methods other than UTF-8
233
 
234
      else
235
         Non_UTF8 : declare
236
            procedure UTF_32_To_String is
237
              new UTF_32_To_Char_Sequence (Out_Char);
238
            --  Instantiate conversion procedure with above Out_Char routine
239
 
240
         begin
241
            UTF_32_To_String
242
              (UTF_32_Code (Wide_Wide_Character'Pos (Char)), Encoding_Method);
243
 
244
         exception
245
            when Constraint_Error =>
246
               Bad;
247
         end Non_UTF8;
248
      end if;
249
   end Encode_Wide_Wide_Character;
250
 
251
   --------------
252
   -- Past_End --
253
   --------------
254
 
255
   procedure Past_End is
256
   begin
257
      raise Constraint_Error with "past end of string";
258
   end Past_End;
259
 
260
end GNAT.Encode_String;

powered by: WebSVN 2.1.0

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