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 --                                                                          --
  10 --          Copyright (C) 1992-2002, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux;
  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_Text_IO.Enumeration_Aux is
  41
  42    subtype TFT is Ada.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_Character;
  51       Buf  : out 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_String;
  68       Buflen : out Natural)
  69    is
  70       ch  : int;
  71       WC  : 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 Is_Letter (Character'Val (ch))
 140                  and then 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 (1) /= ''' 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  : in 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 (1) /= '''
 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          Stop := Stop - 1;
 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_Character;
 329       Buf  : out 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_Text_IO.Enumeration_Aux;