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;