From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/namet-sp.adb | 203 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 203 insertions(+) create mode 100755 gcc/ada/namet-sp.adb (limited to 'gcc/ada/namet-sp.adb') diff --git a/gcc/ada/namet-sp.adb b/gcc/ada/namet-sp.adb new file mode 100755 index 000000000..30f85f52c --- /dev/null +++ b/gcc/ada/namet-sp.adb @@ -0,0 +1,203 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3