home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / casing.adb < prev    next >
Text File  |  1996-09-28  |  4KB  |  109 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                               C A S I N G                                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.18 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- The GNAT library is free software; you can redistribute it and/or modify --
  14. -- it under terms of the GNU Library General Public License as published by --
  15. -- the Free Software  Foundation; either version 2, or (at your option) any --
  16. -- later version.  The GNAT library is distributed in the hope that it will --
  17. -- be useful, but WITHOUT ANY WARRANTY;  without even  the implied warranty --
  18. -- of MERCHANTABILITY  or  FITNESS FOR  A PARTICULAR PURPOSE.  See the  GNU --
  19. -- Library  General  Public  License for  more  details.  You  should  have --
  20. -- received  a copy of the GNU  Library  General Public License  along with --
  21. -- the GNAT library;  see the file  COPYING.LIB.  If not, write to the Free --
  22. -- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.        --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with Csets;    use Csets;
  27. with Namet;    use Namet;
  28. with Opt;      use Opt;
  29. with Sinput;   use Sinput;
  30. with Types;    use Types;
  31. with Widechar; use Widechar;
  32.  
  33. package body Casing is
  34.  
  35.    ----------------
  36.    -- Set_Casing --
  37.    ----------------
  38.  
  39.    procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
  40.       Ptr : Natural;
  41.  
  42.       Actual_Casing : Casing_Type;
  43.       --  Set from C or D as appropriate
  44.  
  45.       After_Und : Boolean := True;
  46.       --  True at start of string, and after an underline character or after
  47.       --  any other special character that is not a normal identifier char).
  48.  
  49.    begin
  50.       if C /= Unknown then
  51.          Actual_Casing := C;
  52.       else
  53.          Actual_Casing := D;
  54.       end if;
  55.  
  56.       Ptr := 1;
  57.  
  58.       while Ptr <= Name_Len loop
  59.          if Name_Buffer (Ptr) = Ascii.ESC
  60.            or else (Upper_Half_Encoding
  61.                      and then Name_Buffer (Ptr) in Upper_Half_Character)
  62.          then
  63.             Skip_Wide (Name_Buffer, Ptr);
  64.             After_Und := False;
  65.  
  66.          elsif Name_Buffer (Ptr) = '_'
  67.             or else not Identifier_Char (Name_Buffer (Ptr))
  68.          then
  69.             After_Und := True;
  70.             Ptr := Ptr + 1;
  71.  
  72.          elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then
  73.             if Actual_Casing = All_Upper_Case
  74.               or else (After_Und and then Actual_Casing = Mixed_Case)
  75.             then
  76.                Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr));
  77.             end if;
  78.  
  79.             After_Und := False;
  80.             Ptr := Ptr + 1;
  81.  
  82.          elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then
  83.             if Actual_Casing = All_Lower_Case
  84.               or else (not After_Und and then Actual_Casing = Mixed_Case)
  85.             then
  86.                Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr));
  87.             end if;
  88.  
  89.             After_Und := False;
  90.             Ptr := Ptr + 1;
  91.  
  92.          else  --  all other characters
  93.             After_Und := False;
  94.             Ptr := Ptr + 1;
  95.          end if;
  96.       end loop;
  97.    end Set_Casing;
  98.  
  99.    ------------------------
  100.    -- Set_All_Upper_Case --
  101.    ------------------------
  102.  
  103.    procedure Set_All_Upper_Case is
  104.    begin
  105.       Set_Casing (All_Upper_Case);
  106.    end Set_All_Upper_Case;
  107.  
  108. end Casing;
  109.