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