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