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