gcc/ada/a-tienau.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --          A D A . 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-2001 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.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  35 with Ada.Characters.Handling; use Ada.Characters.Handling;
  36 with Interfaces.C_Streams;    use Interfaces.C_Streams;
  37
  38 --  Note: this package does not yet deal properly with wide characters ???
  39
  40 package body Ada.Text_IO.Enumeration_Aux is
  41
  42    -----------------------
  43    -- Local Subprograms --
  44    -----------------------
  45
  46    --  These definitions replace the ones in Ada.Characters.Handling, which
  47    --  do not seem to work for some strange not understood reason ??? at
  48    --  least in the OS/2 version.
  49
  50    function To_Lower (C : Character) return Character;
  51    function To_Upper (C : Character) return Character;
  52
  53    ------------------
  54    -- Get_Enum_Lit --
  55    ------------------
  56
  57    procedure Get_Enum_Lit
  58      (File   : File_Type;
  59       Buf    : out String;
  60       Buflen : out Natural)
  61    is
  62       ch  : int;
  63       C   : Character;
  64
  65    begin
  66       Buflen := 0;
  67       Load_Skip (File);
  68       ch := Getc (File);
  69       C := Character'Val (ch);
  70
  71       --  Character literal case. If the initial character is a quote, then
  72       --  we read as far as we can without backup (see ACVC test CE3905L)
  73
  74       if C = ''' then
  75          Store_Char (File, ch, Buf, Buflen);
  76
  77          ch := Getc (File);
  78
  79          if ch in 16#20# .. 16#7E# or else ch >= 16#80# then
  80             Store_Char (File, ch, Buf, Buflen);
  81
  82             ch := Getc (File);
  83
  84             if ch = Character'Pos (''') then
  85                Store_Char (File, ch, Buf, Buflen);
  86             else
  87                Ungetc (ch, File);
  88             end if;
  89
  90          else
  91             Ungetc (ch, File);
  92          end if;
  93
  94       --  Similarly for identifiers, read as far as we can, in particular,
  95       --  do read a trailing underscore (again see ACVC test CE3905L to
  96       --  understand why we do this, although it seems somewhat peculiar).
  97
  98       else
  99          --  Identifier must start with a letter
 100
 101          if not Is_Letter (C) then
 102             Ungetc (ch, File);
 103             return;
 104          end if;
 105
 106          --  If we do have a letter, loop through the characters quitting on
 107          --  the first non-identifier character (note that this includes the
 108          --  cases of hitting a line mark or page mark).
 109
 110          loop
 111             C := Character'Val (ch);
 112             Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen);
 113
 114             ch := Getc (File);
 115             exit when ch = EOF;
 116             C := Character'Val (ch);
 117
 118             exit when not Is_Letter (C)
 119               and then not Is_Digit (C)
 120               and then C /= '_';
 121
 122             exit when C = '_'
 123               and then Buf (Buflen) = '_';
 124          end loop;
 125
 126          Ungetc (ch, File);
 127       end if;
 128    end Get_Enum_Lit;
 129
 130    ---------
 131    -- Put --
 132    ---------
 133
 134    procedure Put
 135      (File  : File_Type;
 136       Item  : String;
 137       Width : Field;
 138       Set   : Type_Set)
 139    is
 140       Actual_Width : constant Count := Count'Max (Count (Width), Item'Length);
 141
 142    begin
 143       if Set = Lower_Case and then Item (1) /= ''' then
 144          declare
 145             Iteml : String (Item'First .. Item'Last);
 146
 147          begin
 148             for J in Item'Range loop
 149                Iteml (J) := To_Lower (Item (J));
 150             end loop;
 151
 152             Put_Item (File, Iteml);
 153          end;
 154
 155       else
 156          Put_Item (File, Item);
 157       end if;
 158
 159       for J in 1 .. Actual_Width - Item'Length loop
 160          Put (File, ' ');
 161       end loop;
 162    end Put;
 163
 164    ----------
 165    -- Puts --
 166    ----------
 167
 168    procedure Puts
 169      (To    : out String;
 170       Item  : in String;
 171       Set   : Type_Set)
 172    is
 173       Ptr : Natural;
 174
 175    begin
 176       if Item'Length > To'Length then
 177          raise Layout_Error;
 178
 179       else
 180          Ptr := To'First;
 181          for J in Item'Range loop
 182             if Set = Lower_Case and then Item (1) /= ''' then
 183                To (Ptr) := To_Lower (Item (J));
 184             else
 185                To (Ptr) := Item (J);
 186             end if;
 187
 188             Ptr := Ptr + 1;
 189          end loop;
 190
 191          while Ptr <= To'Last loop
 192             To (Ptr) := ' ';
 193             Ptr := Ptr + 1;
 194          end loop;
 195       end if;
 196    end Puts;
 197
 198    -------------------
 199    -- Scan_Enum_Lit --
 200    -------------------
 201
 202    procedure Scan_Enum_Lit
 203      (From  : String;
 204       Start : out Natural;
 205       Stop  : out Natural)
 206    is
 207       C  : Character;
 208
 209    --  Processing for Scan_Enum_Lit
 210
 211    begin
 212       String_Skip (From, Start);
 213
 214       --  Character literal case. If the initial character is a quote, then
 215       --  we read as far as we can without backup (see ACVC test CE3905L
 216       --  which is for the analogous case for reading from a file).
 217
 218       if From (Start) = ''' then
 219          Stop := Start;
 220
 221          if Stop = From'Last then
 222             raise Data_Error;
 223          else
 224             Stop := Stop + 1;
 225          end if;
 226
 227          if From (Stop) in ' ' .. '~'
 228            or else From (Stop) >= Character'Val (16#80#)
 229          then
 230             if Stop = From'Last then
 231                raise Data_Error;
 232             else
 233                Stop := Stop + 1;
 234
 235                if From (Stop) = ''' then
 236                   return;
 237                end if;
 238             end if;
 239          end if;
 240
 241          Stop := Stop - 1;
 242          raise Data_Error;
 243
 244       --  Similarly for identifiers, read as far as we can, in particular,
 245       --  do read a trailing underscore (again see ACVC test CE3905L to
 246       --  understand why we do this, although it seems somewhat peculiar).
 247
 248       else
 249          --  Identifier must start with a letter
 250
 251          if not Is_Letter (From (Start)) then
 252             raise Data_Error;
 253          end if;
 254
 255          --  If we do have a letter, loop through the characters quitting on
 256          --  the first non-identifier character (note that this includes the
 257          --  cases of hitting a line mark or page mark).
 258
 259          Stop := Start;
 260          while Stop < From'Last loop
 261             C := From (Stop + 1);
 262
 263             exit when not Is_Letter (C)
 264               and then not Is_Digit (C)
 265               and then C /= '_';
 266
 267             exit when C = '_'
 268               and then From (Stop) = '_';
 269
 270             Stop := Stop + 1;
 271          end loop;
 272       end if;
 273
 274    end Scan_Enum_Lit;
 275
 276    --------------
 277    -- To_Lower --
 278    --------------
 279
 280    function To_Lower (C : Character) return Character is
 281    begin
 282       if C in 'A' .. 'Z' then
 283          return Character'Val (Character'Pos (C) + 32);
 284       else
 285          return C;
 286       end if;
 287    end To_Lower;
 288
 289    function To_Upper (C : Character) return Character is
 290    begin
 291       if C in 'a' .. 'z' then
 292          return Character'Val (Character'Pos (C) - 32);
 293       else
 294          return C;
 295       end if;
 296    end To_Upper;
 297
 298 end Ada.Text_IO.Enumeration_Aux;