gcc/ada/a-ztenau.adb

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