OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[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
This commit is contained in:
Arnaud Charlet 2010-06-23 14:44:34 +02:00
parent f52d94aad0
commit 6e1ee5c3d2
22 changed files with 7333 additions and 1108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
gcc/ada/Makefile.rtl
View File

@ -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) \

1113
gcc/ada/a-stuten.adb
View File

File diff suppressed because it is too large Load Diff

175
gcc/ada/a-stuten.ads
View File

@ -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).
-- 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.
-- 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.
-- 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.
subtype Short_Encoding is Encoding_Scheme range UTF_8 .. UTF_16LE;
subtype Long_Encoding is Encoding_Scheme range UTF_16 .. UTF_16;
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.
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.
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.
-- 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.
private
function To_Unsigned_8 is new
Unchecked_Conversion (Character, Interfaces.Unsigned_8);
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 To_Unsigned_16 is new
Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16);
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;
function To_Unsigned_32 is new
Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32);
-- 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.
subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE;
-- Subtype containing only UTF_16BE and UTF_16LE entries
Encoding_Error : exception;
-- Exception raised if an invalid encoding sequence is encountered by
-- one of the Decode routines.
-- Utility routines for converting between UTF-16 and UTF-16LE/BE
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 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 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;
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.
-- 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;
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;

2106
gcc/ada/a-stwiun-shared.adb Normal file
View File

File diff suppressed because it is too large Load Diff

483
gcc/ada/a-stwiun-shared.ads Normal file
View File

