gcc/ada/a-wtenau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --      A D A . 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_Text_IO.Generic_Aux; use Ada.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_Text_IO.Enumeration_Aux is
  40
  41    subtype TFT is Ada.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_Character;
  50       Buf : out 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_String;
  67       Buflen : out Natural)
  68    is
  69       ch  : int;
  70       WC  : 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_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 (Item'First) /= ''' then
 163          declare
 164             Iteml : 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_Character (To_Lower (To_Character (Item (J))));
 171                else
 172                   Iteml (J) := Item (J);
 173                end if;
 174             end loop;
 175
 176             Put (File, Iteml);
 177          end;
 178
 179       else
 180          Put (File, Item);
 181       end if;
 182
 183       for J in 1 .. Actual_Width - Item'Length loop
 184          Put (File, ' ');
 185       end loop;
 186    end Put;
 187
 188    ----------
 189    -- Puts --
 190    ----------
 191
 192    procedure Puts
 193      (To   : out Wide_String;
 194       Item : Wide_String;
 195       Set  : Type_Set)
 196    is
 197       Ptr : Natural;
 198
 199    begin
 200       if Item'Length > To'Length then
 201          raise Layout_Error;
 202
 203       else
 204          Ptr := To'First;
 205          for J in Item'Range loop
 206             if Set = Lower_Case
 207               and then Item (Item'First) /= '''
 208               and then Is_Character (Item (J))
 209             then
 210                To (Ptr) :=
 211                  To_Wide_Character (To_Lower (To_Character (Item (J))));
 212             else
 213                To (Ptr) := Item (J);
 214             end if;
 215
 216             Ptr := Ptr + 1;
 217          end loop;
 218
 219          while Ptr <= To'Last loop
 220             To (Ptr) := ' ';
 221             Ptr := Ptr + 1;
 222          end loop;
 223       end if;
 224    end Puts;
 225
 226    -------------------
 227    -- Scan_Enum_Lit --
 228    -------------------
 229
 230    procedure Scan_Enum_Lit
 231      (From  : Wide_String;
 232       Start : out Natural;
 233       Stop  : out Natural)
 234    is
 235       WC  : Wide_Character;
 236
 237    --  Processing for Scan_Enum_Lit
 238
 239    begin
 240       Start := From'First;
 241
 242       loop
 243          if Start > From'Last then
 244             raise End_Error;
 245
 246          elsif Is_Character (From (Start))
 247            and then not Is_Blank (To_Character (From (Start)))
 248          then
 249             exit;
 250
 251          else
 252             Start := Start + 1;
 253          end if;
 254       end loop;
 255
 256       --  Character literal case. If the initial character is a quote, then
 257       --  we read as far as we can without backup (see ACVC test CE3905L
 258       --  which is for the analogous case for reading from a file).
 259
 260       if From (Start) = ''' then
 261          Stop := Start;
 262
 263          if Stop = From'Last then
 264             raise Data_Error;
 265          else
 266             Stop := Stop + 1;
 267          end if;
 268
 269          if From (Stop) in ' ' .. '~'
 270            or else From (Stop) >= Wide_Character'Val (16#80#)
 271          then
 272             if Stop = From'Last then
 273                raise Data_Error;
 274             else
 275                Stop := Stop + 1;
 276
 277                if From (Stop) = ''' then
 278                   return;
 279                end if;
 280             end if;
 281          end if;
 282
 283          raise Data_Error;
 284
 285       --  Similarly for identifiers, read as far as we can, in particular,
 286       --  do read a trailing underscore (again see ACVC test CE3905L to
 287       --  understand why we do this, although it seems somewhat peculiar).
 288
 289       else
 290          --  Identifier must start with a letter, any wide character outside
 291          --  the normal Latin-1 range is considered a letter for this test.
 292
 293          if Is_Character (From (Start))
 294            and then not Is_Letter (To_Character (From (Start)))
 295          then
 296             raise Data_Error;
 297          end if;
 298
 299          --  If we do have a letter, loop through the characters quitting on
 300          --  the first non-identifier character (note that this includes the
 301          --  cases of hitting a line mark or page mark).
 302
 303          Stop := Start + 1;
 304          while Stop < From'Last loop
 305             WC := From (Stop + 1);
 306
 307             exit when
 308               Is_Character (WC)
 309                 and then
 310                   not Is_Letter (To_Character (WC))
 311                 and then
 312                   not Is_Letter (To_Character (WC))
 313                 and then
 314                   (WC /= '_' or else From (Stop - 1) = '_');
 315
 316             Stop := Stop + 1;
 317          end loop;
 318       end if;
 319
 320    end Scan_Enum_Lit;
 321
 322    ----------------
 323    -- Store_Char --
 324    ----------------
 325
 326    procedure Store_Char
 327      (WC  : Wide_Character;
 328       Buf : out Wide_String;
 329       Ptr : in out Integer)
 330    is
 331    begin
 332       if Ptr = Buf'Last then
 333          raise Data_Error;
 334       else
 335          Ptr := Ptr + 1;
 336          Buf (Ptr) := WC;
 337       end if;
 338    end Store_Char;
 339
 340    --------------
 341    -- To_Lower --
 342    --------------
 343
 344    function To_Lower (C : Character) return Character is
 345    begin
 346       if C in 'A' .. 'Z' then
 347          return Character'Val (Character'Pos (C) + 32);
 348       else
 349          return C;
 350       end if;
 351    end To_Lower;
 352
 353 end Ada.Wide_Text_IO.Enumeration_Aux;