|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- N A M E T . S P --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2008-2018, Free Software Foundation, Inc. --
|
|
111
|
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
|
|
|
32 with System.WCh_Cnv; use System.WCh_Cnv;
|
|
|
33
|
|
|
34 with GNAT.UTF_32_Spelling_Checker;
|
|
|
35
|
|
|
36 package 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
|
|
|
203 end Namet.Sp;
|
