aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/a-ztenau.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/a-ztenau.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/a-ztenau.adb353
1 files changed, 353 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/a-ztenau.adb b/gcc-4.4.3/gcc/ada/a-ztenau.adb
new file mode 100644
index 000000000..c5776366b
--- /dev/null
+++ b/gcc-4.4.3/gcc/ada/a-ztenau.adb
@@ -0,0 +1,353 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2009, 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 3, 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. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
+with Ada.Characters.Conversions; use Ada.Characters.Conversions;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Interfaces.C_Streams; use Interfaces.C_Streams;
+with System.WCh_Con; use System.WCh_Con;
+
+package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
+
+ subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
+ -- File type required for calls to routines in Aux
+
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Store_Char
+ (WC : Wide_Wide_Character;
+ Buf : out Wide_Wide_String;
+ Ptr : in out Integer);
+ -- Store a single character in buffer, checking for overflow
+
+ -- These definitions replace the ones in Ada.Characters.Handling, which
+ -- do not seem to work for some strange not understood reason ??? at
+ -- least in the OS/2 version.
+
+ function To_Lower (C : Character) return Character;
+
+ ------------------
+ -- Get_Enum_Lit --
+ ------------------
+
+ procedure Get_Enum_Lit
+ (File : File_Type;
+ Buf : out Wide_Wide_String;
+ Buflen : out Natural)
+ is
+ ch : int;
+ WC : Wide_Wide_Character;
+
+ begin
+ Buflen := 0;
+ Load_Skip (TFT (File));
+ ch := Nextc (TFT (File));
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L)
+
+ if ch = Character'Pos (''') then
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ if ch = LM or else ch = EOF then
+ return;
+ end if;
+
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ if ch /= Character'Pos (''') then
+ return;
+ end if;
+
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter. Any wide character value
+ -- outside the normal Latin-1 range counts as a letter for this.
+
+ if ch < 255 and then not Is_Letter (Character'Val (ch)) then
+ return;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ loop
+ Get (File, WC);
+ Store_Char (WC, Buf, Buflen);
+
+ ch := Nextc (TFT (File));
+
+ exit when ch = EOF;
+
+ if ch = Character'Pos ('_') then
+ exit when Buf (Buflen) = '_';
+
+ elsif ch = Character'Pos (ASCII.ESC) then
+ null;
+
+ elsif File.WC_Method in WC_Upper_Half_Encoding_Method
+ and then ch > 127
+ then
+ null;
+
+ else
+ exit when not Is_Letter (Character'Val (ch))
+ and then
+ not Is_Digit (Character'Val (ch));
+ end if;
+ end loop;
+ end if;
+ end Get_Enum_Lit;
+
+ ---------
+ -- Put --
+ ---------
+
+ procedure Put
+ (File : File_Type;
+ Item : Wide_Wide_String;
+ Width : Field;
+ Set : Type_Set)
+ is
+ Actual_Width : constant Integer :=
+ Integer'Max (Integer (Width), Item'Length);
+
+ begin
+ Check_On_One_Line (TFT (File), Actual_Width);
+
+ if Set = Lower_Case and then Item (Item'First) /= ''' then
+ declare
+ Iteml : Wide_Wide_String (Item'First .. Item'Last);
+
+ begin
+ for J in Item'Range loop
+ if Is_Character (Item (J)) then
+ Iteml (J) :=
+ To_Wide_Wide_Character
+ (To_Lower (To_Character (Item (J))));
+ else
+ Iteml (J) := Item (J);
+ end if;
+ end loop;
+
+ Put (File, Iteml);
+ end;
+
+ else
+ Put (File, Item);
+ end if;
+
+ for J in 1 .. Actual_Width - Item'Length loop
+ Put (File, ' ');
+ end loop;
+ end Put;
+
+ ----------
+ -- Puts --
+ ----------
+
+ procedure Puts
+ (To : out Wide_Wide_String;
+ Item : Wide_Wide_String;
+ Set : Type_Set)
+ is
+ Ptr : Natural;
+
+ begin
+ if Item'Length > To'Length then
+ raise Layout_Error;
+
+ else
+ Ptr := To'First;
+ for J in Item'Range loop
+ if Set = Lower_Case
+ and then Item (Item'First) /= '''
+ and then Is_Character (Item (J))
+ then
+ To (Ptr) :=
+ To_Wide_Wide_Character (To_Lower (To_Character (Item (J))));
+ else
+ To (Ptr) := Item (J);
+ end if;
+
+ Ptr := Ptr + 1;
+ end loop;
+
+ while Ptr <= To'Last loop
+ To (Ptr) := ' ';
+ Ptr := Ptr + 1;
+ end loop;
+ end if;
+ end Puts;
+
+ -------------------
+ -- Scan_Enum_Lit --
+ -------------------
+
+ procedure Scan_Enum_Lit
+ (From : Wide_Wide_String;
+ Start : out Natural;
+ Stop : out Natural)
+ is
+ WC : Wide_Wide_Character;
+
+ -- Processing for Scan_Enum_Lit
+
+ begin
+ Start := From'First;
+
+ loop
+ if Start > From'Last then
+ raise End_Error;
+
+ elsif Is_Character (From (Start))
+ and then not Is_Blank (To_Character (From (Start)))
+ then
+ exit;
+
+ else
+ Start := Start + 1;
+ end if;
+ end loop;
+
+ -- Character literal case. If the initial character is a quote, then
+ -- we read as far as we can without backup (see ACVC test CE3905L
+ -- which is for the analogous case for reading from a file).
+
+ if From (Start) = ''' then
+ Stop := Start;
+
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+ end if;
+
+ if From (Stop) in ' ' .. '~'
+ or else From (Stop) >= Wide_Wide_Character'Val (16#80#)
+ then
+ if Stop = From'Last then
+ raise Data_Error;
+ else
+ Stop := Stop + 1;
+
+ if From (Stop) = ''' then
+ return;
+ end if;
+ end if;
+ end if;
+
+ raise Data_Error;
+
+ -- Similarly for identifiers, read as far as we can, in particular,
+ -- do read a trailing underscore (again see ACVC test CE3905L to
+ -- understand why we do this, although it seems somewhat peculiar).
+
+ else
+ -- Identifier must start with a letter, any wide character outside
+ -- the normal Latin-1 range is considered a letter for this test.
+
+ if Is_Character (From (Start))
+ and then not Is_Letter (To_Character (From (Start)))
+ then
+ raise Data_Error;
+ end if;
+
+ -- If we do have a letter, loop through the characters quitting on
+ -- the first non-identifier character (note that this includes the
+ -- cases of hitting a line mark or page mark).
+
+ Stop := Start + 1;
+ while Stop < From'Last loop
+ WC := From (Stop + 1);
+
+ exit when
+ Is_Character (WC)
+ and then
+ not Is_Letter (To_Character (WC))
+ and then
+ not Is_Letter (To_Character (WC))
+ and then
+ (WC /= '_' or else From (Stop - 1) = '_');
+
+ Stop := Stop + 1;
+ end loop;
+ end if;
+
+ end Scan_Enum_Lit;
+
+ ----------------
+ -- Store_Char --
+ ----------------
+
+ procedure Store_Char
+ (WC : Wide_Wide_Character;
+ Buf : out Wide_Wide_String;
+ Ptr : in out Integer)
+ is
+ begin
+ if Ptr = Buf'Last then
+ raise Data_Error;
+ else
+ Ptr := Ptr + 1;
+ Buf (Ptr) := WC;
+ end if;
+ end Store_Char;
+
+ --------------
+ -- To_Lower --
+ --------------
+
+ function To_Lower (C : Character) return Character is
+ begin
+ if C in 'A' .. 'Z' then
+ return Character'Val (Character'Pos (C) + 32);
+ else
+ return C;
+ end if;
+ end To_Lower;
+
+end Ada.Wide_Wide_Text_IO.Enumeration_Aux;