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-2019, 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 32with Csets; use Csets; 33with Opt; use Opt; 34with Widechar; use Widechar; 35 36package 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 216end Casing; 217