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