diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/namet-sp.adb')
-rwxr-xr-x | gcc-4.4.3/gcc/ada/namet-sp.adb | 194 |
1 files changed, 0 insertions, 194 deletions
diff --git a/gcc-4.4.3/gcc/ada/namet-sp.adb b/gcc-4.4.3/gcc/ada/namet-sp.adb deleted file mode 100755 index e2deda941..000000000 --- a/gcc-4.4.3/gcc/ada/namet-sp.adb +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- N A M E T . S P -- --- -- --- B o d y -- --- -- --- Copyright (C) 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.WCh_Cnv; use System.WCh_Cnv; - -with GNAT.UTF_32_Spelling_Checker; - -package body Namet.Sp is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Get_Name_String_UTF_32 - (Id : Name_Id; - Result : out UTF_32_String; - Length : out Natural); - -- This procedure is similar to Get_Decoded_Name except that the output - -- is stored in the given Result array as single codes, so in particular - -- any Uhh, Whhhh, or WWhhhhhhhh sequences are decoded to appear as a - -- single value in the output. This call does not affect the contents of - -- either Name_Buffer or Name_Len. The result is in Result (1 .. Length). - -- The caller must ensure that the result buffer is long enough. - - ---------------------------- - -- Get_Name_String_UTF_32 -- - ---------------------------- - - procedure Get_Name_String_UTF_32 - (Id : Name_Id; - Result : out UTF_32_String; - Length : out Natural) - is - pragma Assert (Result'First = 1); - - SPtr : Int := Name_Entries.Table (Id).Name_Chars_Index + 1; - -- Index through characters of name in Name_Chars table. Initial value - -- points to first character of the name. - - SLen : constant Nat := Nat (Name_Entries.Table (Id).Name_Len); - -- Length of the name - - SLast : constant Int := SPtr + SLen - 1; - -- Last index in Name_Chars table for name - - C : Character; - -- Current character from Name_Chars table - - procedure Store_Hex (N : Natural); - -- Read and store next N characters starting at SPtr and store result - -- in next character of Result. Update SPtr past characters read. - - --------------- - -- Store_Hex -- - --------------- - - procedure Store_Hex (N : Natural) is - T : UTF_32_Code; - C : Character; - - begin - T := 0; - for J in 1 .. N loop - C := Name_Chars.Table (SPtr); - SPtr := SPtr + 1; - - if C in '0' .. '9' then - T := 16 * T + Character'Pos (C) - Character'Pos ('0'); - else - pragma Assert (C in 'a' .. 'f'); - - T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10); - end if; - end loop; - - Length := Length + 1; - pragma Assert (Length <= Result'Length); - Result (Length) := T; - end Store_Hex; - - -- Start of processing for Get_Name_String_UTF_32 - - begin - Length := 0; - while SPtr <= SLast loop - C := Name_Chars.Table (SPtr); - - -- Uhh encoding - - if C = 'U' - and then SPtr <= SLast - 2 - and then Name_Chars.Table (SPtr + 1) not in 'A' .. 'Z' - then - SPtr := SPtr + 1; - Store_Hex (2); - - -- Whhhh encoding - - elsif C = 'W' - and then SPtr <= SLast - 4 - and then Name_Chars.Table (SPtr + 1) not in 'A' .. 'Z' - then - SPtr := SPtr + 1; - Store_Hex (4); - - -- WWhhhhhhhh encoding - - elsif C = 'W' - and then SPtr <= SLast - 8 - and then Name_Chars.Table (SPtr + 1) = 'W' - then - SPtr := SPtr + 2; - Store_Hex (8); - - -- Q encoding (character literal) - - elsif C = 'Q' and then SPtr < SLast then - - -- Put apostrophes around character - - pragma Assert (Length <= Result'Last - 3); - Result (Length + 1) := UTF_32_Code'Val (Character'Pos (''')); - Result (Length + 2) := - UTF_32_Code (Get_Char_Code (Name_Chars.Table (SPtr + 1))); - Result (Length + 3) := UTF_32_Code'Val (Character'Pos (''')); - SPtr := SPtr + 2; - Length := Length + 3; - - -- Unencoded case - - else - SPtr := SPtr + 1; - Length := Length + 1; - pragma Assert (Length <= Result'Last); - Result (Length) := UTF_32_Code (Get_Char_Code (C)); - end if; - end loop; - end Get_Name_String_UTF_32; - - ------------------------ - -- Is_Bad_Spelling_Of -- - ------------------------ - - function Is_Bad_Spelling_Of (Found, Expect : Name_Id) return Boolean is - FL : constant Natural := Natural (Length_Of_Name (Found)); - EL : constant Natural := Natural (Length_Of_Name (Expect)); - -- Length of input names - - FB : UTF_32_String (1 .. 2 * FL); - EB : UTF_32_String (1 .. 2 * EL); - -- Buffers for results, a factor of 2 is more than enough, the only - -- sequence which expands is Q (character literal) by 1.5 times. - - FBL : Natural; - EBL : Natural; - -- Length of decoded names - - begin - Get_Name_String_UTF_32 (Found, FB, FBL); - Get_Name_String_UTF_32 (Expect, EB, EBL); - return - GNAT.UTF_32_Spelling_Checker.Is_Bad_Spelling_Of - (FB (1 .. FBL), EB (1 .. EBL)); - end Is_Bad_Spelling_Of; - -end Namet.Sp; |