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