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