Skip to content

R
riscv-gcc-1
Commit 6e1ee5c3 by Arnaud Charlet
Options

[multiple changes] 

2010-06-23  Thomas Quinot  <quinot@adacore.com>

	* exp_attr.adb (Expand_Access_To_Protected_Op): When rewriting a
	reference to a protected subprogram outside of the protected's scope,
	ensure the corresponding external subprogram is frozen before the
	reference.

2010-06-23  Ed Schonberg  <schonberg@adacore.com>

	* sem_prag.adb: Fix typo in error message.
	* sem.adb: Refine previous change.

2010-06-23  Robert Dewar  <dewar@adacore.com>

	* impunit.adb, a-suewen.adb, a-suewen.ads, a-suenco.adb, a-suenco.ads,
	a-suezen.adb, a-suezen.ads, a-stuten.adb, a-stuten.ads, Makefile.rtl:
	Implement Ada 2012 string encoding packages.

2010-06-23  Arnaud Charlet  <charlet@adacore.com>

	* a-stwiun-shared.adb, a-stwiun-shared.ads, a-stzunb-shared.adb,
	a-stzunb-shared.ads, a-swunau-shared.adb, a-swuwti-shared.adb,
	a-szunau-shared.adb, a-szuzti-shared.adb: New files.
	* gcc-interface/Makefile.in: Enable use of above files.

From-SVN: r161277
parent f52d94aa
Showing with 7319 additions and 1094 deletions
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) \
......
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;
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;
gcc/ada/a-stwiun-shared.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-stwiun-shared.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-stzunb-shared.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-stzunb-shared.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-suenco.adb 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-suenco.ads 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-suewen.adb 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-suewen.ads 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-suezen.adb 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-suezen.ads 0 → 100755
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-swunau-shared.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-swuwti-shared.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-szunau-shared.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/a-szuzti-shared.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
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);
......
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.
......
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 --
......
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;
......
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;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment