URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc1/] [gcc/] [ada/] [namet-sp.adb] - Rev 281
Go to most recent revision | Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- N A M E T . S P -- -- -- -- B o d y -- -- -- -- Copyright (C) 2008-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); -- For an exact match, return False, otherwise check bad spelling. We -- need this special test because the library routine returns True for -- an exact match. if FB (1 .. FBL) = EB (1 .. EBL) then return False; else return GNAT.UTF_32_Spelling_Checker.Is_Bad_Spelling_Of (FB (1 .. FBL), EB (1 .. EBL)); end if; end Is_Bad_Spelling_Of; end Namet.Sp;
Go to most recent revision | Compare with Previous | Blame | View Log