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 --                            $Revision: 1.15 $
  10 --                                                                          --
  11 --          Copyright (C) 1992-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT was originally developed  by the GNAT team at  New York University. --
  32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33 --                                                                          --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
  37 with Ada.Characters.Handling; use Ada.Characters.Handling;
  38 with Interfaces.C_Streams;    use Interfaces.C_Streams;
  39
  40 --  Note: this package does not yet deal properly with wide characters ???
  41
  42 package body Ada.Text_IO.Enumeration_Aux is
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    --  These definitions replace the ones in Ada.Characters.Handling, which
  49    --  do not seem to work for some strange not understood reason ??? at
  50    --  least in the OS/2 version.
  51
  52    function To_Lower (C : Character) return Character;
  53    function To_Upper (C : Character) return Character;
  54
  55    ------------------
  56    -- Get_Enum_Lit --
  57    ------------------
  58
  59    procedure Get_Enum_Lit
  60      (File   : File_Type;
  61       Buf    : out String;
  62       Buflen : out Natural)
  63    is
  64       ch  : int;
  65       C   : Character;
  66
  67    begin
  68       Buflen := 0;
  69       Load_Skip (File);
  70       ch := Getc (File);
  71       C := Character'Val (ch);
  72
  73       --  Character literal case. If the initial character is a quote, then
  74       --  we read as far as we can without backup (see ACVC test CE3905L)
  75
  76       if C = ''' then
  77          Store_Char (File, ch, Buf, Buflen);
  78
  79          ch := Getc (File);
  80
  81          if ch in 16#20# .. 16#7E# or else ch >= 16#80# then
  82             Store_Char (File, ch, Buf, Buflen);
  83
  84             ch := Getc (File);
  85
  86             if ch = Character'Pos (''') then
  87                Store_Char (File, ch, Buf, Buflen);
  88             else
  89                Ungetc (ch, File);
  90             end if;
  91
  92          else
  93             Ungetc (ch, File);
  94          end if;
  95
  96       --  Similarly for identifiers, read as far as we can, in particular,
  97       --  do read a trailing underscore (again see ACVC test CE3905L to
  98       --  understand why we do this, although it seems somewhat peculiar).
  99
 100       else
 101          --  Identifier must start with a letter
 102
 103          if not Is_Letter (C) then
 104             Ungetc (ch, File);
 105             return;
 106          end if;
 107
 108          --  If we do have a letter, loop through the characters quitting on
 109          --  the first non-identifier character (note that this includes the
 110          --  cases of hitting a line mark or page mark).
 111
 112          loop
 113             C := Character'Val (ch);
 114             Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen);
 115
 116             ch := Getc (File);
 117             exit when ch = EOF;
 118             C := Character'Val (ch);
 119
 120             exit when not Is_Letter (C)
 121               and then not Is_Digit (C)
 122               and then C /= '_';
 123
 124             exit when C = '_'
 125               and then Buf (Buflen) = '_';
 126          end loop;
 127
 128          Ungetc (ch, File);
 129       end if;
 130    end Get_Enum_Lit;
 131
 132    ---------
 133    -- Put --
 134    ---------
 135
 136    procedure Put
 137      (File  : File_Type;
 138       Item  : String;
 139       Width : Field;
 140       Set   : Type_Set)
 141    is
 142       Actual_Width : constant Count := Count'Max (Count (Width), Item'Length);
 143
 144    begin
 145       if Set = Lower_Case and then Item (1) /= ''' then
 146          declare
 147             Iteml : String (Item'First .. Item'Last);
 148
 149          begin
 150             for J in Item'Range loop
 151                Iteml (J) := To_Lower (Item (J));
 152             end loop;
 153
 154             Put_Item (File, Iteml);
 155          end;
 156
 157       else
 158          Put_Item (File, Item);
 159       end if;
 160
 161       for J in 1 .. Actual_Width - Item'Length loop
 162          Put (File, ' ');
 163       end loop;
 164    end Put;
 165
 166    ----------
 167    -- Puts --
 168    ----------
 169
 170    procedure Puts
 171      (To    : out String;
 172       Item  : in String;
 173       Set   : Type_Set)
 174    is
 175       Ptr : Natural;
 176
 177    begin
 178       if Item'Length > To'Length then
 179          raise Layout_Error;
 180
 181       else
 182          Ptr := To'First;
 183          for J in Item'Range loop
 184             if Set = Lower_Case and then Item (1) /= ''' then
 185                To (Ptr) := To_Lower (Item (J));
 186             else
 187                To (Ptr) := Item (J);
 188             end if;
 189
 190             Ptr := Ptr + 1;
 191          end loop;
 192
 193          while Ptr <= To'Last loop
 194             To (Ptr) := ' ';
 195             Ptr := Ptr + 1;
 196          end loop;
 197       end if;
 198    end Puts;
 199
 200    -------------------
 201    -- Scan_Enum_Lit --
 202    -------------------
 203
 204    procedure Scan_Enum_Lit
 205      (From  : String;
 206       Start : out Natural;
 207       Stop  : out Natural)
 208    is
 209       C  : Character;
 210
 211    --  Processing for Scan_Enum_Lit
 212
 213    begin
 214       String_Skip (From, Start);
 215
 216       --  Character literal case. If the initial character is a quote, then
 217       --  we read as far as we can without backup (see ACVC test CE3905L
 218       --  which is for the analogous case for reading from a file).
 219
 220       if From (Start) = ''' then
 221          Stop := Start;
 222
 223          if Stop = From'Last then
 224             raise Data_Error;
 225          else
 226             Stop := Stop + 1;
 227          end if;
 228
 229          if From (Stop) in ' ' .. '~'
 230            or else From (Stop) >= Character'Val (16#80#)
 231          then
 232             if Stop = From'Last then
 233                raise Data_Error;
 234             else
 235                Stop := Stop + 1;
 236
 237                if From (Stop) = ''' then
 238                   return;
 239                end if;
 240             end if;
 241          end if;
 242
 243          Stop := Stop - 1;
 244          raise Data_Error;
 245
 246       --  Similarly for identifiers, read as far as we can, in particular,
 247       --  do read a trailing underscore (again see ACVC test CE3905L to
 248       --  understand why we do this, although it seems somewhat peculiar).
 249
 250       else
 251          --  Identifier must start with a letter
 252
 253          if not Is_Letter (From (Start)) then
 254             raise Data_Error;
 255          end if;
 256
 257          --  If we do have a letter, loop through the characters quitting on
 258          --  the first non-identifier character (note that this includes the
 259          --  cases of hitting a line mark or page mark).
 260
 261          Stop := Start;
 262          while Stop < From'Last loop
 263             C := From (Stop + 1);
 264
 265             exit when not Is_Letter (C)
 266               and then not Is_Digit (C)
 267               and then C /= '_';
 268
 269             exit when C = '_'
 270               and then From (Stop) = '_';
 271
 272             Stop := Stop + 1;
 273          end loop;
 274       end if;
 275
 276    end Scan_Enum_Lit;
 277
 278    --------------
 279    -- To_Lower --
 280    --------------
 281
 282    function To_Lower (C : Character) return Character is
 283    begin
 284       if C in 'A' .. 'Z' then
 285          return Character'Val (Character'Pos (C) + 32);
 286       else
 287          return C;
 288       end if;
 289    end To_Lower;
 290
 291    function To_Upper (C : Character) return Character is
 292    begin
 293       if C in 'a' .. 'z' then
 294          return Character'Val (Character'Pos (C) - 32);
 295       else
 296          return C;
 297       end if;
 298    end To_Upper;
 299
 300 end Ada.Text_IO.Enumeration_Aux;