blob: 0ca5a03cf94e3f350b143d5ddc2fbf35f7025e10 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T E X T _ I O . G E N E R I C _ A U X --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.File_IO;
with System.File_Control_Block;
package body Ada.Text_IO.Generic_Aux is
package FIO renames System.File_IO;
package FCB renames System.File_Control_Block;
subtype AP is FCB.AFCB_Ptr;
------------------------
-- Check_End_Of_Field --
------------------------
procedure Check_End_Of_Field
(Buf : String;
Stop : Integer;
Ptr : Integer;
Width : Field)
is
begin
if Ptr > Stop then
return;
elsif Width = 0 then
raise Data_Error;
else
for J in Ptr .. Stop loop
if not Is_Blank (Buf (J)) then
raise Data_Error;
end if;
end loop;
end if;
end Check_End_Of_Field;
-----------------------
-- Check_On_One_Line --
-----------------------
procedure Check_On_One_Line
(File : File_Type;
Length : Integer)
is
begin
FIO.Check_Write_Status (AP (File));
if File.Line_Length /= 0 then
if Count (Length) > File.Line_Length then
raise Layout_Error;
elsif File.Col + Count (Length) > File.Line_Length + 1 then
New_Line (File);
end if;
end if;
end Check_On_One_Line;
----------
-- Getc --
----------
function Getc (File : File_Type) return int is
ch : int;
begin
ch := fgetc (File.Stream);
if ch = EOF and then ferror (File.Stream) /= 0 then
raise Device_Error;
else
return ch;
end if;
end Getc;
--------------
-- Is_Blank --
--------------
function Is_Blank (C : Character) return Boolean is
begin
return C = ' ' or else C = ASCII.HT;
end Is_Blank;
----------
-- Load --
----------
procedure Load
(File : File_Type;
Buf : out String;
Ptr : in out Integer;
Char : Character;
Loaded : out Boolean)
is
ch : int;
begin
ch := Getc (File);
if ch = Character'Pos (Char) then
Store_Char (File, ch, Buf, Ptr);
Loaded := True;
else
Ungetc (ch, File);
Loaded := False;
end if;
end Load;
procedure Load
(File : File_Type;
Buf : out String;
Ptr : in out Integer;
Char : Character)
is
ch : int;
begin
ch := Getc (File);
if ch = Character'Pos (Char) then
Store_Char (File, ch, Buf, Ptr);
else
Ungetc (ch, File);
end if;
end Load;
procedure Load
(File : File_Type;
Buf : out String;
Ptr : in out Integer;
Char1 : Character;
Char2 : Character;
Loaded : out Boolean)
is
ch : int;
begin
ch := Getc (File);
if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
Store_Char (File, ch, Buf, Ptr);
Loaded := True;
else
Ungetc (ch, File);
Loaded := False;
end if;
end Load;
procedure Load
(File : File_Type;
Buf : out String;
Ptr : in out Integer;
Char1 : Character;
Char2 : Character)
is
ch : int;
begin
ch := Getc (File);
if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then
Store_Char (File, ch, Buf, Ptr);
else
Ungetc (ch, File);
end if;
end Load;
-----------------
-- Load_Digits --
-----------------
procedure Load_Digits
(File : File_Type;
Buf : out String;
Ptr : in out Integer;
Loaded : out Boolean)
is
ch : int;
After_Digit : Boolean;
begin
ch := Getc (File);
if ch not in Character'Pos ('0') .. Character'Pos ('9') then
Loaded := False;
else
Loaded := True;
After_Digit := True;
loop
Store_Char (File, ch, Buf, Ptr);
ch := Getc (File);
if ch in Character'Pos ('0') .. Character'Pos ('9') then
After_Digit := True;
elsif ch = Character'Pos ('_') and then After_Digit then
After_Digit := False;
else
exit;
end if;
end loop;
end if;
Ungetc (ch, File);
end Load_Digits;
procedure Load_Digits
(File : File_Type;
Buf : out String;
Ptr : in out Integer)
is
ch : int;
After_Digit : Boolean;
begin
ch := Getc (File);
if ch in Character'Pos ('0') .. Character'Pos ('9') then
After_Digit := True;
loop
Store_Char (File, ch, Buf, Ptr);
ch := Getc (File);
if ch in Character'Pos ('0') .. Character'Pos ('9') then
After_Digit := True;
elsif ch = Character'Pos ('_') and then After_Digit then
After_Digit := False;
else
exit;
end if;
end loop;
end if;
Ungetc (ch, File);
end Load_Digits;
--------------------------
-- Load_Extended_Digits --
--------------------------
procedure Load_Extended_Digits
(File : File_Type;
Buf : out String;
Ptr : in out Integer;
Loaded : out Boolean)
is
ch : int;
After_Digit : Boolean := False;
begin
Loaded := False;
loop
ch := Getc (File);
if ch in Character'Pos ('0') .. Character'Pos ('9')
or else
ch in Character'Pos ('a') .. Character'Pos ('f')
or else
ch in Character'Pos ('A') .. Character'Pos ('F')
then
After_Digit := True;
elsif ch = Character'Pos ('_') and then After_Digit then
After_Digit := False;
else
exit;
end if;
Store_Char (File, ch, Buf, Ptr);
Loaded := True;
end loop;
Ungetc (ch, File);
end Load_Extended_Digits;
procedure Load_Extended_Digits
(File : File_Type;
Buf : out String;
Ptr : in out Integer)
is
Junk : Boolean;
begin
Load_Extended_Digits (File, Buf, Ptr, Junk);
end Load_Extended_Digits;
------------------
-- Load_Integer --
------------------
procedure Load_Integer
(File : File_Type;
Buf : out String;
Ptr : in out Natural)
is
Hash_Loc : Natural;
Loaded : Boolean;
begin
Load_Skip (File);
-- Note: it is a bit strange to allow a minus sign here, but it seems
-- consistent with the general behavior expected by the ACVC tests
-- which is to scan past junk and then signal data error, see ACVC
-- test CE3704F, case (6), which is for signed integer exponents,
-- which seems a similar case.
Load (File, Buf, Ptr, '+', '-');
Load_Digits (File, Buf, Ptr, Loaded);
if Loaded then
-- Deal with based literal. We recognize either the standard '#' or
-- the allowed alternative replacement ':' (see RM J.2(3)).
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
Hash_Loc := Ptr;
Load_Extended_Digits (File, Buf, Ptr);
Load (File, Buf, Ptr, Buf (Hash_Loc));
end if;
-- Deal with exponent
Load (File, Buf, Ptr, 'E', 'e', Loaded);
if Loaded then
-- Note: it is strange to allow a minus sign, since the syntax
-- does not, but that is what ACVC test CE3704F, case (6) wants
-- for the signed case, and there seems no good reason to treat
-- exponents differently for the signed and unsigned cases.
Load (File, Buf, Ptr, '+', '-');
Load_Digits (File, Buf, Ptr);
end if;
end if;
end Load_Integer;
---------------
-- Load_Real --
---------------
procedure Load_Real
(File : File_Type;
Buf : out String;
Ptr : in out Natural)
is
Loaded : Boolean;
begin
-- Skip initial blanks, and load possible sign
Load_Skip (File);
Load (File, Buf, Ptr, '+', '-');
-- Case of .nnnn
Load (File, Buf, Ptr, '.', Loaded);
if Loaded then
Load_Digits (File, Buf, Ptr, Loaded);
-- Hopeless junk if no digits loaded
if not Loaded then
return;
end if;
-- Otherwise must have digits to start
else
Load_Digits (File, Buf, Ptr, Loaded);
-- Hopeless junk if no digits loaded
if not Loaded then
return;
end if;
-- Based cases. We recognize either the standard '#' or the
-- allowed alternative replacement ':' (see RM J.2(3)).
Load (File, Buf, Ptr, '#', ':', Loaded);
if Loaded then
-- Case of nnn#.xxx#
Load (File, Buf, Ptr, '.', Loaded);
if Loaded then
Load_Extended_Digits (File, Buf, Ptr);
Load (File, Buf, Ptr, '#', ':');
-- Case of nnn#xxx.[xxx]# or nnn#xxx#
else
Load_Extended_Digits (File, Buf, Ptr);
Load (File, Buf, Ptr, '.', Loaded);
if Loaded then
Load_Extended_Digits (File, Buf, Ptr);
end if;
-- As usual, it seems strange to allow mixed base characters,
-- but that is what ACVC tests expect, see CE3804M, case (3).
Load (File, Buf, Ptr, '#', ':');
end if;
-- Case of nnn.[nnn] or nnn
else
-- Prevent the potential processing of '.' in cases where the
-- initial digits have a trailing underscore.
if Buf (Ptr) = '_' then
return;
end if;
Load (File, Buf, Ptr, '.', Loaded);
if Loaded then
Load_Digits (File, Buf, Ptr);
end if;
end if;
end if;
-- Deal with exponent
Load (File, Buf, Ptr, 'E', 'e', Loaded);
if Loaded then
Load (File, Buf, Ptr, '+', '-');
Load_Digits (File, Buf, Ptr);
end if;
end Load_Real;
---------------
-- Load_Skip --
---------------
procedure Load_Skip (File : File_Type) is
C : Character;
begin
FIO.Check_Read_Status (AP (File));
-- Loop till we find a non-blank character (note that as usual in
-- Text_IO, blank includes horizontal tab). Note that Get deals with
-- the Before_LM and Before_LM_PM flags appropriately.
loop
Get (File, C);
exit when not Is_Blank (C);
end loop;
Ungetc (Character'Pos (C), File);
File.Col := File.Col - 1;
end Load_Skip;
----------------
-- Load_Width --
----------------
procedure Load_Width
(File : File_Type;
Width : Field;
Buf : out String;
Ptr : in out Integer)
is
ch : int;
begin
FIO.Check_Read_Status (AP (File));
-- If we are immediately before a line mark, then we have no characters.
-- This is always a data error, so we may as well raise it right away.
if File.Before_LM then
raise Data_Error;
else
for J in 1 .. Width loop
ch := Getc (File);
if ch = EOF then
return;
elsif ch = LM then
Ungetc (ch, File);
return;
else
Store_Char (File, ch, Buf, Ptr);
end if;
end loop;
end if;
end Load_Width;
-----------
-- Nextc --
-----------
function Nextc (File : File_Type) return int is
ch : int;
begin
ch := fgetc (File.Stream);
if ch = EOF then
if ferror (File.Stream) /= 0 then
raise Device_Error;
else
return EOF;
end if;
else
Ungetc (ch, File);
return ch;
end if;
end Nextc;
--------------
-- Put_Item --
--------------
procedure Put_Item (File : File_Type; Str : String) is
begin
Check_On_One_Line (File, Str'Length);
Put (File, Str);
end Put_Item;
----------------
-- Store_Char --
----------------
procedure Store_Char
(File : File_Type;
ch : int;
Buf : in out String;
Ptr : in out Integer)
is
begin
File.Col := File.Col + 1;
if Ptr < Buf'Last then
Ptr := Ptr + 1;
end if;
Buf (Ptr) := Character'Val (ch);
end Store_Char;
-----------------
-- String_Skip --
-----------------
procedure String_Skip (Str : String; Ptr : out Integer) is
begin
-- Routines calling String_Skip malfunction if Str'Last = Positive'Last.
-- It's too much trouble to make this silly case work, so we just raise
-- Program_Error with an appropriate message. We raise Program_Error
-- rather than Constraint_Error because we don't want this case to be
-- converted to Data_Error.
if Str'Last = Positive'Last then
raise Program_Error with
"string upper bound is Positive'Last, not supported";
end if;
-- Normal case where Str'Last < Positive'Last
Ptr := Str'First;
loop
if Ptr > Str'Last then
raise End_Error;
elsif not Is_Blank (Str (Ptr)) then
return;
else
Ptr := Ptr + 1;
end if;
end loop;
end String_Skip;
------------
-- Ungetc --
------------
procedure Ungetc (ch : int; File : File_Type) is
begin
if ch /= EOF then
if ungetc (ch, File.Stream) = EOF then
raise Device_Error;
end if;
end if;
end Ungetc;
end Ada.Text_IO.Generic_Aux;