File : namet-sp.adb
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-2009, 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 -- --
19 -- --
20 -- --
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;