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-2001 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,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, 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 Types;    use Types;
  38 with Widechar; use Widechar;
  39
  40 package body Casing is
  41
  42    ----------------------
  43    -- Determine_Casing --
  44    ----------------------
  45
  46    function Determine_Casing (Ident : Text_Buffer) return Casing_Type is
  47
  48       All_Lower : Boolean := True;
  49       --  Set False if upper case letter found
  50
  51       All_Upper : Boolean := True;
  52       --  Set False if lower case letter found
  53
  54       Mixed : Boolean := True;
  55       --  Set False if exception to mixed case rule found (lower case letter
  56       --  at start or after underline, or upper case letter elsewhere).
  57
  58       Decisive : Boolean := False;
  59       --  Set True if at least one instance of letter not after underline
  60
  61       After_Und : Boolean := True;
  62       --  True at start of string, and after an underline character
  63
  64    begin
  65       for S in Ident'Range loop
  66          if Ident (S) = '_' or else Ident (S) = '.' then
  67             After_Und := True;
  68
  69          elsif Is_Lower_Case_Letter (Ident (S)) then
  70             All_Upper := False;
  71
  72             if not After_Und then
  73                Decisive := True;
  74             else
  75                After_Und := False;
  76                Mixed := False;
  77             end if;
  78
  79          elsif Is_Upper_Case_Letter (Ident (S)) then
  80             All_Lower := False;
  81
  82             if not After_Und then
  83                Decisive := True;
  84                Mixed := False;
  85             else
  86                After_Und := False;
  87             end if;
  88          end if;
  89       end loop;
  90
  91       --  Now we can figure out the result from the flags we set in that loop
  92
  93       if All_Lower then
  94          return All_Lower_Case;
  95
  96       elsif not Decisive then
  97          return Unknown;
  98
  99       elsif All_Upper then
 100          return All_Upper_Case;
 101
 102       elsif Mixed then
 103          return Mixed_Case;
 104
 105       else
 106          return Unknown;
 107       end if;
 108    end Determine_Casing;
 109
 110    ------------------------
 111    -- Set_All_Upper_Case --
 112    ------------------------
 113
 114    procedure Set_All_Upper_Case is
 115    begin
 116       Set_Casing (All_Upper_Case);
 117    end Set_All_Upper_Case;
 118
 119    ----------------
 120    -- Set_Casing --
 121    ----------------
 122
 123    procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
 124       Ptr : Natural;
 125
 126       Actual_Casing : Casing_Type;
 127       --  Set from C or D as appropriate
 128
 129       After_Und : Boolean := True;
 130       --  True at start of string, and after an underline character or after
 131       --  any other special character that is not a normal identifier char).
 132
 133    begin
 134       if C /= Unknown then
 135          Actual_Casing := C;
 136       else
 137          Actual_Casing := D;
 138       end if;
 139
 140       Ptr := 1;
 141
 142       while Ptr <= Name_Len loop
 143          if Name_Buffer (Ptr) = ASCII.ESC
 144            or else Name_Buffer (Ptr) = '['
 145            or else (Upper_Half_Encoding
 146                      and then Name_Buffer (Ptr) in Upper_Half_Character)
 147          then
 148             Skip_Wide (Name_Buffer, Ptr);
 149             After_Und := False;
 150
 151          elsif Name_Buffer (Ptr) = '_'
 152             or else not Identifier_Char (Name_Buffer (Ptr))
 153          then
 154             After_Und := True;
 155             Ptr := Ptr + 1;
 156
 157          elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then
 158             if Actual_Casing = All_Upper_Case
 159               or else (After_Und and then Actual_Casing = Mixed_Case)
 160             then
 161                Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr));
 162             end if;
 163
 164             After_Und := False;
 165             Ptr := Ptr + 1;
 166
 167          elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then
 168             if Actual_Casing = All_Lower_Case
 169               or else (not After_Und and then Actual_Casing = Mixed_Case)
 170             then
 171                Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr));
 172             end if;
 173
 174             After_Und := False;
 175             Ptr := Ptr + 1;
 176
 177          else  --  all other characters
 178             After_Und := False;
 179             Ptr := Ptr + 1;
 180          end if;
 181       end loop;
 182    end Set_Casing;
 183
 184 end Casing;