diff options
| -rw-r--r-- | gcc/ada/Makefile.rtl | 3 | ||||
| -rw-r--r-- | gcc/ada/a-stuten.adb | 1069 | ||||
| -rw-r--r-- | gcc/ada/a-stuten.ads | 191 | ||||
| -rw-r--r-- | gcc/ada/a-stwiun-shared.adb | 2106 | ||||
| -rw-r--r-- | gcc/ada/a-stwiun-shared.ads | 483 | ||||
| -rw-r--r-- | gcc/ada/a-stzunb-shared.adb | 2120 | ||||
| -rw-r--r-- | gcc/ada/a-stzunb-shared.ads | 501 | ||||
| -rwxr-xr-x | gcc/ada/a-suenco.adb | 390 | ||||
| -rwxr-xr-x | gcc/ada/a-suenco.ads | 61 | ||||
| -rwxr-xr-x | gcc/ada/a-suewen.adb | 371 | ||||
| -rwxr-xr-x | gcc/ada/a-suewen.ads | 67 | ||||
| -rwxr-xr-x | gcc/ada/a-suezen.adb | 431 | ||||
| -rwxr-xr-x | gcc/ada/a-suezen.ads | 64 | ||||
| -rw-r--r-- | gcc/ada/a-swunau-shared.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/a-swuwti-shared.adb | 136 | ||||
| -rw-r--r-- | gcc/ada/a-szunau-shared.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/a-szuzti-shared.adb | 137 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/Makefile.in | 3 | ||||
| -rw-r--r-- | gcc/ada/impunit.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/sem.adb | 114 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 7 |
22 files changed, 7319 insertions, 1094 deletions
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl index 236ddde0967..6e7d4eba44a 100644 --- a/gcc/ada/Makefile.rtl +++ b/gcc/ada/Makefile.rtl @@ -226,6 +226,9 @@ GNATRTL_NONTASKING_OBJS= \ a-stzsea$(objext) \ a-stzsup$(objext) \ a-stzunb$(objext) \ + a-suenco$(objext) \ + a-suewen$(objext) \ + a-suezen$(objext) \ a-suteio$(objext) \ a-swbwha$(objext) \ a-swfwha$(objext) \ diff --git a/gcc/ada/a-stuten.adb b/gcc/ada/a-stuten.adb index 7571bda0833..fc669b56ee4 100644 --- a/gcc/ada/a-stuten.adb +++ b/gcc/ada/a-stuten.adb @@ -27,1006 +27,183 @@ -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- -------------------------------------------------------------------------------- -with Interfaces; use Interfaces; -with Unchecked_Conversion; +------------------------------------------------------------------------------ package body Ada.Strings.UTF_Encoding is + use Interfaces; - function To_Unsigned_8 is new - Unchecked_Conversion (Character, Unsigned_8); - - function To_Unsigned_16 is new - Unchecked_Conversion (Wide_Character, Unsigned_16); - - function To_Unsigned_32 is new - Unchecked_Conversion (Wide_Wide_Character, Unsigned_32); - - -- Local subprograms - - procedure Raise_Encoding_Error; - -- Called if an invalid input encoding sequence is found by Decode - - function Decode_UTF_8 (Item : String) return Wide_String; - -- Equivalent to Decode (Item, UTF_8), but smaller and faster - - function Decode_UTF_8 (Item : String) return Wide_Wide_String; - -- Equivalent to Decode (Item, UTF_8), but smaller and faster - - function Encode_UTF_8 (Item : Wide_String) return String; - -- Equivalent to Encode (Item, UTF_8) but smaller and faster - - function Encode_UTF_8 (Item : Wide_Wide_String) return String; - -- Equivalent to Encode (Item, UTF_8) but smaller and faster - - function Decode_UTF_16 (Item : Wide_String) return Wide_String; - -- Equivalent to Decode (Item, UTF_16) - - function Decode_UTF_16 (Item : Wide_String) return Wide_Wide_String; - -- Equivalent to Decode (Item, UTF_16) - - function Encode_UTF_16 (Item : Wide_String) return Wide_String; - -- Equivalent to Encode (Item, UTF_16) - - function Encode_UTF_16 (Item : Wide_Wide_String) return Wide_String; - -- Equivalent to Encode (Item, UTF_16) - - ------------ - -- Decode -- - ------------ - - -- String input with Wide_String output (short encodings) - - function Decode - (Item : String; - Scheme : Short_Encoding := UTF_8) return Wide_String - is - begin - -- UTF-8 encoding case - - if Scheme = UTF_8 then - return Decode_UTF_8 (Item); - - -- Case of UTF_16LE or UTF_16BE - - else - UTF16_XE : declare - Input_UTF16 : Wide_String (1 .. Item'Length / 2); - -- UTF_16 input string - - Iptr : Natural; - -- Pointer to next location to store in Input_UTF16 - - Ptr : Natural; - -- Input string pointer - - H, L : Natural range 0 .. 1; - -- Offset for high and low order bytes - - begin - -- In both cases, the input string must be even in length, since - -- we have two input characters for each input code in UTF_16. - - if Item'Length mod 2 /= 0 then - Raise_Encoding_Error; - end if; - - -- We first assemble the UTF_16 string from the input. Set offsets - -- for the two bytes. For UTF_16LE we have low order/high order. - -- For UTF_16BE we have high order/low order. - - if Scheme = UTF_16LE then - L := 0; - H := 1; - else - L := 1; - H := 0; - end if; - - -- Loop to convert input to UTF_16 form - - Iptr := 1; - Ptr := Item'First; - while Ptr < Item'Last loop - Input_UTF16 (Iptr) := - Wide_Character'Val - (Unsigned_16 (To_Unsigned_8 (Item (Ptr + L))) - or - Shift_Left - (Unsigned_16 (To_Unsigned_8 (Item (Ptr + H))), 8)); - Iptr := Iptr + 1; - Ptr := Ptr + 2; - end loop; - - -- Result is obtained by converting this UTF_16 input. Note that - -- we rely on this nested call to Decode to skip any BOM present. - - return Decode (Input_UTF16); - end UTF16_XE; - end if; - end Decode; - - -- String input with Wide_Wide_String output (short encodings) + -------------- + -- Encoding -- + -------------- - function Decode - (Item : String; - Scheme : Short_Encoding := UTF_8) return Wide_Wide_String + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme is begin - -- UTF-8 encoding case - - if Scheme = UTF_8 then - return Decode_UTF_8 (Item); - - -- Case of UTF_16LE or UTF_16BE - - else - UTF16_XE : declare - Input_UTF16 : Wide_String (1 .. Item'Length / 2); - -- UTF_16 input string - - Iptr : Natural; - -- Pointer to next location to store in Input_UTF16 - - Ptr : Natural; - -- Input string pointer - - H, L : Integer range 0 .. 1; - -- Offset for high and low order bytes - - begin - -- In both cases, the input string must be even in length, since - -- we have two input characters for each input code in UTF_16. - - if Item'Length mod 2 /= 0 then - Raise_Encoding_Error; - end if; - - -- We first assemble the UTF_16 string from the input. Set offsets - -- for the two bytes. For UTF_16LE we have low order/high order. - -- For UTF_16BE we have high order/low order. - - if Scheme = UTF_16LE then - L := 0; - H := 1; - else - L := 1; - H := 0; - end if; - - -- Loop to convert input to UTF_16 form - - Ptr := Item'First; - Iptr := 1; - while Ptr < Item'Last loop - Input_UTF16 (Iptr) := - Wide_Character'Val - (Unsigned_16 (To_Unsigned_8 (Item (Ptr + L))) - or - Shift_Left - (Unsigned_16 (To_Unsigned_8 (Item (Ptr + H))), 8)); - Iptr := Iptr + 1; - Ptr := Ptr + 2; - end loop; + if Item'Length >= 2 then + if Item (Item'First .. Item'First + 1) = BOM_16BE then + return UTF_16BE; - -- Result is obtained by converting this UTF_16 input. Note that - -- we rely on this nested call to Decode to skip any BOM present. + elsif Item (Item'First .. Item'First + 1) = BOM_16LE then + return UTF_16LE; - return Decode_UTF_16 (Input_UTF16); - end UTF16_XE; + elsif Item'Length >= 3 + and then Item (Item'First .. Item'First + 2) = BOM_8 + then + return UTF_8; + end if; end if; - end Decode; - -- Wide_String input with Wide_Wide_String output (long encodings) - - function Decode - (Item : Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_String - is - pragma Unreferenced (Scheme); - begin - return Decode_UTF_16 (Item); - end Decode; + return Default; + end Encoding; - -- Wide_String input with Wide_Wide_String output (long encodings) + ----------------- + -- From_UTF_16 -- + ----------------- - function Decode - (Item : Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_Wide_String + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String is - pragma Unreferenced (Scheme); - begin - return Decode_UTF_16 (Item); - end Decode; - - ------------------- - -- Decode_UTF_16 -- - ------------------- - - -- Version returning Wide_String result - - function Decode_UTF_16 (Item : Wide_String) return Wide_String is - Result : Wide_String (1 .. Item'Length); - -- Result is same length as input (possibly minus 1 if BOM present) - - Len : Natural := 0; - -- Length of result - - Cod : Unsigned_16; - J : Positive; + BSpace : constant Natural := 2 * Boolean'Pos (Output_BOM); + Result : UTF_String (1 .. 2 * Item'Length + BSpace); + Len : Natural; + C : Unsigned_16; + Iptr : Natural; begin - -- Skip UTF-16 BOM at start - - J := Item'First; - - if J <= Item'Last and then Item (J) = BOM_16 (1) then - J := J + 1; + if Output_BOM then + Result (1 .. 2) := + (if Output_Scheme = UTF_16BE then BOM_16BE else BOM_16LE); + Len := 2; + else + Len := 0; end if; - -- Loop through input characters - - while J <= Item'Last loop - Cod := To_Unsigned_16 (Item (J)); - - -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFF# - -- represent their own value. - - if Cod <= 16#D7FF# or else Cod >= 16#E000# then - Len := Len + 1; - Result (Len) := Wide_Character'Val (Cod); - - -- Codes in the range 16#D800#..16#DBFF# represent the first of the - -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". - -- Such codes are out of range for 16-bit output. + -- Skip input BOM - -- The remaining case of input in the range 16#DC00#..16#DFFF# must - -- never occur, since it means we have a second surrogate character - -- with no corresponding first surrogate. + Iptr := Item'First; - -- Thus all remaining codes are invalid - - else - Raise_Encoding_Error; - end if; - - J := J + 1; - end loop; - - return Result (1 .. Len); - end Decode_UTF_16; - - -- Version returning Wide_Wide_String result - - function Decode_UTF_16 (Item : Wide_String) return Wide_Wide_String is - Result : Wide_Wide_String (1 .. Item'Length); - -- Result cannot be longer than the input string - - Len : Natural := 0; - -- Length of result - - Cod : Unsigned_16; - J : Positive; - Rcod : Unsigned_32; - - begin - -- Skip UTF-16 BOM at start - - J := Item'First; - - if J <= Item'Last and then Item (J) = BOM_16 (1) then - J := J + 1; + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; end if; - -- Loop through input characters - - while J <= Item'Last loop - Cod := To_Unsigned_16 (Item (J)); - - -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFF# - -- represent their own value. - - if Cod <= 16#D7FF# or else Cod >= 16#E000# then - Len := Len + 1; - Result (Len) := Wide_Wide_Character'Val (Cod); - - -- Codes in the range 16#D800#..16#DBFF# represent the first of the - -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". - - elsif Cod <= 16#DBFF# then - Rcod := (Unsigned_32 (Cod) - 16#D800#) * 2 ** 10; - - -- Error if at end of string - - if J = Item'Last then - Raise_Encoding_Error; + -- UTF-16BE case - -- Otherwise next character must be valid low order surrogate + if Output_Scheme = UTF_16BE then + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (Shift_Right (C, 8)); + Result (Len + 2) := Character'Val (C and 16#00_FF#); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; - else - J := J + 1; - Cod := To_Unsigned_16 (Item (J)); - - if Cod < 16#DC00# or else Cod > 16#DFFF# then - Raise_Encoding_Error; - - else - Rcod := Rcod + (Unsigned_32 (Cod) mod 2 ** 10) + 16#01_0000#; - Len := Len + 1; - Result (Len) := Wide_Wide_Character'Val (Rcod); - end if; - end if; - - -- If input is in the range 16#DC00#..16#DFFF#, we have a second - -- surrogate character with no corresponding first surrogate. + -- UTF-16LE case - else - Raise_Encoding_Error; - end if; - - J := J + 1; - end loop; + else + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (C and 16#00_FF#); + Result (Len + 2) := Character'Val (Shift_Right (C, 8)); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + end if; return Result (1 .. Len); - end Decode_UTF_16; - - ------------------ - -- Decode_UTF_8 -- - ------------------ - - -- Version returning Wide_String result + end From_UTF_16; - function Decode_UTF_8 (Item : String) return Wide_String is - Result : Wide_String (1 .. Item'Length); - -- Result string (worst case is same length as input) - - Len : Natural := 0; - -- Length of result stored so far - - Ptr : Natural; - -- Input string pointer - - C : Unsigned_8; - R : Unsigned_16; - - procedure Get_Continuation; - -- Reads a continuation byte of the form 10xxxxxx, shifts R left - -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On - -- return Ptr is incremented. Raises exceptioon if continuation - -- byte does not exist or is invalid. - - ---------------------- - -- Get_Continuation -- - ---------------------- - - procedure Get_Continuation is - begin - if Ptr > Item'Last then - Raise_Encoding_Error; - - else - C := To_Unsigned_8 (Item (Ptr)); - Ptr := Ptr + 1; + -------------------------- + -- Raise_Encoding_Error -- + -------------------------- - if C < 2#10_000000# or else C > 2#10_111111# then - Raise_Encoding_Error; + procedure Raise_Encoding_Error (Index : Natural) is + Val : constant String := Index'Img; + begin + raise Encoding_Error with + "bad input at Item (" & Val (Val'First + 1 .. Val'Last) & ')'; + end Raise_Encoding_Error; - else - R := Shift_Left (R, 6) or - Unsigned_16 (C and 2#00_111111#); - end if; - end if; - end Get_Continuation; + --------------- + -- To_UTF_16 -- + --------------- - -- Start of processing for Decode_UTF_8 + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length / 2 + 1); + Len : Natural; + Iptr : Natural; begin - Ptr := Item'First; - - -- Skip BOM at start - - if Ptr + 2 <= Item'Last - and then Item (Ptr .. Ptr + 2) = BOM_8 - then - Ptr := Ptr + 3; + if Item'Length mod 2 /= 0 then + raise Encoding_Error with "UTF-16BE/LE string has odd length"; end if; - -- Loop through input characters - - while Ptr <= Item'Last loop - C := To_Unsigned_8 (Item (Ptr)); - Ptr := Ptr + 1; - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - R := Unsigned_16 (C); - - -- No initial code can be of the form 10xxxxxx. Such codes are used - -- only for continuations. - - elsif C <= 2#10_111111# then - Raise_Encoding_Error; - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 2#110_11111# then - R := Unsigned_16 (C and 2#000_11111#); - Get_Continuation; - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - elsif C <= 2#1110_1111# then - R := Unsigned_16 (C and 2#0000_1111#); - Get_Continuation; - Get_Continuation; - - -- Codes in the range 16#10000# - 16#10FFFF# are represented as - -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - - -- Such codes are out of range for Wide_String output - - else - Raise_Encoding_Error; - end if; - - Len := Len + 1; - Result (Len) := Wide_Character'Val (R); - end loop; - - return Result (1 .. Len); - end Decode_UTF_8; - - -- Version returning Wide_Wide_String result - - function Decode_UTF_8 (Item : String) return Wide_Wide_String is - Result : Wide_Wide_String (1 .. Item'Length); - -- Result string (worst case is same length as input) - - Len : Natural := 0; - -- Length of result stored so far - - Ptr : Natural; - -- Input string pointer - - C : Unsigned_8; - R : Unsigned_32; + -- Deal with input BOM, skip if OK, error if bad BOM - procedure Get_Continuation; - -- Reads a continuation byte of the form 10xxxxxx, shifts R left - -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On - -- return Ptr is incremented. Raises exceptioon if continuation - -- byte does not exist or is invalid. - - ---------------------- - -- Get_Continuation -- - ---------------------- - - procedure Get_Continuation is - begin - if Ptr > Item'Last then - raise Encoding_Error with - "incomplete UTF-8 encoding sequence"; - - else - C := To_Unsigned_8 (Item (Ptr)); - Ptr := Ptr + 1; - - if C < 2#10_000000# or else C > 2#10_111111# then - Raise_Encoding_Error; + Iptr := Item'First; + if Item'Length >= 2 then + if Item (Iptr .. Iptr + 1) = BOM_16BE then + if Input_Scheme = UTF_16BE then + Iptr := Iptr + 2; else - R := Shift_Left (R, 6) or - Unsigned_32 (C and 2#00_111111#); + Raise_Encoding_Error (Iptr); end if; - end if; - end Get_Continuation; - - -- Start of processing for UTF8_Decode - - begin - Ptr := Item'First; - - -- Skip BOM at start - - if Ptr + 2 <= Item'Last - and then Item (Ptr .. Ptr + 2) = BOM_8 - then - Ptr := Ptr + 3; - end if; - - -- Loop through input characters - - while Ptr <= Item'Last loop - C := To_Unsigned_8 (Item (Ptr)); - Ptr := Ptr + 1; - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - if C <= 16#7F# then - R := Unsigned_32 (C); - - -- No initial code can be of the form 10xxxxxx. Such codes are used - -- only for continuations. - - elsif C <= 2#10_111111# then - Raise_Encoding_Error; - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 2#110_11111# then - R := Unsigned_32 (C and 2#000_11111#); - Get_Continuation; - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - elsif C <= 2#1110_1111# then - R := Unsigned_32 (C and 2#0000_1111#); - Get_Continuation; - Get_Continuation; - - -- Codes in the range 16#10000# - 16#10FFFF# are represented as - -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - - elsif C <= 2#11110_111# then - R := Unsigned_32 (C and 2#00000_111#); - Get_Continuation; - Get_Continuation; - Get_Continuation; - - -- Any other code is an error - - else - Raise_Encoding_Error; - end if; - - Len := Len + 1; - Result (Len) := Wide_Wide_Character'Val (R); - end loop; - - return Result (1 .. Len); - end Decode_UTF_8; - - ------------ - -- Encode -- - ------------ - - -- Version with Wide_String input returning encoded String - - function Encode - (Item : Wide_String; - Scheme : Short_Encoding := UTF_8) return String - is - begin - -- Case of UTF_8 - - if Scheme = UTF_8 then - return Encode_UTF_8 (Item); - - -- Case of UTF_16LE or UTF_16BE - - else - UTF16XE_Encode : declare - UTF16_Str : constant Wide_String := Encode_UTF_16 (Item); - Result : String (1 .. 2 * UTF16_Str'Last); - - H, L : Integer range -1 .. 0; - -- Offset for high and low order bytes - - C : Unsigned_16; - -- One UTF_16 output value - - begin - -- Set proper byte offsets - - -- Set the byte order for the two bytes of each UTF_16 input code. - -- For UTF_16LE we have low order/high order. For UTF_16BE we have - -- high order/low order. - - if Scheme = UTF_16LE then - L := -1; - H := 0; + elsif Item (Iptr .. Iptr + 1) = BOM_16LE then + if Input_Scheme = UTF_16LE then + Iptr := Iptr + 2; else - L := 0; - H := -1; + Raise_Encoding_Error (Iptr); end if; - -- Now copy the UTF_16 string to the result string - - pragma Warnings (Off); - for J in 1 .. UTF16_Str'Last loop - C := To_Unsigned_16 (UTF16_Str (J)); - Result (2 * J + L) := Character'Val (C and 16#FF#); - Result (2 * J + H) := Character'Val (Shift_Right (C, 8)); - end loop; - - return Result; - end UTF16XE_Encode; + elsif Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Raise_Encoding_Error (Iptr); + end if; end if; - end Encode; - -- Version with Wide_Wide_String input returning String - - function Encode - (Item : Wide_Wide_String; - Scheme : Short_Encoding := UTF_8) return String - is - begin - -- Case of UTF_8 - - if Scheme = UTF_8 then - return Encode_UTF_8 (Item); - - -- Case of UTF_16LE or UTF_16BE + -- Output BOM if specified + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; else - UTF16XE_Encode : declare - UTF16_Str : constant Wide_String := Encode (Item, UTF_16); - Result : String (1 .. 2 * UTF16_Str'Last); - - H, L : Integer range -1 .. 0; - -- Offset for high and low order bytes - - C : Unsigned_16; - -- One UTF_16 output value - - begin - -- Set proper byte offsets - - -- Set the byte order for the two bytes of each UTF_16 input code. - -- For UTF_16LE we have low order/high order. For UTF_16BE we have - -- high order/low order. - - if Scheme = UTF_16LE then - L := -1; - H := 0; - else - L := 0; - H := -1; - end if; - - -- Now copy the UTF_16 string to the result string - - for J in 1 .. UTF16_Str'Last loop - C := To_Unsigned_16 (UTF16_Str (J)); - Result (2 * J + L) := Character'Val (C and 16#FF#); - Result (2 * J + H) := Character'Val (Shift_Right (C, 8)); - end loop; - - return Result; - end UTF16XE_Encode; + Len := 0; end if; - end Encode; - - -- Wide_String input returning encoded Wide_String (long encodings) - - function Encode - (Item : Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_String - is - pragma Unreferenced (Scheme); - begin - return Encode_UTF_16 (Item); - end Encode; - - -- Wide_Wide_String input returning Wide_String (long encodings) - - function Encode - (Item : Wide_Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_String - is - pragma Unreferenced (Scheme); - begin - return Encode_UTF_16 (Item); - end Encode; - - ------------------- - -- Encode_UTF_16 -- - ------------------- - - -- Wide_String input with UTF-16 encoded Wide_String output - - function Encode_UTF_16 (Item : Wide_String) return Wide_String is - Result : Wide_String (1 .. Item'Length); - -- Output is same length as input (we do not add a BOM!) - - Len : Integer := 0; - -- Length of output string - - Cod : Unsigned_16; - - begin - -- Loop through input characters encoding them - - for J in Item'Range loop - Cod := To_Unsigned_16 (Item (J)); - - -- Codes in the range 16#0000#..16#D7FF# are output unchanged - - if Cod <= 16#D7FF# then - Len := Len + 1; - Result (Len) := Wide_Character'Val (Cod); - - -- Codes in tne range 16#D800#..16#DFFF# should never appear in the - -- input, since no valid Unicode characters are in this range (which - -- would conflict with the UTF-16 surrogate encodings). - - elsif Cod <= 16#DFFF# then - raise Constraint_Error with - "Wide_Character in range 16#D800# .. 16#DFFF#"; - - -- Codes in the range 16#E000#..16#FFFF# are output unchanged - - else - Len := Len + 1; - Result (Len) := Wide_Character'Val (Cod); - end if; - end loop; - - return Result (1 .. Len); - end Encode_UTF_16; - - -- Wide_Wide_String input with UTF-16 encoded Wide_String output - - function Encode_UTF_16 (Item : Wide_Wide_String) return Wide_String is - Result : Wide_String (1 .. 2 * Item'Length); - -- Worst case is each input character generates two output characters - - Len : Integer := 0; - -- Length of output string - - Cod : Unsigned_32; - - begin - -- Loop through input characters encoding them - - for J in Item'Range loop - Cod := To_Unsigned_32 (Item (J)); - - -- Codes in the range 16#00_0000#..16#00_D7FF# are output unchanged - - if Cod <= 16#00_D7FF# then - Len := Len + 1; - Result (Len) := Wide_Character'Val (Cod); - - -- Codes in tne range 16#00_D800#..16#00_DFFF# should never appear - -- in the input, since no valid Unicode characters are in this range - -- (which would conflict with the UTF-16 surrogate encodings). - - elsif Cod <= 16#00_DFFF# then - raise Constraint_Error with - "Wide_Wide_Character in range 16#00_D800# .. 16#00_DFFF#"; - -- Codes in the range 16#00_E000#..16#00_FFFF# are output unchanged + -- UTF-16BE case - elsif Cod <= 16#00_FFFF# then + if Input_Scheme = UTF_16BE then + while Iptr < Item'Last loop Len := Len + 1; - Result (Len) := Wide_Character'Val (Cod); + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) * 256 + + Character'Pos (Item (Iptr + 1))); + Iptr := Iptr + 2; + end loop; - -- Codes in the range 16#01_0000#..16#10_FFFF# are output using two - -- surrogate characters. First 16#1_0000# is subtracted from the code - -- point to give a 20-bit value. This is then split into two separate - -- 10-bit values each of which is represented as a surrogate with the - -- most significant half placed in the first surrogate. To allow safe - -- use of simple word-oriented string processing, separate ranges of - -- values are used for the two surrogates: 16#D800#-16#DBFF# for the - -- first, most significant surrogate and 16#DC00#-16#DFFF# for the - -- second, least significant surrogate. + -- UTF-16LE case - elsif Cod <= 16#10_FFFF# then - Cod := Cod - 16#1_0000#; - - Len := Len + 1; - Result (Len) := Wide_Character'Val (16#D800# + Cod / 2 ** 10); - - Len := Len + 1; - Result (Len) := Wide_Character'Val (16#DC00# + Cod mod 2 ** 10); - - -- Codes larger than 16#10_FFFF# are invalid - - else - raise Constraint_Error with - "Wide_Wide_Character exceeds maximum value of 16#10_FFFF#"; - end if; - end loop; - - return Result (1 .. Len); - end Encode_UTF_16; - - ------------------ - -- Encode_UTF_8 -- - ------------------ - - -- Wide_String input with UTF_8 encoded String output - - function Encode_UTF_8 (Item : Wide_String) return String is - Result : String (1 .. 3 * Item'Length); - -- Worst case is three bytes per input byte - - N : Natural := 0; - -- Number of output codes stored in Result - - C : Unsigned_16; - -- Single input character - - procedure Store (C : Unsigned_16); - pragma Inline (Store); - -- Store one output code, C is in the range 0 .. 255 - - ----------- - -- Store -- - ----------- - - procedure Store (C : Unsigned_16) is - begin - N := N + 1; - Result (N) := Character'Val (C); - end Store; - - -- Start of processing for UTF8_Encode - - begin - -- Loop through characters of input - - for J in Item'Range loop - C := To_Unsigned_16 (Item (J)); - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - Store (C); - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 16#7FF# then - Store (2#110_00000# or Shift_Right (C, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - else - Store (2#1110_0000# or Shift_Right (C, 12)); - Store (2#10_000000# or - Shift_Right (C and 2#111111_000000#, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - end if; - end loop; - - return Result (1 .. N); - end Encode_UTF_8; - - -- Wide_Wide_String input with UTF_8 encoded String output - - function Encode_UTF_8 (Item : Wide_Wide_String) return String is - Result : String (1 .. 4 * Item'Length); - -- Worst case is four bytes per input byte - - N : Natural := 0; - -- Number of output codes stored in Result - - C : Unsigned_32; - -- Single input character - - procedure Store (C : Unsigned_32); - pragma Inline (Store); - -- Store one output code (input is in range 0 .. 255) - - ----------- - -- Store -- - ----------- - - procedure Store (C : Unsigned_32) is - begin - N := N + 1; - Result (N) := Character'Val (C); - end Store; - - -- Start of processing for UTF8_Encode - - begin - -- Loop through characters of input - - for J in Item'Range loop - C := To_Unsigned_32 (Item (J)); - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - Store (C); - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 16#7FF# then - Store (2#110_00000# or Shift_Right (C, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - elsif C <= 16#FFFF# then - Store (2#1110_0000# or Shift_Right (C, 12)); - Store (2#10_000000# or - Shift_Right (C and 2#111111_000000#, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - - -- Codes in the range 16#10000# - 16#10FFFF# are represented as - -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - - elsif C <= 16#10_FFFF# then - Store (2#11110_000# or Shift_Right (C, 18)); - Store (2#10_000000# or - Shift_Right (C and 2#111111_000000_000000#, 12)); - Store (2#10_000000# - or Shift_Right (C and 2#111111_000000#, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - - -- Codes higher than 16#10_FFFF# should not appear - - else - raise Constraint_Error with - "out of range invalid value in Encode input"; - end if; - end loop; - - return Result (1 .. N); - end Encode_UTF_8; - - -------------- - -- Encoding -- - -------------- - - -- Version taking String input - - function Encoding (Item : String) return Encoding_Scheme is - begin - if Item'Length >= 2 then - if Item (Item'First .. Item'First + 1) = BOM_16BE then - return UTF_16BE; - - elsif Item (Item'First .. Item'First + 1) = BOM_16LE then - return UTF_16LE; - - elsif Item'Length >= 3 - and then Item (Item'First .. Item'First + 2) = BOM_8 - then - return UTF_8; - end if; - end if; - - return UTF_None; - end Encoding; - - -- Version taking Wide_String input - - function Encoding (Item : Wide_String) return Encoding_Scheme is - begin - if Item'Length >= 1 - and then Item (Item'First .. Item'First) = BOM_16 - then - return UTF_16; else - return UTF_None; + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) + + Character'Pos (Item (Iptr + 1)) * 256); + Iptr := Iptr + 2; + end loop; end if; - end Encoding; - ------------------------ - -- Raise_Encoding_Error -- - ------------------------ - - procedure Raise_Encoding_Error is - begin - raise Encoding_Error with "invalid input encoding sequence"; - end Raise_Encoding_Error; + return Result (1 .. Len); + end To_UTF_16; end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stuten.ads b/gcc/ada/a-stuten.ads index 33b5aec88d1..5299c6f88e2 100644 --- a/gcc/ada/a-stuten.ads +++ b/gcc/ada/a-stuten.ads @@ -7,111 +7,140 @@ -- S p e c -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ --- This is the Ada 2012 package defined in AI05-0137-1. It is used for --- encoding strings using UTF encodings (UTF-8, UTF-16LE, UTF-16BE, UTF-16). - --- Compared with version 05 of the AI, we have added routines for UTF-16 --- encoding and decoding of wide strings, which seems missing from the AI, --- added comments, and reordered the declarations. +-- This is one of the Ada 2012 package defined in AI05-0137-1. It is a parent +-- package that contains declarations used in the child packages for handling +-- UTF encoded strings. Note: this package is consistent with Ada 95, and may +-- be used in Ada 95 or Ada 2005 mode. --- Note: although this is an Ada 2012 package, the earlier versions of the --- language permit the addition of new grandchildren of Ada, so we are able --- to add this package unconditionally for use in Ada 2005 mode. We cannot --- allow it in earlier versions, since it requires Wide_Wide_Character/String. +with Interfaces; +with Unchecked_Conversion; package Ada.Strings.UTF_Encoding is pragma Pure (UTF_Encoding); - type Encoding_Scheme is (UTF_None, UTF_8, UTF_16BE, UTF_16LE, UTF_16); + subtype UTF_String is String; + -- Used to represent a string of 8-bit values containing a sequence of + -- values encoded in one of three ways (UTF-8, UTF-16BE, or UTF-16LE). + -- Typically used in connection with a Scheme parameter indicating which + -- of the encodings applies. This is not strictly a String value in the + -- sense defined in the Ada RM, but in practice type String accomodates + -- all possible 256 codes, and can be used to hold any sequence of 8-bit + -- codes. We use String directly rather than create a new type so that + -- all existing facilities for manipulating type String (e.g. the child + -- packages of Ada.Strings) are available for manipulation of UTF_Strings. + + type Encoding_Scheme is (UTF_8, UTF_16BE, UTF_16LE); + -- Used to specify which of three possible encodings apply to a UTF_String + + subtype UTF_8_String is String; + -- Similar to UTF_String but specifically represents a UTF-8 encoded string + + subtype UTF_16_Wide_String is Wide_String; + -- This is similar to UTF_8_String but is used to represent a Wide_String + -- value which is a sequence of 16-bit values encoded using UTF-16. Again + -- this is not strictly a Wide_String in the sense of the Ada RM, but the + -- type Wide_String can be used to represent a sequence of arbitrary 16-bit + -- values, and it is more convenient to use Wide_String than a new type. - subtype Short_Encoding is Encoding_Scheme range UTF_8 .. UTF_16LE; - subtype Long_Encoding is Encoding_Scheme range UTF_16 .. UTF_16; + Encoding_Error : exception; + -- This exception is raised in the following situations: + -- a) A UTF encoded string contains an invalid encoding sequence + -- b) A UTF-16BE or UTF-16LE input string has an odd length + -- c) An incorrect character value is present in the Input string + -- d) The result for a Wide_Character output exceeds 16#FFFF# + -- The exception message has the index value where the error occurred. -- The BOM (BYTE_ORDER_MARK) values defined here are used at the start of -- a string to indicate the encoding. The convention in this package is - -- that decoding routines ignore a BOM, and output of encoding routines - -- does not include a BOM. If you want to include a BOM in the output, - -- you simply concatenate the appropriate value at the start of the string. + -- that on input a correct BOM is ignored and an incorrect BOM causes an + -- Encoding_Error exception. On output, the output string may or may not + -- include a BOM depending on the setting of Output_BOM. - BOM_8 : constant String := + BOM_8 : constant UTF_8_String := Character'Val (16#EF#) & Character'Val (16#BB#) & Character'Val (16#BF#); - BOM_16BE : constant String := + BOM_16BE : constant UTF_String := Character'Val (16#FE#) & Character'Val (16#FF#); - BOM_16LE : constant String := + BOM_16LE : constant UTF_String := Character'Val (16#FF#) & Character'Val (16#FE#); - BOM_16 : constant Wide_String := + BOM_16 : constant UTF_16_Wide_String := (1 => Wide_Character'Val (16#FEFF#)); - -- The encoding routines take a wide string or wide wide string as input - -- and encode the result using the specified UTF encoding method. For - -- UTF-16, the output is returned as a Wide_String, this is not a normal - -- Wide_String, since the codes in it may represent UTF-16 surrogate - -- characters used to encode large values. Similarly for UTF-8, UTF-16LE, - -- and UTF-16BE, the output is returned in a String, and again this String - -- is not a standard format string, since it may include UTF-8 surrogates. - -- As previously noted, the returned value does NOT start with a BOM. - - -- Note: invalid codes in calls to one of the Encode routines represent - -- invalid values in the sense that they are not defined. For example, the - -- code 16#DC03# is not a valid wide character value. Such values result - -- in undefined behavior. For GNAT, Constraint_Error is raised with an - -- appropriate exception message. - - function Encode - (Item : Wide_String; - Scheme : Short_Encoding := UTF_8) return String; - function Encode - (Item : Wide_Wide_String; - Scheme : Short_Encoding := UTF_8) return String; - - function Encode - (Item : Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_String; - function Encode - (Item : Wide_Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_String; - - -- The decoding routines take a String or Wide_String input which is an - -- encoded string using the specified encoding. The output is a normal - -- Ada Wide_String or Wide_Wide_String value representing the decoded - -- values. Note that a BOM in the input matching the encoding is skipped. - - Encoding_Error : exception; - -- Exception raised if an invalid encoding sequence is encountered by - -- one of the Decode routines. - - function Decode - (Item : String; - Scheme : Short_Encoding := UTF_8) return Wide_String; - function Decode - (Item : String; - Scheme : Short_Encoding := UTF_8) return Wide_Wide_String; - - function Decode - (Item : Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_String; - function Decode - (Item : Wide_String; - Scheme : Long_Encoding := UTF_16) return Wide_Wide_String; - - -- The Encoding functions inspect an encoded string or wide_string and - -- determine if a BOM is present. If so, the appropriate Encoding_Scheme - -- is returned. If not, then UTF_None is returned. - - function Encoding (Item : String) return Encoding_Scheme; - function Encoding (Item : Wide_String) return Encoding_Scheme; + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme; + -- This function inspects a UTF_String value to determine whether it + -- starts with a BOM for UTF-8, UTF-16BE, or UTF_16LE. If so, the result + -- is the scheme corresponding to the BOM. If no valid BOM is present + -- then the result is the specified Default value. + +private + function To_Unsigned_8 is new + Unchecked_Conversion (Character, Interfaces.Unsigned_8); + + function To_Unsigned_16 is new + Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); + + function To_Unsigned_32 is new + Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); + + subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE; + -- Subtype containing only UTF_16BE and UTF_16LE entries + + -- Utility routines for converting between UTF-16 and UTF-16LE/BE + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String; + -- The input string Item is encoded in UTF-16. The output is encoded using + -- Output_Scheme (which is either UTF-16LE or UTF-16BE). There are no error + -- cases. The output starts with BOM_16BE/LE if Output_BOM is True. + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- The input string Item is encoded using Input_Scheme which is either + -- UTF-16LE or UTF-16BE. The output is the corresponding UTF_16 wide + -- string. Encoding error is raised if the length of the input is odd. + -- The output starts with BOM_16 if Output_BOM is True. + + procedure Raise_Encoding_Error (Index : Natural); + pragma No_Return (Raise_Encoding_Error); + -- Raise Encoding_Error exception for bad encoding in input item. The + -- parameter Index is the index of the location in Item for the error. end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stwiun-shared.adb b/gcc/ada/a-stwiun-shared.adb new file mode 100644 index 00000000000..fb7ae76d34e --- /dev/null +++ b/gcc/ada/a-stwiun-shared.adb @@ -0,0 +1,2106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Unbounded is + + use Ada.Strings.Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left string is empty, return Rigth string. + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string. + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data. + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Right is an empty string, return Left string. + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left is empty string, return Right string. + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if Left = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Coefficient is one, just return string itself. + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal. + end "="; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + return Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_String) is + SR : constant Shared_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + Wide_Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String) + is + TR : constant Shared_Wide_String_Access := Target.Reference; + DR : Shared_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String + is + DR : constant Shared_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String + is + DR : constant Shared_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_String, Shared_Wide_String_Access); + + Aux : Shared_Wide_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_Wide_String must never reach + -- zero. + + pragma Assert (Aux /= Empty_Shared_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stwiun-shared.ads b/gcc/ada/a-stwiun-shared.ads new file mode 100644 index 00000000000..a438258c908 --- /dev/null +++ b/gcc/ada/a-stwiun-shared.ads @@ -0,0 +1,483 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String; + + function Length (Source : Unbounded_Wide_String) return Natural; + + type Wide_String_Access is access all Wide_String; + + procedure Free (X : in out Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String; + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String; + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character); + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character); + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String); + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String); + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String); + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter. + + Last : Natural := 0; + Data : Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indecies are just an extra room. + end record; + + type Shared_Wide_String_Access is access all Shared_Wide_String; + + procedure Reference (Item : not null Shared_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_String can be reused. There are two criteria + -- when Shared_Wide_String can be reused: its reference counter must be one + -- (thus Shared_Wide_String is owned exclusively) and its size is + -- sufficient to store string with specified length effectively. + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access; + -- Allocates new Shared_Wide_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_Wide_String can be sligtly + -- greater. Returns reference to Empty_Shared_Wide_String when requested + -- length is zero. + + Empty_Shared_Wide_String : aliased Shared_Wide_String (0); + + function To_Unbounded (S : Wide_String) return Unbounded_Wide_String + renames To_Unbounded_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; + end record; + + -- The Unbounded_Wide_String uses several techniques to increasy speed of + -- the application: + -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains + -- only the reference to the data which is shared between several + -- instances. The shared data is reallocated only when its value is + -- changed and the object mutation can't be used or it is unefficient to + -- use it; + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less then some threashold. + -- - memory preallocation. Most of used memory allocation algorithms + -- alligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + -- + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_String thread-safe, so each instance + -- can't be accessed by several tasks simulatenously. + + pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_Wide_String); + overriding procedure Adjust (Object : in out Unbounded_Wide_String); + overriding procedure Finalize (Object : in out Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String := + (AF.Controlled with + Reference => Empty_Shared_Wide_String'Access); + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stzunb-shared.adb b/gcc/ada/a-stzunb-shared.adb new file mode 100644 index 00000000000..40178394131 --- /dev/null +++ b/gcc/ada/a-stzunb-shared.adb @@ -0,0 +1,2120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Unbounded is + + use Ada.Strings.Wide_Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + procedure Sync_Add_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Interfaces.Unsigned_32; + Value : Interfaces.Unsigned_32) return Interfaces.Unsigned_32; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left string is empty, return Rigth string. + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string. + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data. + + else + DR := Allocate (LR.Last + RR.Last); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Right is an empty string, return Left string. + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left is empty string, return Right string. + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string. + + if Left = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string. + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Coefficient is one, just return string itself. + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it. + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal. + end "="; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_Wide_String'Size + / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + return Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean + is + use Interfaces; + begin + return + Item.Counter = 1 + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is + SR : constant Shared_Wide_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + Wide_Wide_Search.Find_Token + (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less then requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater then requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less the requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is + begin + Sync_Add_And_Fetch (Item.Counter'Access, 1); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check. + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - High - 1; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String) + is + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_Wide_String -- + -------------------- + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DR : constant Shared_Wide_Wide_String_Access := Allocate (Source'Length); + begin + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String + is + DR : constant Shared_Wide_Wide_String_Access := Allocate (Length); + begin + DR.Last := Length; + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is + use Interfaces; + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access); + + Aux : Shared_Wide_Wide_String_Access := Item; + + begin + if Sync_Sub_And_Fetch (Aux.Counter'Access, 1) = 0 then + + -- Reference counter of Empty_Shared_Wide_Wide_String must never + -- reach zero. + + pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-stzunb-shared.ads b/gcc/ada/a-stzunb-shared.ads new file mode 100644 index 00000000000..4617f56fdc2 --- /dev/null +++ b/gcc/ada/a-stzunb-shared.ads @@ -0,0 +1,501 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Wide_Maps; +private with Ada.Finalization; +private with Interfaces; + +package Ada.Strings.Wide_Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; + + function Length (Source : Unbounded_Wide_Wide_String) return Natural; + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (X : in out Wide_Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character); + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String); + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String); + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String); + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_Wide_String (Max_Length : Natural) is limited record + Counter : aliased Interfaces.Unsigned_32 := 1; + -- Reference counter. + + Last : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indecies are just an extra room. + end record; + + type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String; + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_Wide_String can be reused. There are two + -- criteria when Shared_Wide_Wide_String can be reused: its reference + -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively) + -- and its size is sufficient to store string with specified length + -- effectively. + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access; + -- Allocates new Shared_Wide_Wide_String with at least specified maximum + -- length. Actual maximum length of the allocated Shared_Wide_Wide_String + -- can be sligtly greater. Returns reference to + -- Empty_Shared_Wide_Wide_String when requested length is zero. + + Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0); + + function To_Unbounded + (S : Wide_Wide_String) return Unbounded_Wide_Wide_String + renames To_Unbounded_Wide_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_Wide_String_Access := + Empty_Shared_Wide_Wide_String'Access; + end record; + + -- The Unbounded_Wide_Wide_String uses several techniques to increasy speed + -- of the application: + -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String + -- contains only the reference to the data which is shared between + -- several instances. The shared data is reallocated only when its value + -- is changed and the object mutation can't be used or it is unefficient + -- to use it; + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less then some threashold. + -- - memory preallocation. Most of used memory allocation algorithms + -- alligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + -- + -- Reference counting uses GCC builtin atomic operations, which allows to + -- safely share internal data between Ada tasks. Nevertheless, this not + -- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance + -- can't be accessed by several tasks simulatenously. + + pragma Stream_Convert + (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Adjust + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Finalize + (Object : in out Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := + (AF.Controlled with + Reference => + Empty_Shared_Wide_Wide_String'Access); + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-suenco.adb b/gcc/ada/a-suenco.adb new file mode 100755 index 00000000000..42b7f719a5b --- /dev/null +++ b/gcc/ada/a-suenco.adb @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Conversions is + use Interfaces; + + -- Version convertion from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Nothing to do if identical schemes + + if Input_Scheme = Output_Scheme then + return Item; + + -- For remaining cases, one or other of the operands is UTF-16BE/LE + -- encoded, so go through UTF-16 intermediate. + + else + return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)), + Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Version converting UTF-8/UTF-16BE/LE to UTF-16 + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return To_UTF_16 (Item, Input_Scheme, Output_BOM); + end if; + end Convert; + + -- Version converting UTF-8 to UTF-16 + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length + 1); + -- Maximum length of result, including possible BOM + + Len : Natural := 0; + -- Number of characters stored so far in Result + + Iptr : Natural; + -- Next character to process in Item + + C : Unsigned_8; + -- Input UTF-8 code + + R : Unsigned_16; + -- Output UTF-16 code + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C < 2#10_000000# or else C > 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + else + R := Shift_Left (R, 6) or + Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Convert + + begin + -- Output BOM if required + + if Output_BOM then + Len := Len + 1; + Result (Len) := BOM_16 (1); + end if; + + -- Skip OK BOM + + Iptr := Item'First; + + if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + + -- No BOM present + + else + Iptr := Item'First; + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# + -- UTF-8: 0xxxxxxx + -- UTF-16: 00000000_0xxxxxxx + + if C <= 16#7F# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-8: 110yyyxx 10xxxxxx + -- UTF-16: 00000yyy_xxxxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Codes in the range 16#800# - 16#FFFF# + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + -- UTF-16: yyyyyyyy_xxxxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Make sure that we don't have a result in the forbidden range + -- reserved for UTF-16 surrogate characters. + + if R in 16#D800# .. 16#DF00# then + Raise_Encoding_Error (Iptr - 3); + end if; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx + -- Note: zzzz in the output is input zzzzz - 1 + + elsif C <= 2#11110_111# then + R := Unsigned_16 (C and 2#00000_111#); + Get_Continuation; + + -- R now has zzzzzyyyy + + R := R - 2#0000_1_0000#; + + -- R now has zzzzyyyy (zzzz minus one for the output) + + Get_Continuation; + + -- R now has zzzzyyyyyyyyxx + + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (2#110110_00_0000_0000# or Shift_Right (R, 4)); + + R := R and 2#1111#; + Get_Continuation; + Len := Len + 1; + Result (Len) := + Wide_Character'Val (2#110111_00_0000_0000# or R); + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + + -- Convert from UTF-16 to UTF-8/UTF-16-BE/LE + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return From_UTF_16 (Item, Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Convert from UTF-16 to UTF-8 + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is 3 output codes for each input code + BOM space + + Len : Natural; + -- Number of result codes stored + + Iptr : Natural; + -- Pointer to next input character + + C1, C2 : Unsigned_16; + + zzzzz : Unsigned_16; + yyyyyyyy : Unsigned_16; + xxxxxxxx : Unsigned_16; + -- Components of double length case + + begin + Iptr := Item'First; + + -- Skip BOM at start of input + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Generate output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through input + + while Iptr <= Item'Last loop + C1 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000# - 16#007F# + -- UTF-16: 000000000xxxxxxx + -- UTF-8: 0xxxxxxx + + if C1 <= 16#007F# then + Result (Len + 1) := Character'Val (C1); + Len := Len + 1; + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-16: 00000yyyxxxxxxxx + -- UTF-8: 110yyyxx 10xxxxxx + + elsif C1 <= 16#07FF# then + Result (Len + 1) := + Character'Val + (2#110_000000# or Shift_Right (C1, 6)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 2; + + -- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF# + -- UTF-16: yyyyyyyyxxxxxxxx + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + + elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then + Result (Len + 1) := + Character'Val + (2#1110_0000# or Shift_Right (C1, 12)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#)); + Result (Len + 3) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 3; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- Note: zzzzz in the output is input zzzz + 1 + + elsif C1 <= 2#110110_11_11111111# then + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + else + C2 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + end if; + + if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then + Raise_Encoding_Error (Iptr - 1); + end if; + + zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1; + yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#) + or + (Shift_Right (C2, 8) and 2#000000_11#)); + xxxxxxxx := C2 and 2#11111111#; + + Result (Len + 1) := + Character'Val + (2#11110_000# or (Shift_Right (zzzzz, 2))); + Result (Len + 2) := + Character'Val + (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) + or Shift_Right (yyyyyyyy, 4)); + Result (Len + 3) := + Character'Val + (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) + or Shift_Right (xxxxxxxx, 6)); + Result (Len + 4) := + Character'Val + (2#10_000000# or (xxxxxxxx and 2#00_111111#)); + Len := Len + 4; + + -- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st) + + else + Raise_Encoding_Error (Iptr - 2); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suenco.ads b/gcc/ada/a-suenco.ads new file mode 100755 index 00000000000..0aa4f88b20f --- /dev/null +++ b/gcc/ada/a-suenco.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It provides conversions +-- from one UTF encoding method to another. Note: this package is consistent +-- with Ada 95, and may be used in Ada 95 or Ada 2005 mode. + +package Ada.Strings.UTF_Encoding.Conversions is + pragma Pure (Conversions); + + -- In the following conversion routines, a BOM in the input that matches + -- the encoding scheme is ignored, an incorrect BOM causes Encoding_Error + -- to be raised. A BOM is present in the output if the Output_BOM parameter + -- is set to True. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in one of + -- these three schemes as specified by the Output_Scheme argument. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in UTF-16. + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from UTF-8 to UTF-16 + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from UTF-16 to UTF-8, UTF-16LE, or UTF-16BE as specified by + -- the Output_Scheme argument. + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Convert from UTF-16 to UTF-8 + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suewen.adb b/gcc/ada/a-suewen.adb new file mode 100755 index 00000000000..3cbebc83d3a --- /dev/null +++ b/gcc/ada/a-suewen.adb @@ -0,0 +1,371 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Encoding is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_String + + function Decode (Item : UTF_8_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input Item pointer + + C : Unsigned_8; + R : Unsigned_16; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_16 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + -- Such codes are out of range for Wide_String output + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result is same length as input (possibly minus 1 if BOM present) + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Index of next Item element + + C : Unsigned_16; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- Such codes are out of range for 16-bit output. + + -- The case of input in the range 16#DC00#..16#DFFF# must never + -- occur, since it means we have a second surrogate character with + -- no corresponding first surrogate. + + -- Codes in the range 16#FFFE# .. 16#FFFF# are also invalid since + -- they conflict with codes used for BOM values. + + -- Thus all remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Case of UTF_8 + + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + + -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary + + else + return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), + Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_String in UTF-8 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is three bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_16; + -- Single input character + + procedure Store (C : Unsigned_16); + pragma Inline (Store); + -- Store one output code, C is in the range 0 .. 255 + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_16) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for UTF8_Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for J in Item'Range loop + C := To_Unsigned_16 (Item (J)); + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + else + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_String in UTF-16 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : Wide_String (1 .. Item'Length + Boolean'Pos (Output_BOM)); + -- Output is same length as input + possible BOM + + Len : Integer; + -- Length of output string + + C : Unsigned_16; + + begin + -- Output BOM if required + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_16 (Item (Iptr)); + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# are + -- output unchaned. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in tne range 16#D800#..16#DFFF# should never appear in the + -- input, since no valid Unicode characters are in this range (which + -- would conflict with the UTF-16 surrogate encodings). Similarly + -- codes in the range 16#FFFE#..16#FFFF conflict with BOM codes. + -- Thus all remaining codes are illegal. + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result; + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Encoding; diff --git a/gcc/ada/a-suewen.ads b/gcc/ada/a-suewen.ads new file mode 100755 index 00000000000..bae9e148447 --- /dev/null +++ b/gcc/ada/a-suewen.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 95, and may be included in Ada 95 implementations. + +package Ada.Strings.UTF_Encoding.Wide_Encoding is + pragma Pure (Wide_Encoding); + + -- The encoding routines take a Wide_String as input and encode the result + -- using the specified UTF encoding method. The result includes a BOM if + -- the Output_BOM argument is set to True. Encoding_Error is raised if an + -- invalid character appears in the input. In particular the characters + -- in the range 16#D800# .. 16#DFFF# are invalid because they conflict + -- with UTF-16 surrogate encodings, and the characters 16#FFFE# and + -- 16#FFFF# are also invalid because they conflict with BOM codes. + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_String + -- value. Note: a convenient form for scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Encoding; diff --git a/gcc/ada/a-suezen.adb b/gcc/ada/a-suezen.adb new file mode 100755 index 00000000000..972fbf061e8 --- /dev/null +++ b/gcc/ada/a-suezen.adb @@ -0,0 +1,431 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_Wide_String + + function Decode (Item : UTF_8_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input string pointer + + C : Unsigned_8; + R : Unsigned_32; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exceptioon if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_32 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_32 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_32 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_32 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#11110_111# then + R := Unsigned_32 (C and 2#00000_111#); + Get_Continuation; + Get_Continuation; + Get_Continuation; + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result cannot be longer than the input string + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Pointer to next element in Item + + C : Unsigned_16; + R : Unsigned_32; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- The first surrogate provides 10 high order bits of the result. + + elsif C <= 16#DBFF# then + R := Shift_Left ((Unsigned_32 (C) - 16#D800#), 10); + + -- Error if at end of string + + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + -- Otherwise next character must be valid low order surrogate + -- which provides the low 10 order bits of the result. + + else + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 16#DC00# .. 16#DFFF# then + Raise_Encoding_Error (Iptr - 1); + + else + R := R or (Unsigned_32 (C) mod 2 ** 10); + + -- The final adjustment is to add 16#01_0000 to get the + -- result back in the required 21 bit range. + + R := R + 16#01_0000#; + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end if; + end if; + + -- Remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + else + return From_UTF_16 (Encode (Item), Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_Wide_String in UTF-8 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : String (1 .. 4 * Item'Length + 3); + -- Worst case is four bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_32; + -- Single input character + + procedure Store (C : Unsigned_32); + pragma Inline (Store); + -- Store one output code (input is in range 0 .. 255) + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_32) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00#..16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80#..16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800#..16#D7FF# or 16#E000#..16#FFFD# are + -- represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C in 16#1_0000# .. 16#10_FFFF# then + Store (2#11110_000# or + Shift_Right (C, 18)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000_000000#, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or + (C and 2#00_111111#)); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_Wide_String in UTF-16 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : Wide_String (1 .. 2 * Item'Length + 1); + -- Worst case is each input character generates two output characters + -- plus one for possible BOM. + + Len : Integer; + -- Length of output string + + C : Unsigned_32; + + begin + -- Output BOM if needed + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00_0000#..16#00_D7FF# or 16#E000#..16#FFFD# + -- are output unchanged + + if C <= 16#00_D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#01_0000#..16#10_FFFF# are output using two + -- surrogate characters. First 16#1_0000# is subtracted from the code + -- point to give a 20-bit value. This is then split into two separate + -- 10-bit values each of which is represented as a surrogate with the + -- most significant half placed in the first surrogate. The ranges of + -- values used for the two surrogates are 16#D800#-16#DBFF# for the + -- first, most significant surrogate and 16#DC00#-16#DFFF# for the + -- second, least significant surrogate. + + elsif C in 16#1_0000# .. 16#10_FFFF# then + C := C - 16#1_0000#; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#D800# + C / 2 ** 10); + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#DC00# + C mod 2 ** 10); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding; diff --git a/gcc/ada/a-suezen.ads b/gcc/ada/a-suezen.ads new file mode 100755 index 00000000000..7d2a91d2b25 --- /dev/null +++ b/gcc/ada/a-suezen.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 2005, and may be used in Ada 2005 mode, but cannot be +-- used in Ada 95 mode, since Wide_Wide_Character is an Ada 2005 feature. + +package Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is + pragma Pure (Wide_Wide_Encoding); + + -- The encoding routines take a Wide_Wide_String as input and encode the + -- result using the specified UTF encoding method. The result includes a + -- BOM if the Output_BOM parameter is set to True. + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_Wide_String + -- value. Note: a convenient form for Scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding; diff --git a/gcc/ada/a-swunau-shared.adb b/gcc/ada/a-swunau-shared.adb new file mode 100644 index 00000000000..d7fe3a76d30 --- /dev/null +++ b/gcc/ada/a-swunau-shared.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Unbounded.Aux is + + --------------------- + -- Get_Wide_String -- + --------------------- + + procedure Get_Wide_String + (U : Unbounded_Wide_String; + S : out Big_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_String; + + --------------------- + -- Set_Wide_String -- + --------------------- + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access) + is + X : Wide_String_Access := S; + + begin + Set_Unbounded_Wide_String (UP, S.all); + Free (X); + end Set_Wide_String; + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swuwti-shared.adb b/gcc/ada/a-swuwti-shared.adb new file mode 100644 index 00000000000..110b911d441 --- /dev/null +++ b/gcc/ada/a-swuwti-shared.adb @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; + +package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_String is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/a-szunau-shared.adb b/gcc/ada/a-szunau-shared.adb new file mode 100644 index 00000000000..eebc228428d --- /dev/null +++ b/gcc/ada/a-szunau-shared.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Wide_Unbounded.Aux is + + -------------------------- + -- Get_Wide_Wide_String -- + -------------------------- + + procedure Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String; + S : out Big_Wide_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_Wide_String; + + -------------------------- + -- Set_Wide_Wide_String -- + -------------------------- + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access) + is + X : Wide_Wide_String_Access := S; + + begin + Set_Unbounded_Wide_Wide_String (UP, S.all); + Free (X); + end Set_Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szuzti-shared.adb b/gcc/ada/a-szuzti-shared.adb new file mode 100644 index 00000000000..fe0136ce96a --- /dev/null +++ b/gcc/ada/a-szuzti-shared.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; + +package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 48420c0d68a..5126e5a1730 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -280,16 +280,14 @@ package body Exp_Attr is -- Start of processing for Expand_Access_To_Protected_Op begin - -- Within the body of the protected type, the prefix - -- designates a local operation, and the object is the first - -- parameter of the corresponding protected body of the - -- current enclosing operation. + -- Within the body of the protected type, the prefix designates a local + -- operation, and the object is the first parameter of the corresponding + -- protected body of the current enclosing operation. if Is_Entity_Name (Pref) then if May_Be_External_Call then Sub := - New_Occurrence_Of - (External_Subprogram (Entity (Pref)), Loc); + New_Occurrence_Of (External_Subprogram (Entity (Pref)), Loc); else Sub := New_Occurrence_Of @@ -372,6 +370,7 @@ package body Exp_Attr is Make_Aggregate (Loc, Expressions => New_List (Obj_Ref, Sub_Ref)); + Freeze_Before (N, Entity (Sub)); Rewrite (N, Agg); Analyze_And_Resolve (N, E_T); diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index 87d9dc73d0e..ee65cb2fdd1 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -407,9 +407,6 @@ ATOMICS_TARGET_PAIRS += \ a-szunau.adb<a-szunau-shared.adb \ a-szuzti.adb<a-szuzti-shared.adb -# Reset setting for now -ATOMICS_TARGET_PAIRS = - LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/')) # $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT. diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb index cff6d67aa2e..cbd489064ca 100644 --- a/gcc/ada/impunit.adb +++ b/gcc/ada/impunit.adb @@ -173,6 +173,14 @@ package body Impunit is "a-wichun", -- Ada.Wide_Characters.Unicode "a-widcha", -- Ada.Wide_Characters + -- Note: strictly the next two should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 95 mode, since + -- they only deal with Wide_Character, not Wide_Wide_Character. + + "a-stuten", -- Ada.Strings.UTF_Encoding + "a-suenco", -- Ada.Strings.UTF_Encoding.Conversions + "a-suewen", -- Ada.Strings.UTF_Encoding.Wide_Encoding + --------------------------- -- GNAT Special IO Units -- --------------------------- @@ -459,10 +467,10 @@ package body Impunit is "a-szuzti", -- Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO "a-zchuni", -- Ada.Wide_Wide_Characters.Unicode - -- Note: strictly the next one should be an Ada 2012 unit, but it seems - -- harmless (and useful) to make it available in Ada 2005 mode. + -- Note: strictly the following should be Ada 2012 units, but it seems + -- harmless (and useful) to make then available in Ada 2005 mode. - "a-stuten", -- Ada.Strings.UTF_Encoding + "a-suezen", -- Ada.Strings.UTF_Encoding.Wide_Wide_Encoding --------------------------- -- GNAT Special IO Units -- diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index ce6887ef21a..5e6d8b2766a 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -67,9 +67,9 @@ package body Sem is -- Controls debugging printouts for Walk_Library_Items Outer_Generic_Scope : Entity_Id := Empty; - -- Global reference to the outer scope that is generic. In a non - -- generic context, it is empty. At the moment, it is only used - -- for avoiding freezing of external references in generics. + -- Global reference to the outer scope that is generic. In a non- generic + -- context, it is empty. At the moment, it is only used for avoiding + -- freezing of external references in generics. Comp_Unit_List : Elist_Id := No_Elist; -- Used by Walk_Library_Items. This is a list of N_Compilation_Unit nodes @@ -80,9 +80,9 @@ package body Sem is generic with procedure Action (Withed_Unit : Node_Id); procedure Walk_Withs_Immediate (CU : Node_Id; Include_Limited : Boolean); - -- Walk all the with clauses of CU, and call Action for the with'ed - -- unit. Ignore limited withs, unless Include_Limited is True. - -- CU must be an N_Compilation_Unit. + -- Walk all the with clauses of CU, and call Action for the with'ed unit. + -- Ignore limited withs, unless Include_Limited is True. CU must be an + -- N_Compilation_Unit. generic with procedure Action (Withed_Unit : Node_Id); @@ -582,14 +582,14 @@ package body Sem is when N_With_Clause => Analyze_With_Clause (N); - -- A call to analyze the Empty node is an error, but most likely - -- it is an error caused by an attempt to analyze a malformed - -- piece of tree caused by some other error, so if there have - -- been any other errors, we just ignore it, otherwise it is - -- a real internal error which we complain about. + -- A call to analyze the Empty node is an error, but most likely it + -- is an error caused by an attempt to analyze a malformed piece of + -- tree caused by some other error, so if there have been any other + -- errors, we just ignore it, otherwise it is a real internal error + -- which we complain about. - -- We must also consider the case of call to a runtime function - -- that is not available in the configurable runtime. + -- We must also consider the case of call to a runtime function that + -- is not available in the configurable runtime. when N_Empty => pragma Assert (Serious_Errors_Detected /= 0 @@ -846,7 +846,7 @@ package body Sem is return; end if; - -- Now search the global entity suppress table for a matching entry + -- Now search the global entity suppress table for a matching entry. -- We also search this in reverse order so that if there are multiple -- pragmas for the same entity, the last one applies. @@ -1114,12 +1114,12 @@ package body Sem is Node := First (L); Insert_List_After (N, L); - -- Now just analyze from the original first node until we get to - -- the successor of the original insertion point (which may be - -- Empty if the insertion point was at the end of the list). Note - -- that this properly handles the case where any of the analyze - -- calls result in the insertion of nodes after the analyzed - -- node (possibly calling this routine recursively). + -- Now just analyze from the original first node until we get to the + -- successor of the original insertion point (which may be Empty if + -- the insertion point was at the end of the list). Note that this + -- properly handles the case where any of the analyze calls result in + -- the insertion of nodes after the analyzed node (possibly calling + -- this routine recursively). while Node /= After loop Analyze (Node); @@ -1165,9 +1165,9 @@ package body Sem is begin if Is_Non_Empty_List (L) then - -- Capture the Node_Id of the first list node to be inserted. - -- This will still be the first node after the insert operation, - -- since Insert_List_After does not modify the Node_Id values. + -- Capture the Node_Id of the first list node to be inserted. This + -- will still be the first node after the insert operation, since + -- Insert_List_After does not modify the Node_Id values. Node := First (L); Insert_List_Before (N, L); @@ -1222,9 +1222,9 @@ package body Sem is Ptr : Suppress_Stack_Entry_Ptr; begin - -- First search the local entity suppress stack, we search this from the - -- top of the stack down, so that we get the innermost entry that - -- applies to this case if there are nested entries. + -- First search the local entity suppress stack. We search this from the + -- top of the stack down so that we get the innermost entry that applies + -- to this case if there are nested entries. Ptr := Local_Suppress_Stack_Top; while Ptr /= null loop @@ -1237,7 +1237,7 @@ package body Sem is Ptr := Ptr.Prev; end loop; - -- Now search the global entity suppress table for a matching entry + -- Now search the global entity suppress table for a matching entry. -- We also search this from the top down so that if there are multiple -- pragmas for the same entity, the last one applies (not clear what -- or whether the RM specifies this handling, but it seems reasonable). @@ -1327,10 +1327,10 @@ package body Sem is procedure Semantics (Comp_Unit : Node_Id) is -- The following locations save the corresponding global flags and - -- variables so that they can be restored on completion. This is - -- needed so that calls to Rtsfind start with the proper default - -- values for these variables, and also that such calls do not - -- disturb the settings for units being analyzed at a higher level. + -- variables so that they can be restored on completion. This is needed + -- so that calls to Rtsfind start with the proper default values for + -- these variables, and also that such calls do not disturb the settings + -- for units being analyzed at a higher level. S_Current_Sem_Unit : constant Unit_Number_Type := Current_Sem_Unit; S_Full_Analysis : constant Boolean := Full_Analysis; @@ -1348,12 +1348,12 @@ package body Sem is -- context, is compiled with expansion disabled. Save_Config_Switches : Config_Switches_Type; - -- Variable used to save values of config switches while we analyze - -- the new unit, to be restored on exit for proper recursive behavior. + -- Variable used to save values of config switches while we analyze the + -- new unit, to be restored on exit for proper recursive behavior. procedure Do_Analyze; - -- Procedure to analyze the compilation unit. This is called more - -- than once when the high level optimizer is activated. + -- Procedure to analyze the compilation unit. This is called more than + -- once when the high level optimizer is activated. ---------------- -- Do_Analyze -- @@ -1584,8 +1584,8 @@ package body Sem is when N_Package_Body => - -- Package bodies are processed separately if the main - -- unit depends on them. + -- Package bodies are processed separately if the main unit + -- depends on them. null; @@ -1741,8 +1741,8 @@ package body Sem is Do_Withed_Units (CU, Include_Limited => False); - -- Process the unit if it is a spec or the the main unit, if - -- it has no previous spec or we have done all other units. + -- Process the unit if it is a spec or the the main unit, if it + -- has no previous spec or we have done all other units. if not Nkind_In (Item, N_Package_Body, N_Subprogram_Body) or else Acts_As_Spec (CU) @@ -1793,9 +1793,13 @@ package body Sem is procedure Do_Withed_Units is new Walk_Withs (Do_Withed_Unit); function Depends_On_Main (CU : Node_Id) return Boolean; - -- The body of a unit that is withed by the spec of the main - -- unit may in turn have a with_clause on that spec. In that - -- case do not traverse the body, to prevent loops. + -- The body of a unit that is withed by the spec of the main unit + -- may in turn have a with_clause on that spec. In that case do not + -- traverse the body, to prevent loops. It can also happen that the + -- main body as a with_clause on a child, which of course has an + -- implicit with on its parent. It's ok to traverse the child body + -- if the main spec has been processed, otherwise we also have a + -- circularity to avoid. --------------------- -- Depends_On_Main -- @@ -1816,6 +1820,8 @@ package body Sem is while Present (CL) loop if Nkind (CL) = N_With_Clause and then Library_Unit (CL) = Library_Unit (Main_CU) + and then + not Done (Get_Cunit_Unit_Number (Library_Unit (CL))) then return True; end if; @@ -1864,7 +1870,7 @@ package body Sem is -- Local Declarations - Cur : Elmt_Id; + Cur : Elmt_Id; -- Start of processing for Walk_Library_Items @@ -1917,15 +1923,15 @@ package body Sem is -- separate spec. -- If it's a package body, ignore it, unless it is a body - -- created for an instance that is the main unit. In the - -- case of subprograms, the body is the wrapper package. In - -- case of a package, the original file carries the body, - -- and the spec appears as a later entry in the units list. + -- created for an instance that is the main unit. In the case + -- of subprograms, the body is the wrapper package. In case of + -- a package, the original file carries the body, and the spec + -- appears as a later entry in the units list. - -- Otherwise Bodies appear in the list only because of - -- inlining/instantiations, and they are processed only - -- if relevant to the main unit. The main unit itself - -- is processed separately after all other specs. + -- Otherwise Bodies appear in the list only because of inlining + -- or instantiations, and they are processed only if relevant + -- to the main unit. The main unit itself is processed + -- separately after all other specs. when N_Subprogram_Body => if Acts_As_Spec (N) then @@ -1943,7 +1949,7 @@ package body Sem is Unit (Library_Unit (Main_CU))); end if; - -- It's a spec, process it, and the units it depends on. + -- It's a spec, process it, and the units it depends on when others => Do_Unit_And_Dependents (CU, N); @@ -1953,8 +1959,8 @@ package body Sem is Next_Elmt (Cur); end loop; - -- Now process package bodies on which main depends, followed by - -- bodies of parents, if present, and finally main itself. + -- Now process package bodies on which main depends, followed by bodies + -- of parents, if present, and finally main itself. if not Done (Main_Unit) then Do_Main := True; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 764d4f6a506..e5afd0cebb8 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -12284,7 +12284,7 @@ package body Sem_Prag is elsif not Is_Static_String_Expression (Arg1) then Error_Pragma_Arg ("argument of pragma% must be On/Off or " & - "static string expression", Arg2); + "static string expression", Arg1); -- One argument string expression case @@ -12504,6 +12504,11 @@ package body Sem_Prag is raise Program_Error; end case; + -- AI05-0144: detect dangerous order dependence. Disabled for now, + -- until AI is formally approved. + + -- Check_Order_Dependence; + exception when Pragma_Exit => null; end Analyze_Pragma; |