aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.2.1/gcc/ada/casing.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.2.1/gcc/ada/casing.adb')
-rw-r--r--gcc-4.2.1/gcc/ada/casing.adb202
1 files changed, 202 insertions, 0 deletions
diff --git a/gcc-4.2.1/gcc/ada/casing.adb b/gcc-4.2.1/gcc/ada/casing.adb
new file mode 100644
index 000000000..30db5459d
--- /dev/null
+++ b/gcc-4.2.1/gcc/ada/casing.adb
@@ -0,0 +1,202 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- C A S I N G --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 2, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
+-- for more details. You should have received a copy of the GNU General --
+-- Public License distributed with GNAT; see file COPYING. If not, write --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
+-- --
+-- As a special exception, if other files instantiate generics from this --
+-- unit, or you link this unit with other files to produce an executable, --
+-- this unit does not by itself cause the resulting executable to be --
+-- covered by the GNU General Public License. This exception does not --
+-- however invalidate any other reasons why the executable file might be --
+-- covered by the GNU Public License. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Csets; use Csets;
+with Namet; use Namet;
+with Opt; use Opt;
+with Widechar; use Widechar;
+
+package body Casing is
+
+ ----------------------
+ -- Determine_Casing --
+ ----------------------
+
+ function Determine_Casing (Ident : Text_Buffer) return Casing_Type is
+
+ All_Lower : Boolean := True;
+ -- Set False if upper case letter found
+
+ All_Upper : Boolean := True;
+ -- Set False if lower case letter found
+
+ Mixed : Boolean := True;
+ -- Set False if exception to mixed case rule found (lower case letter
+ -- at start or after underline, or upper case letter elsewhere).
+
+ Decisive : Boolean := False;
+ -- Set True if at least one instance of letter not after underline
+
+ After_Und : Boolean := True;
+ -- True at start of string, and after an underline character
+
+ begin
+ for S in Ident'Range loop
+ if Ident (S) = '_' or else Ident (S) = '.' then
+ After_Und := True;
+
+ elsif Is_Lower_Case_Letter (Ident (S)) then
+ All_Upper := False;
+
+ if not After_Und then
+ Decisive := True;
+ else
+ After_Und := False;
+ Mixed := False;
+ end if;
+
+ elsif Is_Upper_Case_Letter (Ident (S)) then
+ All_Lower := False;
+
+ if not After_Und then
+ Decisive := True;
+ Mixed := False;
+ else
+ After_Und := False;
+ end if;
+ end if;
+ end loop;
+
+ -- Now we can figure out the result from the flags we set in that loop
+
+ if All_Lower then
+ return All_Lower_Case;
+
+ elsif not Decisive then
+ return Unknown;
+
+ elsif All_Upper then
+ return All_Upper_Case;
+
+ elsif Mixed then
+ return Mixed_Case;
+
+ else
+ return Unknown;
+ end if;
+ end Determine_Casing;
+
+ ------------------------
+ -- Set_All_Upper_Case --
+ ------------------------
+
+ procedure Set_All_Upper_Case is
+ begin
+ Set_Casing (All_Upper_Case);
+ end Set_All_Upper_Case;
+
+ ----------------
+ -- Set_Casing --
+ ----------------
+
+ procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
+ Ptr : Natural;
+
+ Actual_Casing : Casing_Type;
+ -- Set from C or D as appropriate
+
+ After_Und : Boolean := True;
+ -- True at start of string, and after an underline character or after
+ -- any other special character that is not a normal identifier char).
+
+ begin
+ if C /= Unknown then
+ Actual_Casing := C;
+ else
+ Actual_Casing := D;
+ end if;
+
+ Ptr := 1;
+
+ while Ptr <= Name_Len loop
+
+ -- Wide character. Note that we do nothing with casing in this case.
+ -- In Ada 2005 mode, required folding of lower case letters happened
+ -- as the identifier was scanned, and we do not attempt any further
+ -- messing with case (note that in any case we do not know how to
+ -- fold upper case to lower case in wide character mode). We also
+ -- do not bother with recognizing punctuation as equivalent to an
+ -- underscore. There is nothing functional at this stage in doing
+ -- the requested casing operation, beyond folding to upper case
+ -- when it is mandatory, which does not involve underscores.
+
+ if Name_Buffer (Ptr) = ASCII.ESC
+ or else Name_Buffer (Ptr) = '['
+ or else (Upper_Half_Encoding
+ and then Name_Buffer (Ptr) in Upper_Half_Character)
+ then
+ Skip_Wide (Name_Buffer, Ptr);
+ After_Und := False;
+
+ -- Underscore, or non-identifer character (error case)
+
+ elsif Name_Buffer (Ptr) = '_'
+ or else not Identifier_Char (Name_Buffer (Ptr))
+ then
+ After_Und := True;
+ Ptr := Ptr + 1;
+
+ -- Lower case letter
+
+ elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then
+ if Actual_Casing = All_Upper_Case
+ or else (After_Und and then Actual_Casing = Mixed_Case)
+ then
+ Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr));
+ end if;
+
+ After_Und := False;
+ Ptr := Ptr + 1;
+
+ -- Upper case letter
+
+ elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then
+ if Actual_Casing = All_Lower_Case
+ or else (not After_Und and then Actual_Casing = Mixed_Case)
+ then
+ Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr));
+ end if;
+
+ After_Und := False;
+ Ptr := Ptr + 1;
+
+ -- Other identifier character (must be digit)
+
+ else
+ After_Und := False;
+ Ptr := Ptr + 1;
+ end if;
+ end loop;
+ end Set_Casing;
+
+end Casing;