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-2021, 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Csets;    use Csets;
  27 with Opt;      use Opt;
  28 with Widechar; use Widechar;
  29
  30 package body Casing is
  31
  32    ----------------------
  33    -- Determine_Casing --
  34    ----------------------
  35
  36    function Determine_Casing (Ident : Text_Buffer) return Casing_Type is
  37
  38       All_Lower : Boolean := True;
  39       --  Set False if upper case letter found
  40
  41       All_Upper : Boolean := True;
  42       --  Set False if lower case letter found
  43
  44       Mixed : Boolean := True;
  45       --  Set False if exception to mixed case rule found (lower case letter
  46       --  at start or after underline, or upper case letter elsewhere).
  47
  48       Decisive : Boolean := False;
  49       --  Set True if at least one instance of letter not after underline
  50
  51       After_Und : Boolean := True;
  52       --  True at start of string, and after an underline character
  53
  54    begin
  55       --  A special exception, consider SPARK_Mode to be mixed case
  56
  57       if Ident = "SPARK_Mode" then
  58          return Mixed_Case;
  59       end if;
  60
  61       --  Proceed with normal determination
  62
  63       for S in Ident'Range loop
  64          if Ident (S) = '_' or else Ident (S) = '.' then
  65             After_Und := True;
  66
  67          elsif Is_Lower_Case_Letter (Ident (S)) then
  68             All_Upper := False;
  69
  70             if not After_Und then
  71                Decisive := True;
  72             else
  73                After_Und := False;
  74                Mixed := False;
  75             end if;
  76
  77          elsif Is_Upper_Case_Letter (Ident (S)) then
  78             All_Lower := False;
  79
  80             if not After_Und then
  81                Decisive := True;
  82                Mixed := False;
  83             else
  84                After_Und := False;
  85             end if;
  86          end if;
  87       end loop;
  88
  89       --  Now we can figure out the result from the flags we set in that loop
  90
  91       if All_Lower then
  92          return All_Lower_Case;
  93
  94       elsif not Decisive then
  95          return Unknown;
  96
  97       elsif All_Upper then
  98          return All_Upper_Case;
  99
 100       elsif Mixed then
 101          return Mixed_Case;
 102
 103       else
 104          return Unknown;
 105       end if;
 106    end Determine_Casing;
 107
 108    ------------------------
 109    -- Set_All_Upper_Case --
 110    ------------------------
 111
 112    procedure Set_All_Upper_Case is
 113    begin
 114       Set_Casing (All_Upper_Case);
 115    end Set_All_Upper_Case;
 116
 117    ----------------
 118    -- Set_Casing --
 119    ----------------
 120
 121    procedure Set_Casing
 122      (Buf : in out Bounded_String;
 123       C   : Casing_Type;
 124       D   : Casing_Type := Mixed_Case)
 125    is
 126       Ptr : Natural;
 127
 128       Actual_Casing : Casing_Type;
 129       --  Set from C or D as appropriate
 130
 131       After_Und : Boolean := True;
 132       --  True at start of string, and after an underline character or after
 133       --  any other special character that is not a normal identifier char).
 134
 135    begin
 136       if C /= Unknown then
 137          Actual_Casing := C;
 138       else
 139          Actual_Casing := D;
 140       end if;
 141
 142       Ptr := 1;
 143
 144       while Ptr <= Buf.Length loop
 145
 146          --  Wide character. Note that we do nothing with casing in this case.
 147          --  In Ada 2005 mode, required folding of lower case letters happened
 148          --  as the identifier was scanned, and we do not attempt any further
 149          --  messing with case (note that in any case we do not know how to
 150          --  fold upper case to lower case in wide character mode). We also
 151          --  do not bother with recognizing punctuation as equivalent to an
 152          --  underscore. There is nothing functional at this stage in doing
 153          --  the requested casing operation, beyond folding to upper case
 154          --  when it is mandatory, which does not involve underscores.
 155
 156          if Buf.Chars (Ptr) = ASCII.ESC
 157            or else Buf.Chars (Ptr) = '['
 158            or else (Upper_Half_Encoding
 159                      and then Buf.Chars (Ptr) in Upper_Half_Character)
 160          then
 161             Skip_Wide (Buf.Chars, Ptr);
 162             After_Und := False;
 163
 164          --  Underscore, or non-identifer character (error case)
 165
 166          elsif Buf.Chars (Ptr) = '_'
 167            or else not Identifier_Char (Buf.Chars (Ptr))
 168          then
 169             After_Und := True;
 170             Ptr := Ptr + 1;
 171
 172          --  Lower case letter
 173
 174          elsif Is_Lower_Case_Letter (Buf.Chars (Ptr)) then
 175             if Actual_Casing = All_Upper_Case
 176               or else (After_Und and then Actual_Casing = Mixed_Case)
 177             then
 178                Buf.Chars (Ptr) := Fold_Upper (Buf.Chars (Ptr));
 179             end if;
 180
 181             After_Und := False;
 182             Ptr := Ptr + 1;
 183
 184          --  Upper case letter
 185
 186          elsif Is_Upper_Case_Letter (Buf.Chars (Ptr)) then
 187             if Actual_Casing = All_Lower_Case
 188               or else (not After_Und and then Actual_Casing = Mixed_Case)
 189             then
 190                Buf.Chars (Ptr) := Fold_Lower (Buf.Chars (Ptr));
 191             end if;
 192
 193             After_Und := False;
 194             Ptr := Ptr + 1;
 195
 196          --  Other identifier character (must be digit)
 197
 198          else
 199             After_Und := False;
 200             Ptr := Ptr + 1;
 201          end if;
 202       end loop;
 203    end Set_Casing;
 204
 205    procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
 206    begin
 207       Set_Casing (Global_Name_Buffer, C, D);
 208    end Set_Casing;
 209
 210 end Casing;