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-2023, 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_Casing --
 110    ----------------
 111
 112    procedure Set_Casing
 113      (Buf : in out Bounded_String;
 114       C   : Casing_Type;
 115       D   : Casing_Type := Mixed_Case)
 116    is
 117       Ptr : Natural;
 118
 119       Actual_Casing : Casing_Type;
 120       --  Set from C or D as appropriate
 121
 122       After_Und : Boolean := True;
 123       --  True at start of string, and after an underline character or after
 124       --  any other special character that is not a normal identifier char).
 125
 126    begin
 127       if C /= Unknown then
 128          Actual_Casing := C;
 129       else
 130          Actual_Casing := D;
 131       end if;
 132
 133       Ptr := 1;
 134
 135       while Ptr <= Buf.Length loop
 136
 137          --  Wide character. Note that we do nothing with casing in this case.
 138          --  In Ada 2005 mode, required folding of lower case letters happened
 139          --  as the identifier was scanned, and we do not attempt any further
 140          --  messing with case (note that in any case we do not know how to
 141          --  fold upper case to lower case in wide character mode). We also
 142          --  do not bother with recognizing punctuation as equivalent to an
 143          --  underscore. There is nothing functional at this stage in doing
 144          --  the requested casing operation, beyond folding to upper case
 145          --  when it is mandatory, which does not involve underscores.
 146
 147          if Buf.Chars (Ptr) = ASCII.ESC
 148            or else Buf.Chars (Ptr) = '['
 149            or else (Upper_Half_Encoding
 150                      and then Buf.Chars (Ptr) in Upper_Half_Character)
 151          then
 152             Skip_Wide (Buf.Chars, Ptr);
 153             After_Und := False;
 154
 155          --  Underscore, or non-identifer character (error case)
 156
 157          elsif Buf.Chars (Ptr) = '_'
 158            or else not Identifier_Char (Buf.Chars (Ptr))
 159          then
 160             After_Und := True;
 161             Ptr := Ptr + 1;
 162
 163          --  Lower case letter
 164
 165          elsif Is_Lower_Case_Letter (Buf.Chars (Ptr)) then
 166             if Actual_Casing = All_Upper_Case
 167               or else (After_Und and then Actual_Casing = Mixed_Case)
 168             then
 169                Buf.Chars (Ptr) := Fold_Upper (Buf.Chars (Ptr));
 170             end if;
 171
 172             After_Und := False;
 173             Ptr := Ptr + 1;
 174
 175          --  Upper case letter
 176
 177          elsif Is_Upper_Case_Letter (Buf.Chars (Ptr)) then
 178             if Actual_Casing = All_Lower_Case
 179               or else (not After_Und and then Actual_Casing = Mixed_Case)
 180             then
 181                Buf.Chars (Ptr) := Fold_Lower (Buf.Chars (Ptr));
 182             end if;
 183
 184             After_Und := False;
 185             Ptr := Ptr + 1;
 186
 187          --  Other identifier character (must be digit)
 188
 189          else
 190             After_Und := False;
 191             Ptr := Ptr + 1;
 192          end if;
 193       end loop;
 194    end Set_Casing;
 195
 196    procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
 197    begin
 198       Set_Casing (Global_Name_Buffer, C, D);
 199    end Set_Casing;
 200
 201 end Casing;