gcc/ada/a-ztenau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 -- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X--
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2005, 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 Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux;
  35 with Ada.Characters.Handling;           use Ada.Characters.Handling;
  36 with Interfaces.C_Streams;              use Interfaces.C_Streams;
  37 with System.WCh_Con;                    use System.WCh_Con;
  38
  39 package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is
  40
  41    subtype TFT is Ada.Wide_Wide_Text_IO.File_Type;
  42    --  File type required for calls to routines in Aux
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Store_Char
  49      (WC   : Wide_Wide_Character;
  50       Buf  : out Wide_Wide_String;
  51       Ptr  : in out Integer);
  52    --  Store a single character in buffer, checking for overflow.
  53
  54    --  These definitions replace the ones in Ada.Characters.Handling, which
  55    --  do not seem to work for some strange not understood reason ??? at
  56    --  least in the OS/2 version.
  57
  58    function To_Lower (C : Character) return Character;
  59
  60    ------------------
  61    -- Get_Enum_Lit --
  62    ------------------
  63
  64    procedure Get_Enum_Lit
  65      (File   : File_Type;
  66       Buf    : out Wide_Wide_String;
  67       Buflen : out Natural)
  68    is
  69       ch  : int;
  70       WC  : Wide_Wide_Character;
  71
  72    begin
  73       Buflen := 0;
  74       Load_Skip (TFT (File));
  75       ch := Nextc (TFT (File));
  76
  77       --  Character literal case. If the initial character is a quote, then
  78       --  we read as far as we can without backup (see ACVC test CE3905L)
  79
  80       if ch = Character'Pos (''') then
  81          Get (File, WC);
  82          Store_Char (WC, Buf, Buflen);
  83
  84          ch := Nextc (TFT (File));
  85
  86          if ch = LM or else ch = EOF then
  87             return;
  88          end if;
  89
  90          Get (File, WC);
  91          Store_Char (WC, Buf, Buflen);
  92
  93          ch := Nextc (TFT (File));
  94
  95          if ch /= Character'Pos (''') then
  96             return;
  97          end if;
  98
  99          Get (File, WC);
 100          Store_Char (WC, Buf, Buflen);
 101
 102       --  Similarly for identifiers, read as far as we can, in particular,
 103       --  do read a trailing underscore (again see ACVC test CE3905L to
 104       --  understand why we do this, although it seems somewhat peculiar).
 105
 106       else
 107          --  Identifier must start with a letter. Any wide character value
 108          --  outside the normal Latin-1 range counts as a letter for this.
 109
 110          if ch < 255 and then not Is_Letter (Character'Val (ch)) then
 111             return;
 112          end if;
 113
 114          --  If we do have a letter, loop through the characters quitting on
 115          --  the first non-identifier character (note that this includes the
 116          --  cases of hitting a line mark or page mark).
 117
 118          loop
 119             Get (File, WC);
 120             Store_Char (WC, Buf, Buflen);
 121
 122             ch := Nextc (TFT (File));
 123
 124             exit when ch = EOF;
 125
 126             if ch = Character'Pos ('_') then
 127                exit when Buf (Buflen) = '_';
 128
 129             elsif ch = Character'Pos (ASCII.ESC) then
 130                null;
 131
 132             elsif File.WC_Method in WC_Upper_Half_Encoding_Method
 133               and then ch > 127
 134             then
 135                null;
 136
 137             else
 138                exit when not Is_Letter (Character'Val (ch))
 139                            and then
 140                          not Is_Digit (Character'Val (ch));
 141             end if;
 142          end loop;
 143       end if;
 144    end Get_Enum_Lit;
 145
 146    ---------
 147    -- Put --
 148    ---------
 149
 150    procedure Put
 151      (File  : File_Type;
 152       Item  : Wide_Wide_String;
 153       Width : Field;
 154       Set   : Type_Set)
 155    is
 156       Actual_Width : constant Integer :=
 157                        Integer'Max (Integer (Width), Item'Length);
 158
 159    begin
 160       Check_On_One_Line (TFT (File), Actual_Width);
 161
 162       if Set = Lower_Case and then Item (1) /= ''' then
 163          declare
 164             Iteml : Wide_Wide_String (Item'First .. Item'Last);
 165
 166          begin
 167             for J in Item'Range loop
 168                if Is_Character (Item (J)) then
 169                   Iteml (J) :=
 170                     To_Wide_Wide_Character
 171                       (To_Lower (To_Character (Item (J))));
 172                else
 173                   Iteml (J) := Item (J);
 174                end if;
 175             end loop;
 176
 177             Put (File, Iteml);
 178          end;
 179
 180       else
 181          Put (File, Item);
 182       end if;
 183
 184       for J in 1 .. Actual_Width - Item'Length loop
 185          Put (File, ' ');
 186       end loop;
 187    end Put;
 188
 189    ----------
 190    -- Puts --
 191    ----------
 192
 193    procedure Puts
 194      (To    : out Wide_Wide_String;
 195       Item  : Wide_Wide_String;
 196       Set   : Type_Set)
 197    is
 198       Ptr : Natural;
 199
 200    begin
 201       if Item'Length > To'Length then
 202          raise Layout_Error;
 203
 204       else
 205          Ptr := To'First;
 206          for J in Item'Range loop
 207             if Set = Lower_Case
 208               and then Item (1) /= '''
 209               and then Is_Character (Item (J))
 210             then
 211                To (Ptr) :=
 212                  To_Wide_Wide_Character (To_Lower (To_Character (Item (J))));
 213             else
 214                To (Ptr) := Item (J);
 215             end if;
 216
 217             Ptr := Ptr + 1;
 218          end loop;
 219
 220          while Ptr <= To'Last loop
 221             To (Ptr) := ' ';
 222             Ptr := Ptr + 1;
 223          end loop;
 224       end if;
 225    end Puts;
 226
 227    -------------------
 228    -- Scan_Enum_Lit --
 229    -------------------
 230
 231    procedure Scan_Enum_Lit
 232      (From  : Wide_Wide_String;
 233       Start : out Natural;
 234       Stop  : out Natural)
 235    is
 236       WC  : Wide_Wide_Character;
 237
 238    --  Processing for Scan_Enum_Lit
 239
 240    begin
 241       Start := From'First;
 242
 243       loop
 244          if Start > From'Last then
 245             raise End_Error;
 246
 247          elsif Is_Character (From (Start))
 248            and then not Is_Blank (To_Character (From (Start)))
 249          then
 250             exit;
 251
 252          else
 253             Start := Start + 1;
 254          end if;
 255       end loop;
 256
 257       --  Character literal case. If the initial character is a quote, then
 258       --  we read as far as we can without backup (see ACVC test CE3905L
 259       --  which is for the analogous case for reading from a file).
 260
 261       if From (Start) = ''' then
 262          Stop := Start;
 263
 264          if Stop = From'Last then
 265             raise Data_Error;
 266          else
 267             Stop := Stop + 1;
 268          end if;
 269
 270          if From (Stop) in ' ' .. '~'
 271            or else From (Stop) >= Wide_Wide_Character'Val (16#80#)
 272          then
 273             if Stop = From'Last then
 274                raise Data_Error;
 275             else
 276                Stop := Stop + 1;
 277
 278                if From (Stop) = ''' then
 279                   return;
 280                end if;
 281             end if;
 282          end if;
 283
 284          raise Data_Error;
 285
 286       --  Similarly for identifiers, read as far as we can, in particular,
 287       --  do read a trailing underscore (again see ACVC test CE3905L to
 288       --  understand why we do this, although it seems somewhat peculiar).
 289
 290       else
 291          --  Identifier must start with a letter, any wide character outside
 292          --  the normal Latin-1 range is considered a letter for this test.
 293
 294          if Is_Character (From (Start))
 295            and then not Is_Letter (To_Character (From (Start)))
 296          then
 297             raise Data_Error;
 298          end if;
 299
 300          --  If we do have a letter, loop through the characters quitting on
 301          --  the first non-identifier character (note that this includes the
 302          --  cases of hitting a line mark or page mark).
 303
 304          Stop := Start + 1;
 305          while Stop < From'Last loop
 306             WC := From (Stop + 1);
 307
 308             exit when
 309               Is_Character (WC)
 310                 and then
 311                   not Is_Letter (To_Character (WC))
 312                 and then
 313                   not Is_Letter (To_Character (WC))
 314                 and then
 315                   (WC /= '_' or else From (Stop - 1) = '_');
 316
 317             Stop := Stop + 1;
 318          end loop;
 319       end if;
 320
 321    end Scan_Enum_Lit;
 322
 323    ----------------
 324    -- Store_Char --
 325    ----------------
 326
 327    procedure Store_Char
 328      (WC   : Wide_Wide_Character;
 329       Buf  : out Wide_Wide_String;
 330       Ptr  : in out Integer)
 331    is
 332    begin
 333       if Ptr = Buf'Last then
 334          raise Data_Error;
 335       else
 336          Ptr := Ptr + 1;
 337          Buf (Ptr) := WC;
 338       end if;
 339    end Store_Char;
 340
 341    --------------
 342    -- To_Lower --
 343    --------------
 344
 345    function To_Lower (C : Character) return Character is
 346    begin
 347       if C in 'A' .. 'Z' then
 348          return Character'Val (Character'Pos (C) + 32);
 349       else
 350          return C;
 351       end if;
 352    end To_Lower;
 353
 354 end Ada.Wide_Wide_Text_IO.Enumeration_Aux;