gcc/ada/a-suenco.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                   ADA.STRINGS.UTF_ENCODING.CONVERSIONS                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2010, 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 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 package body Ada.Strings.UTF_Encoding.Conversions is
  35    use Interfaces;
  36
  37    --  Version convertion from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE
  38
  39    function Convert
  40      (Item          : UTF_String;
  41       Input_Scheme  : Encoding_Scheme;
  42       Output_Scheme : Encoding_Scheme;
  43       Output_BOM    : Boolean := False) return UTF_String
  44    is
  45    begin
  46       --  Nothing to do if identical schemes
  47
  48       if Input_Scheme = Output_Scheme then
  49          return Item;
  50
  51       --  For remaining cases, one or other of the operands is UTF-16BE/LE
  52       --  encoded, so go through UTF-16 intermediate.
  53
  54       else
  55          return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)),
  56                          Output_Scheme, Output_BOM);
  57       end if;
  58    end Convert;
  59
  60    --  Version converting UTF-8/UTF-16BE/LE to UTF-16
  61
  62    function Convert
  63      (Item          : UTF_String;
  64       Input_Scheme  : Encoding_Scheme;
  65       Output_BOM    : Boolean := False) return UTF_16_Wide_String
  66    is
  67    begin
  68       if Input_Scheme = UTF_8 then
  69          return Convert (Item, Output_BOM);
  70       else
  71          return To_UTF_16 (Item, Input_Scheme, Output_BOM);
  72       end if;
  73    end Convert;
  74
  75    --  Version converting UTF-8 to UTF-16
  76
  77    function Convert
  78      (Item       : UTF_8_String;
  79       Output_BOM : Boolean := False) return UTF_16_Wide_String
  80    is
  81       Result : UTF_16_Wide_String (1 .. Item'Length + 1);
  82       --  Maximum length of result, including possible BOM
  83
  84       Len : Natural := 0;
  85       --  Number of characters stored so far in Result
  86
  87       Iptr : Natural;
  88       --  Next character to process in Item
  89
  90       C : Unsigned_8;
  91       --  Input UTF-8 code
  92
  93       R : Unsigned_16;
  94       --  Output UTF-16 code
  95
  96       procedure Get_Continuation;
  97       --  Reads a continuation byte of the form 10xxxxxx, shifts R left
  98       --  by 6 bits, and or's in the xxxxxx to the low order 6 bits. On
  99       --  return Ptr is incremented. Raises exceptioon if continuation
 100       --  byte does not exist or is invalid.
 101
 102       ----------------------
 103       -- Get_Continuation --
 104       ----------------------
 105
 106       procedure Get_Continuation is
 107       begin
 108          if Iptr > Item'Last then
 109             Raise_Encoding_Error (Iptr - 1);
 110
 111          else
 112             C := To_Unsigned_8 (Item (Iptr));
 113             Iptr := Iptr + 1;
 114
 115             if C < 2#10_000000# or else C > 2#10_111111# then
 116                Raise_Encoding_Error (Iptr - 1);
 117
 118             else
 119                R := Shift_Left (R, 6) or
 120                  Unsigned_16 (C and 2#00_111111#);
 121             end if;
 122          end if;
 123       end Get_Continuation;
 124
 125    --  Start of processing for Convert
 126
 127    begin
 128       --  Output BOM if required
 129
 130       if Output_BOM then
 131          Len := Len + 1;
 132          Result (Len) := BOM_16 (1);
 133       end if;
 134
 135       --  Skip OK BOM
 136
 137       Iptr := Item'First;
 138
 139       if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then
 140          Iptr := Iptr + 3;
 141
 142       --  Error if bad BOM
 143
 144       elsif Item'Length >= 2
 145         and then (Item (Iptr .. Iptr + 1) = BOM_16BE
 146                     or else
 147                   Item (Iptr .. Iptr + 1) = BOM_16LE)
 148       then
 149          Raise_Encoding_Error (Iptr);
 150
 151       --  No BOM present
 152
 153       else
 154          Iptr := Item'First;
 155       end if;
 156
 157       while Iptr <= Item'Last loop
 158          C := To_Unsigned_8 (Item (Iptr));
 159          Iptr := Iptr + 1;
 160
 161          --  Codes in the range 16#00# - 16#7F#
 162          --    UTF-8:  0xxxxxxx
 163          --    UTF-16: 00000000_0xxxxxxx
 164
 165          if C <= 16#7F# then
 166             Len := Len + 1;
 167             Result (Len) := Wide_Character'Val (C);
 168
 169          --  No initial code can be of the form 10xxxxxx. Such codes are used
 170          --  only for continuations.
 171
 172          elsif C <= 2#10_111111# then
 173             Raise_Encoding_Error (Iptr - 1);
 174
 175          --  Codes in the range 16#80# - 16#7FF#
 176          --    UTF-8:  110yyyxx 10xxxxxx
 177          --    UTF-16: 00000yyy_xxxxxxxx
 178
 179          elsif C <= 2#110_11111# then
 180             R := Unsigned_16 (C and 2#000_11111#);
 181             Get_Continuation;
 182             Len := Len + 1;
 183             Result (Len) := Wide_Character'Val (R);
 184
 185          --  Codes in the range 16#800# - 16#FFFF#
 186          --    UTF-8:  1110yyyy 10yyyyxx 10xxxxxx
 187          --    UTF-16: yyyyyyyy_xxxxxxxx
 188
 189          elsif C <= 2#1110_1111# then
 190             R := Unsigned_16 (C and 2#0000_1111#);
 191             Get_Continuation;
 192             Get_Continuation;
 193             Len := Len + 1;
 194             Result (Len) := Wide_Character'Val (R);
 195
 196             --  Make sure that we don't have a result in the forbidden range
 197             --  reserved for UTF-16 surrogate characters.
 198
 199             if R in 16#D800# .. 16#DF00# then
 200                Raise_Encoding_Error (Iptr - 3);
 201             end if;
 202
 203          --  Codes in the range 16#10000# - 16#10FFFF#
 204          --    UTF-8:  11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
 205          --    UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx
 206          --    Note: zzzz in the output is input zzzzz - 1
 207
 208          elsif C <= 2#11110_111# then
 209             R := Unsigned_16 (C and 2#00000_111#);
 210             Get_Continuation;
 211
 212             --  R now has zzzzzyyyy
 213
 214             R := R - 2#0000_1_0000#;
 215
 216             --  R now has zzzzyyyy (zzzz minus one for the output)
 217
 218             Get_Continuation;
 219
 220             --  R now has zzzzyyyyyyyyxx
 221
 222             Len := Len + 1;
 223             Result (Len) :=
 224               Wide_Character'Val
 225                 (2#110110_00_0000_0000# or Shift_Right (R, 4));
 226
 227             R := R and 2#1111#;
 228             Get_Continuation;
 229             Len := Len + 1;
 230             Result (Len) :=
 231               Wide_Character'Val (2#110111_00_0000_0000# or R);
 232
 233          --  Any other code is an error
 234
 235          else
 236             Raise_Encoding_Error (Iptr - 1);
 237          end if;
 238       end loop;
 239
 240       return Result (1 .. Len);
 241    end Convert;
 242
 243    --  Convert from UTF-16 to UTF-8/UTF-16-BE/LE
 244
 245    function Convert
 246      (Item          : UTF_16_Wide_String;
 247       Output_Scheme : Encoding_Scheme;
 248       Output_BOM    : Boolean := False) return UTF_String
 249    is
 250    begin
 251       if Output_Scheme = UTF_8 then
 252          return Convert (Item, Output_BOM);
 253       else
 254          return From_UTF_16 (Item, Output_Scheme, Output_BOM);
 255       end if;
 256    end Convert;
 257
 258    --  Convert from UTF-16 to UTF-8
 259
 260    function Convert
 261      (Item          : UTF_16_Wide_String;
 262       Output_BOM    : Boolean := False) return UTF_8_String
 263    is
 264       Result : UTF_8_String (1 .. 3 * Item'Length + 3);
 265       --  Worst case is 3 output codes for each input code + BOM space
 266
 267       Len : Natural;
 268       --  Number of result codes stored
 269
 270       Iptr : Natural;
 271       --  Pointer to next input character
 272
 273       C1, C2 : Unsigned_16;
 274
 275       zzzzz    : Unsigned_16;
 276       yyyyyyyy : Unsigned_16;
 277       xxxxxxxx : Unsigned_16;
 278       --  Components of double length case
 279
 280    begin
 281       Iptr := Item'First;
 282
 283       --  Skip BOM at start of input
 284
 285       if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then
 286          Iptr := Iptr + 1;
 287       end if;
 288
 289       --  Generate output BOM if required
 290
 291       if Output_BOM then
 292          Result (1 .. 3) := BOM_8;
 293          Len := 3;
 294       else
 295          Len := 0;
 296       end if;
 297
 298       --  Loop through input
 299
 300       while Iptr <= Item'Last loop
 301          C1 := To_Unsigned_16 (Item (Iptr));
 302          Iptr := Iptr + 1;
 303
 304          --  Codes in the range 16#0000# - 16#007F#
 305          --    UTF-16: 000000000xxxxxxx
 306          --    UTF-8:  0xxxxxxx
 307
 308          if C1 <= 16#007F# then
 309             Result (Len + 1) := Character'Val (C1);
 310             Len := Len + 1;
 311
 312          --  Codes in the range 16#80# - 16#7FF#
 313          --    UTF-16: 00000yyyxxxxxxxx
 314          --    UTF-8:  110yyyxx 10xxxxxx
 315
 316          elsif C1 <= 16#07FF# then
 317             Result (Len + 1) :=
 318               Character'Val
 319                 (2#110_000000# or Shift_Right (C1, 6));
 320             Result (Len + 2) :=
 321               Character'Val
 322                 (2#10_000000# or (C1 and 2#00_111111#));
 323             Len := Len + 2;
 324
 325          --  Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF#
 326          --    UTF-16: yyyyyyyyxxxxxxxx
 327          --    UTF-8:  1110yyyy 10yyyyxx 10xxxxxx
 328
 329          elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then
 330             Result (Len + 1) :=
 331               Character'Val
 332                 (2#1110_0000# or Shift_Right (C1, 12));
 333             Result (Len + 2) :=
 334               Character'Val
 335                 (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#));
 336             Result (Len + 3) :=
 337               Character'Val
 338                 (2#10_000000# or (C1 and 2#00_111111#));
 339             Len := Len + 3;
 340
 341          --  Codes in the range 16#10000# - 16#10FFFF#
 342          --    UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx
 343          --    UTF-8:  11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
 344          --    Note: zzzzz in the output is input zzzz + 1
 345
 346          elsif C1 <= 2#110110_11_11111111# then
 347             if Iptr > Item'Last then
 348                Raise_Encoding_Error (Iptr - 1);
 349             else
 350                C2 := To_Unsigned_16 (Item (Iptr));
 351                Iptr := Iptr + 1;
 352             end if;
 353
 354             if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then
 355                Raise_Encoding_Error (Iptr - 1);
 356             end if;
 357
 358             zzzzz    := (Shift_Right (C1, 6) and 2#1111#) + 1;
 359             yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#)
 360                             or
 361                          (Shift_Right (C2, 8) and 2#000000_11#));
 362             xxxxxxxx := C2 and 2#11111111#;
 363
 364             Result (Len + 1) :=
 365               Character'Val
 366                 (2#11110_000# or (Shift_Right (zzzzz, 2)));
 367             Result (Len + 2) :=
 368               Character'Val
 369                 (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4)
 370                               or Shift_Right (yyyyyyyy, 4));
 371             Result (Len + 3) :=
 372               Character'Val
 373                 (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4)
 374                               or Shift_Right (xxxxxxxx, 6));
 375             Result (Len + 4) :=
 376               Character'Val
 377                 (2#10_000000# or (xxxxxxxx and 2#00_111111#));
 378             Len := Len + 4;
 379
 380          --  Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st)
 381
 382          else
 383             Raise_Encoding_Error (Iptr - 2);
 384          end if;
 385       end loop;
 386
 387       return Result (1 .. Len);
 388    end Convert;
 389
 390 end Ada.Strings.UTF_Encoding.Conversions;