Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/casing.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT COMPILER COMPONENTS -- | |
4 -- -- | |
5 -- C A S I N G -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 1992-2015, 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 | |
32 with Csets; use Csets; | |
33 with Opt; use Opt; | |
34 with Widechar; use Widechar; | |
35 | |
36 package body Casing is | |
37 | |
38 ---------------------- | |
39 -- Determine_Casing -- | |
40 ---------------------- | |
41 | |
42 function Determine_Casing (Ident : Text_Buffer) return Casing_Type is | |
43 | |
44 All_Lower : Boolean := True; | |
45 -- Set False if upper case letter found | |
46 | |
47 All_Upper : Boolean := True; | |
48 -- Set False if lower case letter found | |
49 | |
50 Mixed : Boolean := True; | |
51 -- Set False if exception to mixed case rule found (lower case letter | |
52 -- at start or after underline, or upper case letter elsewhere). | |
53 | |
54 Decisive : Boolean := False; | |
55 -- Set True if at least one instance of letter not after underline | |
56 | |
57 After_Und : Boolean := True; | |
58 -- True at start of string, and after an underline character | |
59 | |
60 begin | |
61 -- A special exception, consider SPARK_Mode to be mixed case | |
62 | |
63 if Ident = "SPARK_Mode" then | |
64 return Mixed_Case; | |
65 end if; | |
66 | |
67 -- Proceed with normal determination | |
68 | |
69 for S in Ident'Range loop | |
70 if Ident (S) = '_' or else Ident (S) = '.' then | |
71 After_Und := True; | |
72 | |
73 elsif Is_Lower_Case_Letter (Ident (S)) then | |
74 All_Upper := False; | |
75 | |
76 if not After_Und then | |
77 Decisive := True; | |
78 else | |
79 After_Und := False; | |
80 Mixed := False; | |
81 end if; | |
82 | |
83 elsif Is_Upper_Case_Letter (Ident (S)) then | |
84 All_Lower := False; | |
85 | |
86 if not After_Und then | |
87 Decisive := True; | |
88 Mixed := False; | |
89 else | |
90 After_Und := False; | |
91 end if; | |
92 end if; | |
93 end loop; | |
94 | |
95 -- Now we can figure out the result from the flags we set in that loop | |
96 | |
97 if All_Lower then | |
98 return All_Lower_Case; | |
99 | |
100 elsif not Decisive then | |
101 return Unknown; | |
102 | |
103 elsif All_Upper then | |
104 return All_Upper_Case; | |
105 | |
106 elsif Mixed then | |
107 return Mixed_Case; | |
108 | |
109 else | |
110 return Unknown; | |
111 end if; | |
112 end Determine_Casing; | |
113 | |
114 ------------------------ | |
115 -- Set_All_Upper_Case -- | |
116 ------------------------ | |
117 | |
118 procedure Set_All_Upper_Case is | |
119 begin | |
120 Set_Casing (All_Upper_Case); | |
121 end Set_All_Upper_Case; | |
122 | |
123 ---------------- | |
124 -- Set_Casing -- | |
125 ---------------- | |
126 | |
127 procedure Set_Casing | |
128 (Buf : in out Bounded_String; | |
129 C : Casing_Type; | |
130 D : Casing_Type := Mixed_Case) | |
131 is | |
132 Ptr : Natural; | |
133 | |
134 Actual_Casing : Casing_Type; | |
135 -- Set from C or D as appropriate | |
136 | |
137 After_Und : Boolean := True; | |
138 -- True at start of string, and after an underline character or after | |
139 -- any other special character that is not a normal identifier char). | |
140 | |
141 begin | |
142 if C /= Unknown then | |
143 Actual_Casing := C; | |
144 else | |
145 Actual_Casing := D; | |
146 end if; | |
147 | |
148 Ptr := 1; | |
149 | |
150 while Ptr <= Buf.Length loop | |
151 | |
152 -- Wide character. Note that we do nothing with casing in this case. | |
153 -- In Ada 2005 mode, required folding of lower case letters happened | |
154 -- as the identifier was scanned, and we do not attempt any further | |
155 -- messing with case (note that in any case we do not know how to | |
156 -- fold upper case to lower case in wide character mode). We also | |
157 -- do not bother with recognizing punctuation as equivalent to an | |
158 -- underscore. There is nothing functional at this stage in doing | |
159 -- the requested casing operation, beyond folding to upper case | |
160 -- when it is mandatory, which does not involve underscores. | |
161 | |
162 if Buf.Chars (Ptr) = ASCII.ESC | |
163 or else Buf.Chars (Ptr) = '[' | |
164 or else (Upper_Half_Encoding | |
165 and then Buf.Chars (Ptr) in Upper_Half_Character) | |
166 then | |
167 Skip_Wide (Buf.Chars, Ptr); | |
168 After_Und := False; | |
169 | |
170 -- Underscore, or non-identifer character (error case) | |
171 | |
172 elsif Buf.Chars (Ptr) = '_' | |
173 or else not Identifier_Char (Buf.Chars (Ptr)) | |
174 then | |
175 After_Und := True; | |
176 Ptr := Ptr + 1; | |
177 | |
178 -- Lower case letter | |
179 | |
180 elsif Is_Lower_Case_Letter (Buf.Chars (Ptr)) then | |
181 if Actual_Casing = All_Upper_Case | |
182 or else (After_Und and then Actual_Casing = Mixed_Case) | |
183 then | |
184 Buf.Chars (Ptr) := Fold_Upper (Buf.Chars (Ptr)); | |
185 end if; | |
186 | |
187 After_Und := False; | |
188 Ptr := Ptr + 1; | |
189 | |
190 -- Upper case letter | |
191 | |
192 elsif Is_Upper_Case_Letter (Buf.Chars (Ptr)) then | |
193 if Actual_Casing = All_Lower_Case | |
194 or else (not After_Und and then Actual_Casing = Mixed_Case) | |
195 then | |
196 Buf.Chars (Ptr) := Fold_Lower (Buf.Chars (Ptr)); | |
197 end if; | |
198 | |
199 After_Und := False; | |
200 Ptr := Ptr + 1; | |
201 | |
202 -- Other identifier character (must be digit) | |
203 | |
204 else | |
205 After_Und := False; | |
206 Ptr := Ptr + 1; | |
207 end if; | |
208 end loop; | |
209 end Set_Casing; | |
210 | |
211 procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is | |
212 begin | |
213 Set_Casing (Global_Name_Buffer, C, D); | |
214 end Set_Casing; | |
215 | |
216 end Casing; |