GCC v8.2
[gcc.git] / gcc / ada / casing.adb
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-2018, 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;