@ -0,0 +1,483 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R I N G S . W I D E _ U N B O U N D E D --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version is supported on:
-- - all Alpha platforms
-- - all ia64 platforms
-- - all PowerPC platforms
-- - all SPARC V9 platforms
-- - all x86_64 platforms
with Ada.Strings.Wide_Maps;
private with Ada.Finalization;
private with Interfaces;
package Ada.Strings.Wide_Unbounded is
pragma Preelaborate;
type Unbounded_Wide_String is private;
pragma Preelaborable_Initialization (Unbounded_Wide_String);
Null_Unbounded_Wide_String : constant Unbounded_Wide_String;
function Length (Source : Unbounded_Wide_String) return Natural;
type Wide_String_Access is access all Wide_String;
procedure Free (X : in out Wide_String_Access);
--------------------------------------------------------
-- Conversion, Concatenation, and Selection Functions --
--------------------------------------------------------
function To_Unbounded_Wide_String
(Source : Wide_String) return Unbounded_Wide_String;
function To_Unbounded_Wide_String
(Length : Natural) return Unbounded_Wide_String;
function To_Wide_String
(Source : Unbounded_Wide_String) return Wide_String;
procedure Set_Unbounded_Wide_String
(Target : out Unbounded_Wide_String;
Source : Wide_String);
pragma Ada_05 (Set_Unbounded_Wide_String);
procedure Append
(Source : in out Unbounded_Wide_String;
New_Item : Unbounded_Wide_String);
procedure Append
(Source : in out Unbounded_Wide_String;
New_Item : Wide_String);
procedure Append
(Source : in out Unbounded_Wide_String;
New_Item : Wide_Character);
function "&"
(Left : Unbounded_Wide_String;
Right : Unbounded_Wide_String) return Unbounded_Wide_String;
function "&"
(Left : Unbounded_Wide_String;
Right : Wide_String) return Unbounded_Wide_String;
function "&"
(Left : Wide_String;
Right : Unbounded_Wide_String) return Unbounded_Wide_String;
function "&"
(Left : Unbounded_Wide_String;
Right : Wide_Character) return Unbounded_Wide_String;
function "&"
(Left : Wide_Character;
Right : Unbounded_Wide_String) return Unbounded_Wide_String;
function Element
(Source : Unbounded_Wide_String;
Index : Positive) return Wide_Character;
procedure Replace_Element
(Source : in out Unbounded_Wide_String;
Index : Positive;
By : Wide_Character);
function Slice
(Source : Unbounded_Wide_String;
Low : Positive;
High : Natural) return Wide_String;
function Unbounded_Slice
(Source : Unbounded_Wide_String;
Low : Positive;
High : Natural) return Unbounded_Wide_String;
pragma Ada_05 (Unbounded_Slice);
procedure Unbounded_Slice
(Source : Unbounded_Wide_String;
Target : out Unbounded_Wide_String;
Low : Positive;
High : Natural);
pragma Ada_05 (Unbounded_Slice);
function "="
(Left : Unbounded_Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function "="
(Left : Unbounded_Wide_String;
Right : Wide_String) return Boolean;
function "="
(Left : Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function "<"
(Left : Unbounded_Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function "<"
(Left : Unbounded_Wide_String;
Right : Wide_String) return Boolean;
function "<"
(Left : Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function "<="
(Left : Unbounded_Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function "<="
(Left : Unbounded_Wide_String;
Right : Wide_String) return Boolean;
function "<="
(Left : Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function ">"
(Left : Unbounded_Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function ">"
(Left : Unbounded_Wide_String;
Right : Wide_String) return Boolean;
function ">"
(Left : Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function ">="
(Left : Unbounded_Wide_String;
Right : Unbounded_Wide_String) return Boolean;
function ">="
(Left : Unbounded_Wide_String;
Right : Wide_String) return Boolean;
function ">="
(Left : Wide_String;
Right : Unbounded_Wide_String) return Boolean;
------------------------
-- Search Subprograms --
------------------------
function Index
(Source : Unbounded_Wide_String;
Pattern : Wide_String;
Going : Direction := Forward;
Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
return Natural;
function Index
(Source : Unbounded_Wide_String;
Pattern : Wide_String;
Going : Direction := Forward;
Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
function Index
(Source : Unbounded_Wide_String;
Set : Wide_Maps.Wide_Character_Set;
Test : Membership := Inside;
Going : Direction := Forward) return Natural;
function Index
(Source : Unbounded_Wide_String;
Pattern : Wide_String;
From : Positive;
Going : Direction := Forward;
Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
return Natural;
pragma Ada_05 (Index);
function Index
(Source : Unbounded_Wide_String;
Pattern : Wide_String;
From : Positive;
Going : Direction := Forward;
Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
pragma Ada_05 (Index);
function Index
(Source : Unbounded_Wide_String;
Set : Wide_Maps.Wide_Character_Set;
From : Positive;
Test : Membership := Inside;
Going : Direction := Forward) return Natural;
pragma Ada_05 (Index);
function Index_Non_Blank
(Source : Unbounded_Wide_String;
Going : Direction := Forward) return Natural;
function Index_Non_Blank
(Source : Unbounded_Wide_String;
From : Positive;
Going : Direction := Forward) return Natural;
pragma Ada_05 (Index_Non_Blank);
function Count
(Source : Unbounded_Wide_String;
Pattern : Wide_String;
Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity)
return Natural;
function Count
(Source : Unbounded_Wide_String;
Pattern : Wide_String;
Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural;
function Count
(Source : Unbounded_Wide_String;
Set : Wide_Maps.Wide_Character_Set) return Natural;
procedure Find_Token
(Source : Unbounded_Wide_String;
Set : Wide_Maps.Wide_Character_Set;
Test : Membership;
First : out Positive;
Last : out Natural);
------------------------------------
-- String Translation Subprograms --
------------------------------------
function Translate
(Source : Unbounded_Wide_String;
Mapping : Wide_Maps.Wide_Character_Mapping)
return Unbounded_Wide_String;
procedure Translate
(Source : in out Unbounded_Wide_String;
Mapping : Wide_Maps.Wide_Character_Mapping);
function Translate
(Source : Unbounded_Wide_String;
Mapping : Wide_Maps.Wide_Character_Mapping_Function)
return Unbounded_Wide_String;
procedure Translate
(Source : in out Unbounded_Wide_String;
Mapping : Wide_Maps.Wide_Character_Mapping_Function);
---------------------------------------
-- String Transformation Subprograms --
---------------------------------------
function Replace_Slice
(Source : Unbounded_Wide_String;
Low : Positive;
High : Natural;
By : Wide_String) return Unbounded_Wide_String;
procedure Replace_Slice
(Source : in out Unbounded_Wide_String;
Low : Positive;
High : Natural;
By : Wide_String);
function Insert
(Source : Unbounded_Wide_String;
Before : Positive;
New_Item : Wide_String) return Unbounded_Wide_String;
procedure Insert
(Source : in out Unbounded_Wide_String;
Before : Positive;
New_Item : Wide_String);
function Overwrite
(Source : Unbounded_Wide_String;
Position : Positive;
New_Item : Wide_String) return Unbounded_Wide_String;
procedure Overwrite
(Source : in out Unbounded_Wide_String;
Position : Positive;
New_Item : Wide_String);
function Delete
(Source : Unbounded_Wide_String;
From : Positive;
Through : Natural) return Unbounded_Wide_String;
procedure Delete
(Source : in out Unbounded_Wide_String;
From : Positive;
Through : Natural);
function Trim
(Source : Unbounded_Wide_String;
Side : Trim_End) return Unbounded_Wide_String;
procedure Trim
(Source : in out Unbounded_Wide_String;
Side : Trim_End);
function Trim
(Source : Unbounded_Wide_String;
Left : Wide_Maps.Wide_Character_Set;
Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String;
procedure Trim
(Source : in out Unbounded_Wide_String;
Left : Wide_Maps.Wide_Character_Set;
Right : Wide_Maps.Wide_Character_Set);
function Head
(Source : Unbounded_Wide_String;
Count : Natural;
Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String;
procedure Head
(Source : in out Unbounded_Wide_String;
Count : Natural;
Pad : Wide_Character := Wide_Space);
function Tail
(Source : Unbounded_Wide_String;
Count : Natural;
Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String;
procedure Tail
(Source : in out Unbounded_Wide_String;
Count : Natural;
Pad : Wide_Character := Wide_Space);
function "*"
(Left : Natural;
Right : Wide_Character) return Unbounded_Wide_String;
function "*"
(Left : Natural;
Right : Wide_String) return Unbounded_Wide_String;
function "*"
(Left : Natural;
Right : Unbounded_Wide_String) return Unbounded_Wide_String;
private
pragma Inline (Length);
package AF renames Ada.Finalization;
type Shared_Wide_String (Max_Length : Natural) is limited record
Counter : aliased Interfaces.Unsigned_32 := 1;
-- Reference counter.
Last : Natural := 0;
Data : Wide_String (1 .. Max_Length);
-- Last is the index of last significant element of the Data. All
-- elements with larger indecies are just an extra room.
end record;
type Shared_Wide_String_Access is access all Shared_Wide_String;
procedure Reference (Item : not null Shared_Wide_String_Access);
-- Increment reference counter.
procedure Unreference (Item : not null Shared_Wide_String_Access);
-- Decrement reference counter. Deallocate Item when reference counter is
-- zero.
function Can_Be_Reused
(Item : Shared_Wide_String_Access;
Length : Natural) return Boolean;
-- Returns True if Shared_Wide_String can be reused. There are two criteria
-- when Shared_Wide_String can be reused: its reference counter must be one
-- (thus Shared_Wide_String is owned exclusively) and its size is
-- sufficient to store string with specified length effectively.
function Allocate (Max_Length : Natural) return Shared_Wide_String_Access;
-- Allocates new Shared_Wide_String with at least specified maximum length.
-- Actual maximum length of the allocated Shared_Wide_String can be sligtly
-- greater. Returns reference to Empty_Shared_Wide_String when requested
-- length is zero.
Empty_Shared_Wide_String : aliased Shared_Wide_String (0);
function To_Unbounded (S : Wide_String) return Unbounded_Wide_String
renames To_Unbounded_Wide_String;
-- This renames are here only to be used in the pragma Stream_Convert.
type Unbounded_Wide_String is new AF.Controlled with record
Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access;
end record;
-- The Unbounded_Wide_String uses several techniques to increasy speed of
-- the application:
-- - implicit sharing or copy-on-write. Unbounded_Wide_String contains
-- only the reference to the data which is shared between several
-- instances. The shared data is reallocated only when its value is
-- changed and the object mutation can't be used or it is unefficient to
-- use it;
-- - object mutation. Shared data object can be reused without memory
-- reallocation when all of the following requirements are meat:
-- - shared data object don't used anywhere longer;
-- - its size is sufficient to store new value;
-- - the gap after reuse is less then some threashold.
-- - memory preallocation. Most of used memory allocation algorithms
-- alligns allocated segment on the some boundary, thus some amount of
-- additional memory can be preallocated without any impact. Such
-- preallocated memory can used later by Append/Insert operations
-- without reallocation.
--
-- Reference counting uses GCC builtin atomic operations, which allows to
-- safely share internal data between Ada tasks. Nevertheless, this not
-- make objects of Unbounded_Wide_String thread-safe, so each instance
-- can't be accessed by several tasks simulatenously.
pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String);
-- Provide stream routines without dragging in Ada.Streams
pragma Finalize_Storage_Only (Unbounded_Wide_String);
-- Finalization is required only for freeing storage
overriding procedure Initialize (Object : in out Unbounded_Wide_String);
overriding procedure Adjust (Object : in out Unbounded_Wide_String);
overriding procedure Finalize (Object : in out Unbounded_Wide_String);
Null_Unbounded_Wide_String : constant Unbounded_Wide_String :=
(AF.Controlled with
Reference => Empty_Shared_Wide_String'Access);
end Ada.Strings.Wide_Unbounded;

2120
gcc/ada/a-stzunb-shared.adb Normal file
View File

File diff suppressed because it is too large Load Diff

501
gcc/ada/a-stzunb-shared.ads Normal file
View File

@ -0,0 +1,501 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D --
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
-- apply solely to the contents of the part following the private keyword. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This version is supported on:
-- - all Alpha platforms
-- - all ia64 platforms
-- - all PowerPC platforms
-- - all SPARC V9 platforms
-- - all x86_64 platforms
with Ada.Strings.Wide_Wide_Maps;
private with Ada.Finalization;
private with Interfaces;
package Ada.Strings.Wide_Wide_Unbounded is
pragma Preelaborate;
type Unbounded_Wide_Wide_String is private;
pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String);
Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String;
function Length (Source : Unbounded_Wide_Wide_String) return Natural;
type Wide_Wide_String_Access is access all Wide_Wide_String;
procedure Free (X : in out Wide_Wide_String_Access);
--------------------------------------------------------
-- Conversion, Concatenation, and Selection Functions --
--------------------------------------------------------
function To_Unbounded_Wide_Wide_String
(Source : Wide_Wide_String) return Unbounded_Wide_Wide_String;
function To_Unbounded_Wide_Wide_String
(Length : Natural) return Unbounded_Wide_Wide_String;
function To_Wide_Wide_String
(Source : Unbounded_Wide_Wide_String) return Wide_Wide_String;
procedure Set_Unbounded_Wide_Wide_String
(Target : out Unbounded_Wide_Wide_String;
Source : Wide_Wide_String);
pragma Ada_05 (Set_Unbounded_Wide_Wide_String);
procedure Append
(Source : in out Unbounded_Wide_Wide_String;
New_Item : Unbounded_Wide_Wide_String);
procedure Append
(Source : in out Unbounded_Wide_Wide_String;
New_Item : Wide_Wide_String);
procedure Append
(Source : in out Unbounded_Wide_Wide_String;
New_Item : Wide_Wide_Character);
function "&"
(Left : Unbounded_Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
function "&"
(Left : Unbounded_Wide_Wide_String;
Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
function "&"
(Left : Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
function "&"
(Left : Unbounded_Wide_Wide_String;
Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
function "&"
(Left : Wide_Wide_Character;
Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
function Element
(Source : Unbounded_Wide_Wide_String;
Index : Positive) return Wide_Wide_Character;
procedure Replace_Element
(Source : in out Unbounded_Wide_Wide_String;
Index : Positive;
By : Wide_Wide_Character);
function Slice
(Source : Unbounded_Wide_Wide_String;
Low : Positive;
High : Natural) return Wide_Wide_String;
function Unbounded_Slice
(Source : Unbounded_Wide_Wide_String;
Low : Positive;
High : Natural) return Unbounded_Wide_Wide_String;
pragma Ada_05 (Unbounded_Slice);
procedure Unbounded_Slice
(Source : Unbounded_Wide_Wide_String;
Target : out Unbounded_Wide_Wide_String;
Low : Positive;
High : Natural);
pragma Ada_05 (Unbounded_Slice);
function "="
(Left : Unbounded_Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function "="
(Left : Unbounded_Wide_Wide_String;
Right : Wide_Wide_String) return Boolean;
function "="
(Left : Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function "<"
(Left : Unbounded_Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function "<"
(Left : Unbounded_Wide_Wide_String;
Right : Wide_Wide_String) return Boolean;
function "<"
(Left : Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function "<="
(Left : Unbounded_Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function "<="
(Left : Unbounded_Wide_Wide_String;
Right : Wide_Wide_String) return Boolean;
function "<="
(Left : Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function ">"
(Left : Unbounded_Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function ">"
(Left : Unbounded_Wide_Wide_String;
Right : Wide_Wide_String) return Boolean;
function ">"
(Left : Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function ">="
(Left : Unbounded_Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
function ">="
(Left : Unbounded_Wide_Wide_String;
Right : Wide_Wide_String) return Boolean;
function ">="
(Left : Wide_Wide_String;
Right : Unbounded_Wide_Wide_String) return Boolean;
------------------------
-- Search Subprograms --
------------------------
function Index
(Source : Unbounded_Wide_Wide_String;
Pattern : Wide_Wide_String;
Going : Direction := Forward;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
Wide_Wide_Maps.Identity)
return Natural;
function Index
(Source : Unbounded_Wide_Wide_String;
Pattern : Wide_Wide_String;
Going : Direction := Forward;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
return Natural;
function Index
(Source : Unbounded_Wide_Wide_String;
Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
Test : Membership := Inside;
Going : Direction := Forward) return Natural;
function Index
(Source : Unbounded_Wide_Wide_String;
Pattern : Wide_Wide_String;
From : Positive;
Going : Direction := Forward;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
Wide_Wide_Maps.Identity)
return Natural;
pragma Ada_05 (Index);
function Index
(Source : Unbounded_Wide_Wide_String;
Pattern : Wide_Wide_String;
From : Positive;
Going : Direction := Forward;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
return Natural;
pragma Ada_05 (Index);
function Index
(Source : Unbounded_Wide_Wide_String;
Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
From : Positive;
Test : Membership := Inside;
Going : Direction := Forward) return Natural;
pragma Ada_05 (Index);
function Index_Non_Blank
(Source : Unbounded_Wide_Wide_String;
Going : Direction := Forward) return Natural;
function Index_Non_Blank
(Source : Unbounded_Wide_Wide_String;
From : Positive;
Going : Direction := Forward) return Natural;
pragma Ada_05 (Index_Non_Blank);
function Count
(Source : Unbounded_Wide_Wide_String;
Pattern : Wide_Wide_String;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping :=
Wide_Wide_Maps.Identity)
return Natural;
function Count
(Source : Unbounded_Wide_Wide_String;
Pattern : Wide_Wide_String;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
return Natural;
function Count
(Source : Unbounded_Wide_Wide_String;
Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural;
procedure Find_Token
(Source : Unbounded_Wide_Wide_String;
Set : Wide_Wide_Maps.Wide_Wide_Character_Set;
Test : Membership;
First : out Positive;
Last : out Natural);
------------------------------------
-- String Translation Subprograms --
------------------------------------
function Translate
(Source : Unbounded_Wide_Wide_String;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping)
return Unbounded_Wide_Wide_String;
procedure Translate
(Source : in out Unbounded_Wide_Wide_String;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping);
function Translate
(Source : Unbounded_Wide_Wide_String;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function)
return Unbounded_Wide_Wide_String;
procedure Translate
(Source : in out Unbounded_Wide_Wide_String;
Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function);
---------------------------------------
-- String Transformation Subprograms --
---------------------------------------
function Replace_Slice
(Source : Unbounded_Wide_Wide_String;
Low : Positive;
High : Natural;
By : Wide_Wide_String) return Unbounded_Wide_Wide_String;
procedure Replace_Slice
(Source : in out Unbounded_Wide_Wide_String;
Low : Positive;
High : Natural;
By : Wide_Wide_String);
function Insert
(Source : Unbounded_Wide_Wide_String;
Before : Positive;
New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
procedure Insert
(Source : in out Unbounded_Wide_Wide_String;
Before : Positive;
New_Item : Wide_Wide_String);
function Overwrite
(Source : Unbounded_Wide_Wide_String;
Position : Positive;
New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String;
procedure Overwrite
(Source : in out Unbounded_Wide_Wide_String;
Position : Positive;
New_Item : Wide_Wide_String);
function Delete
(Source : Unbounded_Wide_Wide_String;
From : Positive;
Through : Natural) return Unbounded_Wide_Wide_String;
procedure Delete
(Source : in out Unbounded_Wide_Wide_String;
From : Positive;
Through : Natural);
function Trim
(Source : Unbounded_Wide_Wide_String;
Side : Trim_End) return Unbounded_Wide_Wide_String;
procedure Trim
(Source : in out Unbounded_Wide_Wide_String;
Side : Trim_End);
function Trim
(Source : Unbounded_Wide_Wide_String;
Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
Right : Wide_Wide_Maps.Wide_Wide_Character_Set)
return Unbounded_Wide_Wide_String;
procedure Trim
(Source : in out Unbounded_Wide_Wide_String;
Left : Wide_Wide_Maps.Wide_Wide_Character_Set;
Right : Wide_Wide_Maps.Wide_Wide_Character_Set);
function Head
(Source : Unbounded_Wide_Wide_String;
Count : Natural;
Pad : Wide_Wide_Character := Wide_Wide_Space)
return Unbounded_Wide_Wide_String;
procedure Head
(Source : in out Unbounded_Wide_Wide_String;
Count : Natural;
Pad : Wide_Wide_Character := Wide_Wide_Space);
function Tail
(Source : Unbounded_Wide_Wide_String;
Count : Natural;
Pad : Wide_Wide_Character := Wide_Wide_Space)
return Unbounded_Wide_Wide_String;
procedure Tail
(Source : in out Unbounded_Wide_Wide_String;
Count : Natural;
Pad : Wide_Wide_Character := Wide_Wide_Space);
function "*"
(Left : Natural;
Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String;
function "*"
(Left : Natural;
Right : Wide_Wide_String) return Unbounded_Wide_Wide_String;
function "*"
(Left : Natural;
Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String;
private
pragma Inline (Length);
package AF renames Ada.Finalization;
type Shared_Wide_Wide_String (Max_Length : Natural) is limited record
Counter : aliased Interfaces.Unsigned_32 := 1;
-- Reference counter.
Last : Natural := 0;
Data : Wide_Wide_String (1 .. Max_Length);
-- Last is the index of last significant element of the Data. All
-- elements with larger indecies are just an extra room.
end record;
type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String;
procedure Reference (Item : not null Shared_Wide_Wide_String_Access);
-- Increment reference counter.
procedure Unreference (Item : not null Shared_Wide_Wide_String_Access);
-- Decrement reference counter. Deallocate Item when reference counter is
-- zero.
function Can_Be_Reused
(Item : Shared_Wide_Wide_String_Access;
Length : Natural) return Boolean;
-- Returns True if Shared_Wide_Wide_String can be reused. There are two
-- criteria when Shared_Wide_Wide_String can be reused: its reference
-- counter must be one (thus Shared_Wide_Wide_String is owned exclusively)
-- and its size is sufficient to store string with specified length
-- effectively.
function Allocate
(Max_Length : Natural) return Shared_Wide_Wide_String_Access;
-- Allocates new Shared_Wide_Wide_String with at least specified maximum
-- length. Actual maximum length of the allocated Shared_Wide_Wide_String
-- can be sligtly greater. Returns reference to
-- Empty_Shared_Wide_Wide_String when requested length is zero.
Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0);
function To_Unbounded
(S : Wide_Wide_String) return Unbounded_Wide_Wide_String
renames To_Unbounded_Wide_Wide_String;
-- This renames are here only to be used in the pragma Stream_Convert.
type Unbounded_Wide_Wide_String is new AF.Controlled with record
Reference : Shared_Wide_Wide_String_Access :=
Empty_Shared_Wide_Wide_String'Access;
end record;
-- The Unbounded_Wide_Wide_String uses several techniques to increasy speed
-- of the application:
-- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String
-- contains only the reference to the data which is shared between
-- several instances. The shared data is reallocated only when its value
-- is changed and the object mutation can't be used or it is unefficient
-- to use it;
-- - object mutation. Shared data object can be reused without memory
-- reallocation when all of the following requirements are meat:
-- - shared data object don't used anywhere longer;
-- - its size is sufficient to store new value;
-- - the gap after reuse is less then some threashold.
-- - memory preallocation. Most of used memory allocation algorithms
-- alligns allocated segment on the some boundary, thus some amount of
-- additional memory can be preallocated without any impact. Such
-- preallocated memory can used later by Append/Insert operations
-- without reallocation.
--
-- Reference counting uses GCC builtin atomic operations, which allows to
-- safely share internal data between Ada tasks. Nevertheless, this not
-- make objects of Unbounded_Wide_Wide_String thread-safe, so each instance
-- can't be accessed by several tasks simulatenously.
pragma Stream_Convert
(Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String);
-- Provide stream routines without dragging in Ada.Streams
pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String);
-- Finalization is required only for freeing storage
overriding procedure Initialize
(Object : in out Unbounded_Wide_Wide_String);
overriding procedure Adjust
(Object : in out Unbounded_Wide_Wide_String);
overriding procedure Finalize
(Object : in out Unbounded_Wide_Wide_String);
Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String :=
(AF.Controlled with
Reference =>
Empty_Shared_Wide_Wide_String'Access);
end Ada.Strings.Wide_Wide_Unbounded;

390
gcc/ada/a-suenco.adb Executable file
View File

@ -0,0 +1,390 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Ada.Strings.UTF_Encoding.Conversions is
use Interfaces;
-- Version convertion from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE
function Convert
(Item : UTF_String;
Input_Scheme : Encoding_Scheme;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String
is
begin
-- Nothing to do if identical schemes
if Input_Scheme = Output_Scheme then
return Item;
-- For remaining cases, one or other of the operands is UTF-16BE/LE
-- encoded, so go through UTF-16 intermediate.
else
return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)),
Output_Scheme, Output_BOM);
end if;
end Convert;
-- Version converting UTF-8/UTF-16BE/LE to UTF-16
function Convert
(Item : UTF_String;
Input_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_16_Wide_String
is
begin
if Input_Scheme = UTF_8 then
return Convert (Item, Output_BOM);
else
return To_UTF_16 (Item, Input_Scheme, Output_BOM);
end if;
end Convert;
-- Version converting UTF-8 to UTF-16
function Convert
(Item : UTF_8_String;
Output_BOM : Boolean := False) return UTF_16_Wide_String
is
Result : UTF_16_Wide_String (1 .. Item'Length + 1);
-- Maximum length of result, including possible BOM
Len : Natural := 0;
-- Number of characters stored so far in Result
Iptr : Natural;
-- Next character to process in Item
C : Unsigned_8;
-- Input UTF-8 code
R : Unsigned_16;
-- Output UTF-16 code
procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On
-- return Ptr is incremented. Raises exceptioon if continuation
-- byte does not exist or is invalid.
----------------------
-- Get_Continuation --
----------------------
procedure Get_Continuation is
begin
if Iptr > Item'Last then
Raise_Encoding_Error (Iptr - 1);
else
C := To_Unsigned_8 (Item (Iptr));
Iptr := Iptr + 1;
if C < 2#10_000000# or else C > 2#10_111111# then
Raise_Encoding_Error (Iptr - 1);
else
R := Shift_Left (R, 6) or
Unsigned_16 (C and 2#00_111111#);
end if;
end if;
end Get_Continuation;
-- Start of processing for Convert
begin
-- Output BOM if required
if Output_BOM then
Len := Len + 1;
Result (Len) := BOM_16 (1);
end if;
-- Skip OK BOM
Iptr := Item'First;
if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then
Iptr := Iptr + 3;
-- Error if bad BOM
elsif Item'Length >= 2
and then (Item (Iptr .. Iptr + 1) = BOM_16BE
or else
Item (Iptr .. Iptr + 1) = BOM_16LE)
then
Raise_Encoding_Error (Iptr);
-- No BOM present
else
Iptr := Item'First;
end if;
while Iptr <= Item'Last loop
C := To_Unsigned_8 (Item (Iptr));
Iptr := Iptr + 1;
-- Codes in the range 16#00# - 16#7F#
-- UTF-8: 0xxxxxxx
-- UTF-16: 00000000_0xxxxxxx
if C <= 16#7F# then
Len := Len + 1;
Result (Len) := Wide_Character'Val (C);
-- No initial code can be of the form 10xxxxxx. Such codes are used
-- only for continuations.
elsif C <= 2#10_111111# then
Raise_Encoding_Error (Iptr - 1);
-- Codes in the range 16#80# - 16#7FF#
-- UTF-8: 110yyyxx 10xxxxxx
-- UTF-16: 00000yyy_xxxxxxxx
elsif C <= 2#110_11111# then
R := Unsigned_16 (C and 2#000_11111#);
Get_Continuation;
Len := Len + 1;
Result (Len) := Wide_Character'Val (R);
-- Codes in the range 16#800# - 16#FFFF#
-- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx
-- UTF-16: yyyyyyyy_xxxxxxxx
elsif C <= 2#1110_1111# then
R := Unsigned_16 (C and 2#0000_1111#);
Get_Continuation;
Get_Continuation;
Len := Len + 1;
Result (Len) := Wide_Character'Val (R);
-- Make sure that we don't have a result in the forbidden range
-- reserved for UTF-16 surrogate characters.
if R in 16#D800# .. 16#DF00# then
Raise_Encoding_Error (Iptr - 3);
end if;
-- Codes in the range 16#10000# - 16#10FFFF#
-- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
-- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx
-- Note: zzzz in the output is input zzzzz - 1
elsif C <= 2#11110_111# then
R := Unsigned_16 (C and 2#00000_111#);
Get_Continuation;
-- R now has zzzzzyyyy
R := R - 2#0000_1_0000#;
-- R now has zzzzyyyy (zzzz minus one for the output)
Get_Continuation;
-- R now has zzzzyyyyyyyyxx
Len := Len + 1;
Result (Len) :=
Wide_Character'Val
(2#110110_00_0000_0000# or Shift_Right (R, 4));
R := R and 2#1111#;
Get_Continuation;
Len := Len + 1;
Result (Len) :=
Wide_Character'Val (2#110111_00_0000_0000# or R);
-- Any other code is an error
else
Raise_Encoding_Error (Iptr - 1);
end if;
end loop;
return Result (1 .. Len);
end Convert;
-- Convert from UTF-16 to UTF-8/UTF-16-BE/LE
function Convert
(Item : UTF_16_Wide_String;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String
is
begin
if Output_Scheme = UTF_8 then
return Convert (Item, Output_BOM);
else
return From_UTF_16 (Item, Output_Scheme, Output_BOM);
end if;
end Convert;
-- Convert from UTF-16 to UTF-8
function Convert
(Item : UTF_16_Wide_String;
Output_BOM : Boolean := False) return UTF_8_String
is
Result : UTF_8_String (1 .. 3 * Item'Length + 3);
-- Worst case is 3 output codes for each input code + BOM space
Len : Natural;
-- Number of result codes stored
Iptr : Natural;
-- Pointer to next input character
C1, C2 : Unsigned_16;
zzzzz : Unsigned_16;
yyyyyyyy : Unsigned_16;
xxxxxxxx : Unsigned_16;
-- Components of double length case
begin
Iptr := Item'First;
-- Skip BOM at start of input
if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then
Iptr := Iptr + 1;
end if;
-- Generate output BOM if required
if Output_BOM then
Result (1 .. 3) := BOM_8;
Len := 3;
else
Len := 0;
end if;
-- Loop through input
while Iptr <= Item'Last loop
C1 := To_Unsigned_16 (Item (Iptr));
Iptr := Iptr + 1;
-- Codes in the range 16#0000# - 16#007F#
-- UTF-16: 000000000xxxxxxx
-- UTF-8: 0xxxxxxx
if C1 <= 16#007F# then
Result (Len + 1) := Character'Val (C1);
Len := Len + 1;
-- Codes in the range 16#80# - 16#7FF#
-- UTF-16: 00000yyyxxxxxxxx
-- UTF-8: 110yyyxx 10xxxxxx
elsif C1 <= 16#07FF# then
Result (Len + 1) :=
Character'Val
(2#110_000000# or Shift_Right (C1, 6));
Result (Len + 2) :=
Character'Val
(2#10_000000# or (C1 and 2#00_111111#));
Len := Len + 2;
-- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF#
-- UTF-16: yyyyyyyyxxxxxxxx
-- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx
elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then
Result (Len + 1) :=
Character'Val
(2#1110_0000# or Shift_Right (C1, 12));
Result (Len + 2) :=
Character'Val
(2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#));
Result (Len + 3) :=
Character'Val
(2#10_000000# or (C1 and 2#00_111111#));
Len := Len + 3;
-- Codes in the range 16#10000# - 16#10FFFF#
-- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx
-- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
-- Note: zzzzz in the output is input zzzz + 1
elsif C1 <= 2#110110_11_11111111# then
if Iptr > Item'Last then
Raise_Encoding_Error (Iptr - 1);
else
C2 := To_Unsigned_16 (Item (Iptr));
Iptr := Iptr + 1;
end if;
if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then
Raise_Encoding_Error (Iptr - 1);
end if;
zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1;
yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#)
or
(Shift_Right (C2, 8) and 2#000000_11#));
xxxxxxxx := C2 and 2#11111111#;
Result (Len + 1) :=
Character'Val
(2#11110_000# or (Shift_Right (zzzzz, 2)));
Result (Len + 2) :=
Character'Val
(2#10_000000# or Shift_Left (zzzzz and 2#11#, 4)
or Shift_Right (yyyyyyyy, 4));
Result (Len + 3) :=
Character'Val
(2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4)
or Shift_Right (xxxxxxxx, 6));
Result (Len + 4) :=
Character'Val
(2#10_000000# or (xxxxxxxx and 2#00_111111#));
Len := Len + 4;
-- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st)
else
Raise_Encoding_Error (Iptr - 2);
end if;
end loop;
return Result (1 .. Len);
end Convert;
end Ada.Strings.UTF_Encoding.Conversions;

61
gcc/ada/a-suenco.ads Executable file
View File

@ -0,0 +1,61 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS --
-- --
-- S p e c --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- This is an Ada 2012 package defined in AI05-0137-1. It provides conversions
-- from one UTF encoding method to another. Note: this package is consistent
-- with Ada 95, and may be used in Ada 95 or Ada 2005 mode.
package Ada.Strings.UTF_Encoding.Conversions is
pragma Pure (Conversions);
-- In the following conversion routines, a BOM in the input that matches
-- the encoding scheme is ignored, an incorrect BOM causes Encoding_Error
-- to be raised. A BOM is present in the output if the Output_BOM parameter
-- is set to True.
function Convert
(Item : UTF_String;
Input_Scheme : Encoding_Scheme;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String;
-- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified
-- by the Input_Scheme argument, and generate an output encoded in one of
-- these three schemes as specified by the Output_Scheme argument.
function Convert
(Item : UTF_String;
Input_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_16_Wide_String;
-- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified
-- by the Input_Scheme argument, and generate an output encoded in UTF-16.
function Convert
(Item : UTF_8_String;
Output_BOM : Boolean := False) return UTF_16_Wide_String;
-- Convert from UTF-8 to UTF-16
function Convert
(Item : UTF_16_Wide_String;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String;
-- Convert from UTF-16 to UTF-8, UTF-16LE, or UTF-16BE as specified by
-- the Output_Scheme argument.
function Convert
(Item : UTF_16_Wide_String;
Output_BOM : Boolean := False) return UTF_8_String;
-- Convert from UTF-16 to UTF-8
end Ada.Strings.UTF_Encoding.Conversions;

371
gcc/ada/a-suewen.adb Executable file
View File

@ -0,0 +1,371 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Ada.Strings.UTF_Encoding.Wide_Encoding is
use Interfaces;
------------
-- Decode --
------------
-- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_String
function Decode
(Item : UTF_String;
Input_Scheme : Encoding_Scheme) return Wide_String
is
begin
if Input_Scheme = UTF_8 then
return Decode (Item);
else
return Decode (To_UTF_16 (Item, Input_Scheme));
end if;
end Decode;
-- Decode UTF-8 input to Wide_String
function Decode (Item : UTF_8_String) return Wide_String is
Result : Wide_String (1 .. Item'Length);
-- Result string (worst case is same length as input)
Len : Natural := 0;
-- Length of result stored so far
Iptr : Natural;
-- Input Item pointer
C : Unsigned_8;
R : Unsigned_16;
procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On
-- return Ptr is incremented. Raises exceptioon if continuation
-- byte does not exist or is invalid.
----------------------
-- Get_Continuation --
----------------------
procedure Get_Continuation is
begin
if Iptr > Item'Last then
Raise_Encoding_Error (Iptr - 1);
else
C := To_Unsigned_8 (Item (Iptr));
Iptr := Iptr + 1;
if C not in 2#10_000000# .. 2#10_111111# then
Raise_Encoding_Error (Iptr - 1);
else
R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#);
end if;
end if;
end Get_Continuation;
-- Start of processing for Decode
begin
Iptr := Item'First;
-- Skip BOM at start
if Item'Length >= 3
and then Item (Iptr .. Iptr + 2) = BOM_8
then
Iptr := Iptr + 3;
-- Error if bad BOM
elsif Item'Length >= 2
and then (Item (Iptr .. Iptr + 1) = BOM_16BE
or else
Item (Iptr .. Iptr + 1) = BOM_16LE)
then
Raise_Encoding_Error (Iptr);
end if;
while Iptr <= Item'Last loop
C := To_Unsigned_8 (Item (Iptr));
Iptr := Iptr + 1;
-- Codes in the range 16#00# - 16#7F# are represented as
-- 0xxxxxxx
if C <= 16#7F# then
R := Unsigned_16 (C);
-- No initial code can be of the form 10xxxxxx. Such codes are used
-- only for continuations.
elsif C <= 2#10_111111# then
Raise_Encoding_Error (Iptr - 1);
-- Codes in the range 16#80# - 16#7FF# are represented as
-- 110yyyxx 10xxxxxx
elsif C <= 2#110_11111# then
R := Unsigned_16 (C and 2#000_11111#);
Get_Continuation;
-- Codes in the range 16#800# - 16#FFFF# are represented as
-- 1110yyyy 10yyyyxx 10xxxxxx
elsif C <= 2#1110_1111# then
R := Unsigned_16 (C and 2#0000_1111#);
Get_Continuation;
Get_Continuation;
-- Codes in the range 16#10000# - 16#10FFFF# are represented as
-- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
-- Such codes are out of range for Wide_String output
else
Raise_Encoding_Error (Iptr - 1);
end if;
Len := Len + 1;
Result (Len) := Wide_Character'Val (R);
end loop;
return Result (1 .. Len);
end Decode;
-- Decode UTF-16 input to Wide_String
function Decode (Item : UTF_16_Wide_String) return Wide_String is
Result : Wide_String (1 .. Item'Length);
-- Result is same length as input (possibly minus 1 if BOM present)
Len : Natural := 0;
-- Length of result
Iptr : Natural;
-- Index of next Item element
C : Unsigned_16;
begin
-- Skip UTF-16 BOM at start
Iptr := Item'First;
if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then
Iptr := Iptr + 1;
end if;
-- Loop through input characters
while Iptr <= Item'Last loop
C := To_Unsigned_16 (Item (Iptr));
Iptr := Iptr + 1;
-- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD#
-- represent their own value.
if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then
Len := Len + 1;
Result (Len) := Wide_Character'Val (C);
-- Codes in the range 16#D800#..16#DBFF# represent the first of the
-- two surrogates used to encode the range 16#01_000#..16#10_FFFF".
-- Such codes are out of range for 16-bit output.
-- The case of input in the range 16#DC00#..16#DFFF# must never
-- occur, since it means we have a second surrogate character with
-- no corresponding first surrogate.
-- Codes in the range 16#FFFE# .. 16#FFFF# are also invalid since
-- they conflict with codes used for BOM values.
-- Thus all remaining codes are invalid
else
Raise_Encoding_Error (Iptr - 1);
end if;
end loop;
return Result (1 .. Len);
end Decode;
------------
-- Encode --
------------
-- Encode Wide_String in UTF-8, UTF-16BE or UTF-16LE
function Encode
(Item : Wide_String;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String
is
begin
-- Case of UTF_8
if Output_Scheme = UTF_8 then
return Encode (Item, Output_BOM);
-- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary
else
return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)),
Output_Scheme, Output_BOM);
end if;
end Encode;
-- Encode Wide_String in UTF-8
function Encode
(Item : Wide_String;
Output_BOM : Boolean := False) return UTF_8_String
is
Result : UTF_8_String (1 .. 3 * Item'Length + 3);
-- Worst case is three bytes per input byte + space for BOM
Len : Natural;
-- Number of output codes stored in Result
C : Unsigned_16;
-- Single input character
procedure Store (C : Unsigned_16);
pragma Inline (Store);
-- Store one output code, C is in the range 0 .. 255
-----------
-- Store --
-----------
procedure Store (C : Unsigned_16) is
begin
Len := Len + 1;
Result (Len) := Character'Val (C);
end Store;
-- Start of processing for UTF8_Encode
begin
-- Output BOM if required
if Output_BOM then
Result (1 .. 3) := BOM_8;
Len := 3;
else
Len := 0;
end if;
-- Loop through characters of input
for J in Item'Range loop
C := To_Unsigned_16 (Item (J));
-- Codes in the range 16#00# - 16#7F# are represented as
-- 0xxxxxxx
if C <= 16#7F# then
Store (C);
-- Codes in the range 16#80# - 16#7FF# are represented as
-- 110yyyxx 10xxxxxx
elsif C <= 16#7FF# then
Store (2#110_00000# or Shift_Right (C, 6));
Store (2#10_000000# or (C and 2#00_111111#));
-- Codes in the range 16#800# - 16#FFFF# are represented as
-- 1110yyyy 10yyyyxx 10xxxxxx
else
Store (2#1110_0000# or Shift_Right (C, 12));
Store (2#10_000000# or
Shift_Right (C and 2#111111_000000#, 6));
Store (2#10_000000# or (C and 2#00_111111#));
end if;
end loop;
return Result (1 .. Len);
end Encode;
-- Encode Wide_String in UTF-16
function Encode
(Item : Wide_String;
Output_BOM : Boolean := False) return UTF_16_Wide_String
is
Result : Wide_String (1 .. Item'Length + Boolean'Pos (Output_BOM));
-- Output is same length as input + possible BOM
Len : Integer;
-- Length of output string
C : Unsigned_16;
begin
-- Output BOM if required
if Output_BOM then
Result (1) := BOM_16 (1);
Len := 1;
else
Len := 0;
end if;
-- Loop through input characters encoding them
for Iptr in Item'Range loop
C := To_Unsigned_16 (Item (Iptr));
-- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# are
-- output unchaned.
if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then
Len := Len + 1;
Result (Len) := Wide_Character'Val (C);
-- Codes in tne range 16#D800#..16#DFFF# should never appear in the
-- input, since no valid Unicode characters are in this range (which
-- would conflict with the UTF-16 surrogate encodings). Similarly
-- codes in the range 16#FFFE#..16#FFFF conflict with BOM codes.
-- Thus all remaining codes are illegal.
else
Raise_Encoding_Error (Iptr);
end if;
end loop;
return Result;
end Encode;
end Ada.Strings.UTF_Encoding.Wide_Encoding;

67
gcc/ada/a-suewen.ads Executable file
View File

@ -0,0 +1,67 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.UTF_ENCODING.WIDE_ENCODING --
-- --
-- S p e c --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding
-- and decoding Wide_String values using UTF encodings. Note: this package is
-- consistent with Ada 95, and may be included in Ada 95 implementations.
package Ada.Strings.UTF_Encoding.Wide_Encoding is
pragma Pure (Wide_Encoding);
-- The encoding routines take a Wide_String as input and encode the result
-- using the specified UTF encoding method. The result includes a BOM if
-- the Output_BOM argument is set to True. Encoding_Error is raised if an
-- invalid character appears in the input. In particular the characters
-- in the range 16#D800# .. 16#DFFF# are invalid because they conflict
-- with UTF-16 surrogate encodings, and the characters 16#FFFE# and
-- 16#FFFF# are also invalid because they conflict with BOM codes.
function Encode
(Item : Wide_String;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String;
-- Encode Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as
-- specified by the Output_Scheme parameter.
function Encode
(Item : Wide_String;
Output_BOM : Boolean := False) return UTF_8_String;
-- Encode Wide_String using UTF-8 encoding
function Encode
(Item : Wide_String;
Output_BOM : Boolean := False) return UTF_16_Wide_String;
-- Encode Wide_String using UTF_16 encoding
-- The decoding routines take a UTF String as input, and return a decoded
-- Wide_String. If the UTF String starts with a BOM that matches the
-- encoding method, it is ignored. An incorrect BOM raises Encoding_Error.
function Decode
(Item : UTF_String;
Input_Scheme : Encoding_Scheme) return Wide_String;
-- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the
-- Input_Scheme parameter. It is decoded and returned as a Wide_String
-- value. Note: a convenient form for scheme may be Encoding (UTF_String).
function Decode
(Item : UTF_8_String) return Wide_String;
-- The input is encoded in UTF-8 and returned as a Wide_String value
function Decode
(Item : UTF_16_Wide_String) return Wide_String;
-- The input is encoded in UTF-16 and returned as a Wide_String value
end Ada.Strings.UTF_Encoding.Wide_Encoding;

431
gcc/ada/a-suezen.adb Executable file
View File

@ -0,0 +1,431 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is
use Interfaces;
------------
-- Decode --
------------
-- Version to decode UTF-8/UTF-16BE/UTF-16LE input to Wide_Wide_String
function Decode
(Item : UTF_String;
Input_Scheme : Encoding_Scheme) return Wide_Wide_String
is
begin
if Input_Scheme = UTF_8 then
return Decode (Item);
else
return Decode (To_UTF_16 (Item, Input_Scheme));
end if;
end Decode;
-- Decode UTF-8 input to Wide_Wide_String
function Decode (Item : UTF_8_String) return Wide_Wide_String is
Result : Wide_Wide_String (1 .. Item'Length);
-- Result string (worst case is same length as input)
Len : Natural := 0;
-- Length of result stored so far
Iptr : Natural;
-- Input string pointer
C : Unsigned_8;
R : Unsigned_32;
procedure Get_Continuation;
-- Reads a continuation byte of the form 10xxxxxx, shifts R left
-- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On
-- return Ptr is incremented. Raises exceptioon if continuation
-- byte does not exist or is invalid.
----------------------
-- Get_Continuation --
----------------------
procedure Get_Continuation is
begin
if Iptr > Item'Last then
Raise_Encoding_Error (Iptr - 1);
else
C := To_Unsigned_8 (Item (Iptr));
Iptr := Iptr + 1;
if C not in 2#10_000000# .. 2#10_111111# then
Raise_Encoding_Error (Iptr - 1);
else
R := Shift_Left (R, 6) or Unsigned_32 (C and 2#00_111111#);
end if;
end if;
end Get_Continuation;
-- Start of processing for Decode
begin
Iptr := Item'First;
-- Skip BOM at start
if Item'Length >= 3
and then Item (Iptr .. Iptr + 2) = BOM_8
then
Iptr := Iptr + 3;
-- Error if bad BOM
elsif Item'Length >= 2
and then (Item (Iptr .. Iptr + 1) = BOM_16BE
or else
Item (Iptr .. Iptr + 1) = BOM_16LE)
then
Raise_Encoding_Error (Iptr);
end if;
-- Loop through input characters
while Iptr <= Item'Last loop
C := To_Unsigned_8 (Item (Iptr));
Iptr := Iptr + 1;
-- Codes in the range 16#00# - 16#7F# are represented as
-- 0xxxxxxx
if C <= 16#7F# then
R := Unsigned_32 (C);
-- No initial code can be of the form 10xxxxxx. Such codes are used
-- only for continuations.
elsif C <= 2#10_111111# then
Raise_Encoding_Error (Iptr - 1);
-- Codes in the range 16#80# - 16#7FF# are represented as
-- 110yyyxx 10xxxxxx
elsif C <= 2#110_11111# then
R := Unsigned_32 (C and 2#000_11111#);
Get_Continuation;
-- Codes in the range 16#800# - 16#FFFF# are represented as
-- 1110yyyy 10yyyyxx 10xxxxxx
elsif C <= 2#1110_1111# then
R := Unsigned_32 (C and 2#0000_1111#);
Get_Continuation;
Get_Continuation;
-- Codes in the range 16#10000# - 16#10FFFF# are represented as
-- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
elsif C <= 2#11110_111# then
R := Unsigned_32 (C and 2#00000_111#);
Get_Continuation;
Get_Continuation;
Get_Continuation;
-- Any other code is an error
else
Raise_Encoding_Error (Iptr - 1);
end if;
Len := Len + 1;
Result (Len) := Wide_Wide_Character'Val (R);
end loop;
return Result (1 .. Len);
end Decode;
-- Decode UTF-16 input to Wide_Wide_String
function Decode (Item : UTF_16_Wide_String) return Wide_Wide_String is
Result : Wide_Wide_String (1 .. Item'Length);
-- Result cannot be longer than the input string
Len : Natural := 0;
-- Length of result
Iptr : Natural;
-- Pointer to next element in Item
C : Unsigned_16;
R : Unsigned_32;
begin
-- Skip UTF-16 BOM at start
Iptr := Item'First;
if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then
Iptr := Iptr + 1;
end if;
-- Loop through input characters
while Iptr <= Item'Last loop
C := To_Unsigned_16 (Item (Iptr));
Iptr := Iptr + 1;
-- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD#
-- represent their own value.
if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then
Len := Len + 1;
Result (Len) := Wide_Wide_Character'Val (C);
-- Codes in the range 16#D800#..16#DBFF# represent the first of the
-- two surrogates used to encode the range 16#01_000#..16#10_FFFF".
-- The first surrogate provides 10 high order bits of the result.
elsif C <= 16#DBFF# then
R := Shift_Left ((Unsigned_32 (C) - 16#D800#), 10);
-- Error if at end of string
if Iptr > Item'Last then
Raise_Encoding_Error (Iptr - 1);
-- Otherwise next character must be valid low order surrogate
-- which provides the low 10 order bits of the result.
else
C := To_Unsigned_16 (Item (Iptr));
Iptr := Iptr + 1;
if C not in 16#DC00# .. 16#DFFF# then
Raise_Encoding_Error (Iptr - 1);
else
R := R or (Unsigned_32 (C) mod 2 ** 10);
-- The final adjustment is to add 16#01_0000 to get the
-- result back in the required 21 bit range.
R := R + 16#01_0000#;
Len := Len + 1;
Result (Len) := Wide_Wide_Character'Val (R);
end if;
end if;
-- Remaining codes are invalid
else
Raise_Encoding_Error (Iptr - 1);
end if;
end loop;
return Result (1 .. Len);
end Decode;
------------
-- Encode --
------------
-- Encode Wide_Wide_String in UTF-8, UTF-16BE or UTF-16LE
function Encode
(Item : Wide_Wide_String;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String
is
begin
if Output_Scheme = UTF_8 then
return Encode (Item, Output_BOM);
else
return From_UTF_16 (Encode (Item), Output_Scheme, Output_BOM);
end if;
end Encode;
-- Encode Wide_Wide_String in UTF-8
function Encode
(Item : Wide_Wide_String;
Output_BOM : Boolean := False) return UTF_8_String
is
Result : String (1 .. 4 * Item'Length + 3);
-- Worst case is four bytes per input byte + space for BOM
Len : Natural;
-- Number of output codes stored in Result
C : Unsigned_32;
-- Single input character
procedure Store (C : Unsigned_32);
pragma Inline (Store);
-- Store one output code (input is in range 0 .. 255)
-----------
-- Store --
-----------
procedure Store (C : Unsigned_32) is
begin
Len := Len + 1;
Result (Len) := Character'Val (C);
end Store;
-- Start of processing for Encode
begin
-- Output BOM if required
if Output_BOM then
Result (1 .. 3) := BOM_8;
Len := 3;
else
Len := 0;
end if;
-- Loop through characters of input
for Iptr in Item'Range loop
C := To_Unsigned_32 (Item (Iptr));
-- Codes in the range 16#00#..16#7F# are represented as
-- 0xxxxxxx
if C <= 16#7F# then
Store (C);
-- Codes in the range 16#80#..16#7FF# are represented as
-- 110yyyxx 10xxxxxx
elsif C <= 16#7FF# then
Store (2#110_00000# or Shift_Right (C, 6));
Store (2#10_000000# or (C and 2#00_111111#));
-- Codes in the range 16#800#..16#D7FF# or 16#E000#..16#FFFD# are
-- represented as
-- 1110yyyy 10yyyyxx 10xxxxxx
elsif C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then
Store (2#1110_0000# or Shift_Right (C, 12));
Store (2#10_000000# or
Shift_Right (C and 2#111111_000000#, 6));
Store (2#10_000000# or (C and 2#00_111111#));
-- Codes in the range 16#10000# - 16#10FFFF# are represented as
-- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx
elsif C in 16#1_0000# .. 16#10_FFFF# then
Store (2#11110_000# or
Shift_Right (C, 18));
Store (2#10_000000# or
Shift_Right (C and 2#111111_000000_000000#, 12));
Store (2#10_000000# or
Shift_Right (C and 2#111111_000000#, 6));
Store (2#10_000000# or
(C and 2#00_111111#));
-- All other codes are invalid
else
Raise_Encoding_Error (Iptr);
end if;
end loop;
return Result (1 .. Len);
end Encode;
-- Encode Wide_Wide_String in UTF-16
function Encode
(Item : Wide_Wide_String;
Output_BOM : Boolean := False) return UTF_16_Wide_String
is
Result : Wide_String (1 .. 2 * Item'Length + 1);
-- Worst case is each input character generates two output characters
-- plus one for possible BOM.
Len : Integer;
-- Length of output string
C : Unsigned_32;
begin
-- Output BOM if needed
if Output_BOM then
Result (1) := BOM_16 (1);
Len := 1;
else
Len := 0;
end if;
-- Loop through input characters encoding them
for Iptr in Item'Range loop
C := To_Unsigned_32 (Item (Iptr));
-- Codes in the range 16#00_0000#..16#00_D7FF# or 16#E000#..16#FFFD#
-- are output unchanged
if C <= 16#00_D7FF# or else C in 16#E000# .. 16#FFFD# then
Len := Len + 1;
Result (Len) := Wide_Character'Val (C);
-- Codes in the range 16#01_0000#..16#10_FFFF# are output using two
-- surrogate characters. First 16#1_0000# is subtracted from the code
-- point to give a 20-bit value. This is then split into two separate
-- 10-bit values each of which is represented as a surrogate with the
-- most significant half placed in the first surrogate. The ranges of
-- values used for the two surrogates are 16#D800#-16#DBFF# for the
-- first, most significant surrogate and 16#DC00#-16#DFFF# for the
-- second, least significant surrogate.
elsif C in 16#1_0000# .. 16#10_FFFF# then
C := C - 16#1_0000#;
Len := Len + 1;
Result (Len) := Wide_Character'Val (16#D800# + C / 2 ** 10);
Len := Len + 1;
Result (Len) := Wide_Character'Val (16#DC00# + C mod 2 ** 10);
-- All other codes are invalid
else
Raise_Encoding_Error (Iptr);
end if;
end loop;
return Result (1 .. Len);
end Encode;
end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding;

64
gcc/ada/a-suezen.ads Executable file
View File

@ -0,0 +1,64 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_ENCODING --
-- --
-- S p e c --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
-- copy and modify this specification, provided that if you redistribute a --
-- modified version, any changes that you have made are clearly indicated. --
-- --
------------------------------------------------------------------------------
-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding
-- and decoding Wide_String values using UTF encodings. Note: this package is
-- consistent with Ada 2005, and may be used in Ada 2005 mode, but cannot be
-- used in Ada 95 mode, since Wide_Wide_Character is an Ada 2005 feature.
package Ada.Strings.UTF_Encoding.Wide_Wide_Encoding is
pragma Pure (Wide_Wide_Encoding);
-- The encoding routines take a Wide_Wide_String as input and encode the
-- result using the specified UTF encoding method. The result includes a
-- BOM if the Output_BOM parameter is set to True.
function Encode
(Item : Wide_Wide_String;
Output_Scheme : Encoding_Scheme;
Output_BOM : Boolean := False) return UTF_String;
-- Encode Wide_Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as
-- specified by the Output_Scheme parameter.
function Encode
(Item : Wide_Wide_String;
Output_BOM : Boolean := False) return UTF_8_String;
-- Encode Wide_Wide_String using UTF-8 encoding
function Encode
(Item : Wide_Wide_String;
Output_BOM : Boolean := False) return UTF_16_Wide_String;
-- Encode Wide_Wide_String using UTF_16 encoding
-- The decoding routines take a UTF String as input, and return a decoded
-- Wide_String. If the UTF String starts with a BOM that matches the
-- encoding method, it is ignored. An incorrect BOM raises Encoding_Error.
function Decode
(Item : UTF_String;
Input_Scheme : Encoding_Scheme) return Wide_Wide_String;
-- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the
-- Input_Scheme parameter. It is decoded and returned as a Wide_Wide_String
-- value. Note: a convenient form for Scheme may be Encoding (UTF_String).
function Decode
(Item : UTF_8_String) return Wide_Wide_String;
-- The input is encoded in UTF-8 and returned as a Wide_Wide_String value
function Decode
(Item : UTF_16_Wide_String) return Wide_Wide_String;
-- The input is encoded in UTF-16 and returned as a Wide_String value
end Ada.Strings.UTF_Encoding.Wide_Wide_Encoding;

67
gcc/ada/a-swunau-shared.adb Normal file
View File

@ -0,0 +1,67 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Ada.Strings.Wide_Unbounded.Aux is
---------------------
-- Get_Wide_String --
---------------------
procedure Get_Wide_String
(U : Unbounded_Wide_String;
S : out Big_Wide_String_Access;
L : out Natural)
is
X : aliased Big_Wide_String;
for X'Address use U.Reference.Data'Address;
begin
S := X'Unchecked_Access;
L := U.Reference.Last;
end Get_Wide_String;
---------------------
-- Set_Wide_String --
---------------------
procedure Set_Wide_String
(UP : in out Unbounded_Wide_String;
S : Wide_String_Access)
is
X : Wide_String_Access := S;
begin
Set_Unbounded_Wide_String (UP, S.all);
Free (X);
end Set_Wide_String;
end Ada.Strings.Wide_Unbounded.Aux;

136
gcc/ada/a-swuwti-shared.adb Normal file
View File

@ -0,0 +1,136 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Text_IO; use Ada.Wide_Text_IO;
package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is
--------------
-- Get_Line --
--------------
function Get_Line return Unbounded_Wide_String is
Buffer : Wide_String (1 .. 1000);
Last : Natural;
Result : Unbounded_Wide_String;
begin
Get_Line (Buffer, Last);
Set_Unbounded_Wide_String (Result, Buffer (1 .. Last));
while Last = Buffer'Last loop
Get_Line (Buffer, Last);
Append (Result, Buffer (1 .. Last));
end loop;
return Result;
end Get_Line;
function Get_Line
(File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String
is
Buffer : Wide_String (1 .. 1000);
Last : Natural;
Result : Unbounded_Wide_String;
begin
Get_Line (File, Buffer, Last);
Set_Unbounded_Wide_String (Result, Buffer (1 .. Last));
while Last = Buffer'Last loop
Get_Line (File, Buffer, Last);
Append (Result, Buffer (1 .. Last));
end loop;
return Result;
end Get_Line;
procedure Get_Line (Item : out Unbounded_Wide_String) is
begin
Get_Line (Current_Input, Item);
end Get_Line;
procedure Get_Line
(File : Ada.Wide_Text_IO.File_Type;
Item : out Unbounded_Wide_String)
is
Buffer : Wide_String (1 .. 1000);
Last : Natural;
begin
Get_Line (File, Buffer, Last);
Set_Unbounded_Wide_String (Item, Buffer (1 .. Last));
while Last = Buffer'Last loop
Get_Line (File, Buffer, Last);
Append (Item, Buffer (1 .. Last));
end loop;
end Get_Line;
---------
-- Put --
---------
procedure Put (U : Unbounded_Wide_String) is
UR : constant Shared_Wide_String_Access := U.Reference;
begin
Put (UR.Data (1 .. UR.Last));
end Put;
procedure Put (File : File_Type; U : Unbounded_Wide_String) is
UR : constant Shared_Wide_String_Access := U.Reference;
begin
Put (File, UR.Data (1 .. UR.Last));
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line (U : Unbounded_Wide_String) is
UR : constant Shared_Wide_String_Access := U.Reference;
begin
Put_Line (UR.Data (1 .. UR.Last));
end Put_Line;
procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is
UR : constant Shared_Wide_String_Access := U.Reference;
begin
Put_Line (File, UR.Data (1 .. UR.Last));
end Put_Line;
end Ada.Strings.Wide_Unbounded.Wide_Text_IO;

67
gcc/ada/a-szunau-shared.adb Normal file
View File

@ -0,0 +1,67 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
package body Ada.Strings.Wide_Wide_Unbounded.Aux is
--------------------------
-- Get_Wide_Wide_String --
--------------------------
procedure Get_Wide_Wide_String
(U : Unbounded_Wide_Wide_String;
S : out Big_Wide_Wide_String_Access;
L : out Natural)
is
X : aliased Big_Wide_Wide_String;
for X'Address use U.Reference.Data'Address;
begin
S := X'Unchecked_Access;
L := U.Reference.Last;
end Get_Wide_Wide_String;
--------------------------
-- Set_Wide_Wide_String --
--------------------------
procedure Set_Wide_Wide_String
(UP : in out Unbounded_Wide_Wide_String;
S : Wide_Wide_String_Access)
is
X : Wide_Wide_String_Access := S;
begin
Set_Unbounded_Wide_Wide_String (UP, S.all);
Free (X);
end Set_Wide_Wide_String;
end Ada.Strings.Wide_Wide_Unbounded.Aux;

137
gcc/ada/a-szuzti-shared.adb Normal file
View File

@ -0,0 +1,137 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO --
-- --
-- B o d y --
-- --
-- Copyright (C) 1997-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO;
package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is
--------------
-- Get_Line --
--------------
function Get_Line return Unbounded_Wide_Wide_String is
Buffer : Wide_Wide_String (1 .. 1000);
Last : Natural;
Result : Unbounded_Wide_Wide_String;
begin
Get_Line (Buffer, Last);
Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last));
while Last = Buffer'Last loop
Get_Line (Buffer, Last);
Append (Result, Buffer (1 .. Last));
end loop;
return Result;
end Get_Line;
function Get_Line
(File : Ada.Wide_Wide_Text_IO.File_Type)
return Unbounded_Wide_Wide_String
is
Buffer : Wide_Wide_String (1 .. 1000);
Last : Natural;
Result : Unbounded_Wide_Wide_String;
begin
Get_Line (File, Buffer, Last);
Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last));
while Last = Buffer'Last loop
Get_Line (File, Buffer, Last);
Append (Result, Buffer (1 .. Last));
end loop;
return Result;
end Get_Line;
procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is
begin
Get_Line (Current_Input, Item);
end Get_Line;
procedure Get_Line
(File : Ada.Wide_Wide_Text_IO.File_Type;
Item : out Unbounded_Wide_Wide_String)
is
Buffer : Wide_Wide_String (1 .. 1000);
Last : Natural;
begin
Get_Line (File, Buffer, Last);
Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last));
while Last = Buffer'Last loop
Get_Line (File, Buffer, Last);
Append (Item, Buffer (1 .. Last));
end loop;
end Get_Line;
---------
-- Put --
---------
procedure Put (U : Unbounded_Wide_Wide_String) is
UR : constant Shared_Wide_Wide_String_Access := U.Reference;
begin
Put (UR.Data (1 .. UR.Last));
end Put;
procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is
UR : constant Shared_Wide_Wide_String_Access := U.Reference;
begin
Put (File, UR.Data (1 .. UR.Last));
end Put;
--------------
-- Put_Line --
--------------
procedure Put_Line (U : Unbounded_Wide_Wide_String) is
UR : constant Shared_Wide_Wide_String_Access := U.Reference;
begin
Put_Line (UR.Data (1 .. UR.Last));
end Put_Line;
procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is
UR : constant Shared_Wide_Wide_String_Access := U.Reference;
begin
Put_Line (File, UR.Data (1 .. UR.Last));
end Put_Line;
end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO;

11
gcc/ada/exp_attr.adb
View File

@ -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);

3
gcc/ada/gcc-interface/Makefile.in
View File

@ -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.

14
gcc/ada/impunit.adb
View File

@ -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 --

114
gcc/ada/sem.adb
View File

@ -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;

7
gcc/ada/sem_prag.adb
View File

@ -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;