home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Geek Gadgets 1
/
ADE-1.bin
/
ade-dist
/
gnat-2.06-src.tgz
/
tar.out
/
fsf
/
gnat
/
ada
/
a-tienau.adb
< prev
next >
Wrap
Text File
|
1996-09-28
|
8KB
|
283 lines
------------------------------------------------------------------------------
-- --
-- GNAT RUNTIME COMPONENTS --
-- --
-- A D A . T E X T _ I O . E N U M E R A T I O N _ A U X --
-- --
-- B o d y --
-- --
-- $Revision: 1.11 $ --
-- --
-- Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved --
-- --
-- The GNAT library is free software; you can redistribute it and/or modify --
-- it under terms of the GNU Library General Public License as published by --
-- the Free Software Foundation; either version 2, or (at your option) any --
-- later version. The GNAT library is distributed in the hope that it will --
-- be useful, but WITHOUT ANY WARRANTY; without even the implied warranty --
-- of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --
-- Library General Public License for more details. You should have --
-- received a copy of the GNU Library General Public License along with --
-- the GNAT library; see the file COPYING.LIB. If not, write to the Free --
-- Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
-- --
------------------------------------------------------------------------------
with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Interfaces.C_Streams; use Interfaces.C_Streams;
-- Note: this package does not yet deal properly with wide characters ???
package body Ada.Text_IO.Enumeration_Aux is
-- These definitions replace the ones in Ada.Characters.Handling, which
-- do not seem to work for some strange not understood reason ??? at
-- least in the OS/2 version.
function To_Lower (C : Character) return Character;
function To_Upper (C : Character) return Character;
function To_Lower (C : Character) return Character is
begin
if C in 'A' .. 'Z' then
return Character'Val (Character'Pos (C) + 32);
else
return C;
end if;
end To_Lower;
function To_Upper (C : Character) return Character is
begin
if C in 'a' .. 'z' then
return Character'Val (Character'Pos (C) - 32);
else
return C;
end if;
end To_Upper;
------------------
-- Get_Enum_Lit --
------------------
procedure Get_Enum_Lit
(File : File_Type;
Buf : out String;
Buflen : out Natural)
is
ch : int;
C : Character;
begin
Buflen := 0;
Load_Skip (File);
ch := Getc (File);
C := Character'Val (ch);
-- Character literal case. If the initial character is a quote, then
-- we read as far as we can without backup (see ACVC test CE3905L)
if C = ''' then
Store_Char (File, ch, Buf, Buflen);
ch := Getc (File);
if ch in 16#20# .. 16#7E# or else ch >= 16#80# then
Store_Char (File, ch, Buf, Buflen);
ch := Getc (File);
if ch = Character'Pos (''') then
Store_Char (File, ch, Buf, Buflen);
else
Ungetc (ch, File);
end if;
else
Ungetc (ch, File);
end if;
-- Similarly for identifiers, read as far as we can, in particular,
-- do read a trailing underscore (again see ACVC test CE3905L to
-- understand why we do this, although it seems somewhat peculiar).
else
-- Identifier must start with a letter
if not Is_Letter (C) then
Ungetc (ch, File);
return;
end if;
-- If we do have a letter, loop through the characters quitting on
-- the first non-identifier character (note that this includes the
-- cases of hitting a line mark or page mark).
loop
C := Character'Val (ch);
Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen);
ch := Getc (File);
exit when ch = EOF;
C := Character'Val (ch);
exit when not Is_Letter (C)
and then not Is_Digit (C)
and then C /= '_';
exit when C = '_'
and then Buf (Buflen) = '_';
end loop;
Ungetc (ch, File);
end if;
end Get_Enum_Lit;
-------------------
-- Scan_Enum_Lit --
-------------------
procedure Scan_Enum_Lit
(From : String;
Start : out Natural;
Stop : out Natural)
is
C : Character;
-- Processing for Scan_Enum_Lit
begin
String_Skip (From, Start);
-- Character literal case. If the initial character is a quote, then
-- we read as far as we can without backup (see ACVC test CE3905L
-- which is for the analogous case for reading from a file).
if From (Start) = ''' then
Stop := Start;
if Stop = From'Last then
raise Data_Error;
else
Stop := Stop + 1;
end if;
if From (Stop) in ' ' .. '~'
or else From (Stop) >= Character'Val (16#80#)
then
if Stop = From'Last then
raise Data_Error;
else
Stop := Stop + 1;
if From (Stop) = ''' then
return;
end if;
end if;
end if;
Stop := Stop - 1;
raise Data_Error;
-- Similarly for identifiers, read as far as we can, in particular,
-- do read a trailing underscore (again see ACVC test CE3905L to
-- understand why we do this, although it seems somewhat peculiar).
else
-- Identifier must start with a letter
if not Is_Letter (From (Start)) then
raise Data_Error;
end if;
-- If we do have a letter, loop through the characters quitting on
-- the first non-identifier character (note that this includes the
-- cases of hitting a line mark or page mark).
Stop := Start + 1;
while Stop < From'Last loop
C := From (Stop + 1);
exit when not Is_Letter (C)
and then not Is_Digit (C)
and then C /= '_';
exit when C = '_'
and then From (Stop - 1) = '_';
Stop := Stop + 1;
end loop;
end if;
end Scan_Enum_Lit;
---------
-- Put --
---------
procedure Put
(File : File_Type;
Item : String;
Width : Field;
Set : Type_Set)
is
Actual_Width : constant Count := Count'Max (Count (Width), Item'Length);
begin
if Set = Lower_Case and then Item (1) /= ''' then
declare
Iteml : String (Item'First .. Item'Last);
begin
for J in Item'Range loop
Iteml (J) := To_Lower (Item (J));
end loop;
Put_Item (File, Iteml);
end;
else
Put_Item (File, Item);
end if;
for J in 1 .. Actual_Width - Item'Length loop
Put (File, ' ');
end loop;
end Put;
----------
-- Puts --
----------
procedure Puts
(To : out String;
Item : in String;
Set : Type_Set)
is
Ptr : Natural;
begin
if Item'Length > To'Length then
raise Layout_Error;
else
Ptr := To'First;
for J in Item'Range loop
if Set = Lower_Case and then Item (1) /= ''' then
To (Ptr) := To_Lower (Item (J));
else
To (Ptr) := Item (J);
end if;
Ptr := Ptr + 1;
end loop;
while Ptr <= To'Last loop
To (Ptr) := ' ';
Ptr := Ptr + 1;
end loop;
end if;
end Puts;
end Ada.Text_IO.Enumeration_Aux;
