1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- N A M E T . S P -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2008-2012, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with System.WCh_Cnv; use System.WCh_Cnv; 33 34with GNAT.UTF_32_Spelling_Checker; 35 36package body Namet.Sp is 37 38 ----------------------- 39 -- Local Subprograms -- 40 ----------------------- 41 42 procedure Get_Name_String_UTF_32 43 (Id : Name_Id; 44 Result : out UTF_32_String; 45 Length : out Natural); 46 -- This procedure is similar to Get_Decoded_Name except that the output 47 -- is stored in the given Result array as single codes, so in particular 48 -- any Uhh, Whhhh, or WWhhhhhhhh sequences are decoded to appear as a 49 -- single value in the output. This call does not affect the contents of 50 -- either Name_Buffer or Name_Len. The result is in Result (1 .. Length). 51 -- The caller must ensure that the result buffer is long enough. 52 53 ---------------------------- 54 -- Get_Name_String_UTF_32 -- 55 ---------------------------- 56 57 procedure Get_Name_String_UTF_32 58 (Id : Name_Id; 59 Result : out UTF_32_String; 60 Length : out Natural) 61 is 62 pragma Assert (Result'First = 1); 63 64 SPtr : Int := Name_Entries.Table (Id).Name_Chars_Index + 1; 65 -- Index through characters of name in Name_Chars table. Initial value 66 -- points to first character of the name. 67 68 SLen : constant Nat := Nat (Name_Entries.Table (Id).Name_Len); 69 -- Length of the name 70 71 SLast : constant Int := SPtr + SLen - 1; 72 -- Last index in Name_Chars table for name 73 74 C : Character; 75 -- Current character from Name_Chars table 76 77 procedure Store_Hex (N : Natural); 78 -- Read and store next N characters starting at SPtr and store result 79 -- in next character of Result. Update SPtr past characters read. 80 81 --------------- 82 -- Store_Hex -- 83 --------------- 84 85 procedure Store_Hex (N : Natural) is 86 T : UTF_32_Code; 87 C : Character; 88 89 begin 90 T := 0; 91 for J in 1 .. N loop 92 C := Name_Chars.Table (SPtr); 93 SPtr := SPtr + 1; 94 95 if C in '0' .. '9' then 96 T := 16 * T + Character'Pos (C) - Character'Pos ('0'); 97 else 98 pragma Assert (C in 'a' .. 'f'); 99 100 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10); 101 end if; 102 end loop; 103 104 Length := Length + 1; 105 pragma Assert (Length <= Result'Length); 106 Result (Length) := T; 107 end Store_Hex; 108 109 -- Start of processing for Get_Name_String_UTF_32 110 111 begin 112 Length := 0; 113 while SPtr <= SLast loop 114 C := Name_Chars.Table (SPtr); 115 116 -- Uhh encoding 117 118 if C = 'U' 119 and then SPtr <= SLast - 2 120 and then Name_Chars.Table (SPtr + 1) not in 'A' .. 'Z' 121 then 122 SPtr := SPtr + 1; 123 Store_Hex (2); 124 125 -- Whhhh encoding 126 127 elsif C = 'W' 128 and then SPtr <= SLast - 4 129 and then Name_Chars.Table (SPtr + 1) not in 'A' .. 'Z' 130 then 131 SPtr := SPtr + 1; 132 Store_Hex (4); 133 134 -- WWhhhhhhhh encoding 135 136 elsif C = 'W' 137 and then SPtr <= SLast - 8 138 and then Name_Chars.Table (SPtr + 1) = 'W' 139 then 140 SPtr := SPtr + 2; 141 Store_Hex (8); 142 143 -- Q encoding (character literal) 144 145 elsif C = 'Q' and then SPtr < SLast then 146 147 -- Put apostrophes around character 148 149 pragma Assert (Length <= Result'Last - 3); 150 Result (Length + 1) := UTF_32_Code'Val (Character'Pos (''')); 151 Result (Length + 2) := 152 UTF_32_Code (Get_Char_Code (Name_Chars.Table (SPtr + 1))); 153 Result (Length + 3) := UTF_32_Code'Val (Character'Pos (''')); 154 SPtr := SPtr + 2; 155 Length := Length + 3; 156 157 -- Unencoded case 158 159 else 160 SPtr := SPtr + 1; 161 Length := Length + 1; 162 pragma Assert (Length <= Result'Last); 163 Result (Length) := UTF_32_Code (Get_Char_Code (C)); 164 end if; 165 end loop; 166 end Get_Name_String_UTF_32; 167 168 ------------------------ 169 -- Is_Bad_Spelling_Of -- 170 ------------------------ 171 172 function Is_Bad_Spelling_Of (Found, Expect : Name_Id) return Boolean is 173 FL : constant Natural := Natural (Length_Of_Name (Found)); 174 EL : constant Natural := Natural (Length_Of_Name (Expect)); 175 -- Length of input names 176 177 FB : UTF_32_String (1 .. 2 * FL); 178 EB : UTF_32_String (1 .. 2 * EL); 179 -- Buffers for results, a factor of 2 is more than enough, the only 180 -- sequence which expands is Q (character literal) by 1.5 times. 181 182 FBL : Natural; 183 EBL : Natural; 184 -- Length of decoded names 185 186 begin 187 Get_Name_String_UTF_32 (Found, FB, FBL); 188 Get_Name_String_UTF_32 (Expect, EB, EBL); 189 190 -- For an exact match, return False, otherwise check bad spelling. We 191 -- need this special test because the library routine returns True for 192 -- an exact match. 193 194 if FB (1 .. FBL) = EB (1 .. EBL) then 195 return False; 196 else 197 return 198 GNAT.UTF_32_Spelling_Checker.Is_Bad_Spelling_Of 199 (FB (1 .. FBL), EB (1 .. EBL)); 200 end if; 201 end Is_Bad_Spelling_Of; 202 203end Namet.Sp; 204