gcc/ada/a-wtenau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME 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-2002, 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_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 Is_Letter (Character'Val (ch))
 139                  and then not Is_Digit (Character'Val (ch));
 140             end if;
 141          end loop;
 142       end if;
 143    end Get_Enum_Lit;
 144
 145    ---------
 146    -- Put --
 147    ---------
 148
 149    procedure Put
 150      (File  : File_Type;
 151       Item  : Wide_String;
 152       Width : Field;
 153       Set   : Type_Set)
 154    is
 155       Actual_Width : constant Integer :=
 156                        Integer'Max (Integer (Width), Item'Length);
 157
 158    begin
 159       Check_On_One_Line (TFT (File), Actual_Width);
 160
 161       if Set = Lower_Case and then Item (1) /= ''' then
 162          declare
 163             Iteml : Wide_String (Item'First .. Item'Last);
 164
 165          begin
 166             for J in Item'Range loop
 167                if Is_Character (Item (J)) then
 168                   Iteml (J) :=
 169                     To_Wide_Character (To_Lower (To_Character (Item (J))));
 170                else
 171                   Iteml (J) := Item (J);
 172                end if;
 173             end loop;
 174
 175             Put (File, Iteml);
 176          end;
 177
 178       else
 179          Put (File, Item);
 180       end if;
 181
 182       for J in 1 .. Actual_Width - Item'Length loop
 183          Put (File, ' ');
 184       end loop;
 185    end Put;
 186
 187    ----------
 188    -- Puts --
 189    ----------
 190
 191    procedure Puts
 192      (To    : out Wide_String;
 193       Item  : in Wide_String;
 194       Set   : Type_Set)
 195    is
 196       Ptr : Natural;
 197
 198    begin
 199       if Item'Length > To'Length then
 200          raise Layout_Error;
 201
 202       else
 203          Ptr := To'First;
 204          for J in Item'Range loop
 205             if Set = Lower_Case
 206               and then Item (1) /= '''
 207               and then Is_Character (Item (J))
 208             then
 209                To (Ptr) :=
 210                  To_Wide_Character (To_Lower (To_Character (Item (J))));
 211             else
 212                To (Ptr) := Item (J);
 213             end if;
 214
 215             Ptr := Ptr + 1;
 216          end loop;
 217
 218          while Ptr <= To'Last loop
 219             To (Ptr) := ' ';
 220             Ptr := Ptr + 1;
 221          end loop;
 222       end if;
 223    end Puts;
 224
 225    -------------------
 226    -- Scan_Enum_Lit --
 227    -------------------
 228
 229    procedure Scan_Enum_Lit
 230      (From  : Wide_String;
 231       Start : out Natural;
 232       Stop  : out Natural)
 233    is
 234       WC  : Wide_Character;
 235
 236    --  Processing for Scan_Enum_Lit
 237
 238    begin
 239       Start := From'First;
 240
 241       loop
 242          if Start > From'Last then
 243             raise End_Error;
 244
 245          elsif Is_Character (From (Start))
 246            and then not Is_Blank (To_Character (From (Start)))
 247          then
 248             exit;
 249
 250          else
 251             Start := Start + 1;
 252          end if;
 253       end loop;
 254
 255       --  Character literal case. If the initial character is a quote, then
 256       --  we read as far as we can without backup (see ACVC test CE3905L
 257       --  which is for the analogous case for reading from a file).
 258
 259       if From (Start) = ''' then
 260          Stop := Start;
 261
 262          if Stop = From'Last then
 263             raise Data_Error;
 264          else
 265             Stop := Stop + 1;
 266          end if;
 267
 268          if From (Stop) in ' ' .. '~'
 269            or else From (Stop) >= Wide_Character'Val (16#80#)
 270          then
 271             if Stop = From'Last then
 272                raise Data_Error;
 273             else
 274                Stop := Stop + 1;
 275
 276                if From (Stop) = ''' then
 277                   return;
 278                end if;
 279             end if;
 280          end if;
 281
 282          Stop := Stop - 1;
 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;