Skip to content

R
riscv-gcc-1
Commit b0887a43 by Arnaud Charlet
Options

[multiple changes] 

2010-10-11  Javier Miranda  <miranda@adacore.com>

	* a-textio.adb: Move new implementation of Get_Line to a subunit.
	* a-tigeli.adb: New subunit containing the implementation of Get_Line.

2010-10-11  Ed Schonberg  <schonberg@adacore.com>

	* sem_aux.adb: Code clean up.

From-SVN: r165272
parent e0ae93e2
Showing with 243 additions and 196 deletions
gcc/ada/ChangeLog
2010-10-11 Javier Miranda <miranda@adacore.com>
* a-textio.adb: Move new implementation of Get_Line to a subunit.
* a-tigeli.adb: New subunit containing the implementation of Get_Line.
2010-10-11 Ed Schonberg <schonberg@adacore.com>
* sem_aux.adb: Code clean up.
2010-10-11 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sem_aux.adb, sem_ch6.adb: Minor reformatting
......
gcc/ada/a-textio.adb
......@@ -32,8 +32,6 @@
with Ada.Streams; use Ada.Streams;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
with System.File_IO;
with System.CRTL;
with System.WCh_Cnv; use System.WCh_Cnv;
......@@ -686,197 +684,10 @@ package body Ada.Text_IO is
Get_Immediate (Current_In, Item, Available);
end Get_Immediate;
--------------
-- Get_Line --
--------------
procedure Get_Line
(File : File_Type;
Item : out String;
Last : out Natural)
is
Chunk_Size : constant := 80;
-- We read into a fixed size auxiliary buffer. Because this buffer
-- needs to be pre-initialized, there is a trade-off between size and
-- speed. Experiments find returns are diminishing after 50 and this
-- size allows most lines to be processed with a single read.
ch : int;
N : Natural;
procedure memcpy (s1, s2 : chars; n : size_t);
pragma Import (C, memcpy);
function memchr (s : chars; ch : int; n : size_t) return chars;
pragma Import (C, memchr);
procedure memset (b : chars; ch : int; n : size_t);
pragma Import (C, memset);
function Get_Chunk (N : Positive) return Natural;
-- Reads at most N - 1 characters into Item (Last + 1 .. Item'Last),
-- updating Last. Raises End_Error if nothing was read (End_Of_File).
-- Returns number of characters still to read (either 0 or 1) in
-- case of success.
---------------
-- Get_Chunk --
---------------
function Get_Chunk (N : Positive) return Natural is
Buf : String (1 .. Chunk_Size);
S : constant chars := Buf (1)'Address;
P : chars;
begin
if N = 1 then
return N;
end if;
memset (S, 10, size_t (N));
if fgets (S, N, File.Stream) = Null_Address then
if ferror (File.Stream) /= 0 then
raise Device_Error;
-- If incomplete last line, pretend we found a LM
elsif Last >= Item'First then
return 0;
else
raise End_Error;
end if;
end if;
P := memchr (S, LM, size_t (N));
-- If no LM is found, the buffer got filled without reading a new
-- line. Otherwise, the LM is either one from the input, or else one
-- from the initialization, which means an incomplete end-of-line was
-- encountered. Only in first case the LM will be followed by a 0.
if P = Null_Address then
pragma Assert (Buf (N) = ASCII.NUL);
memcpy (Item (Last + 1)'Address,
Buf (1)'Address, size_t (N - 1));
Last := Last + N - 1;
return 1;
else
-- P points to the LM character. Set K so Buf (K) is the character
-- right before.
declare
K : Natural := Natural (P - S);
begin
-- Now Buf (K + 2) should be 0, or otherwise Buf (K) is the 0
-- put in by fgets, so compensate.
if K + 2 > Buf'Last or else Buf (K + 2) /= ASCII.NUL then
-- Incomplete last line, so remove the extra 0
pragma Assert (Buf (K) = ASCII.NUL);
K := K - 1;
end if;
memcpy (Item (Last + 1)'Address,
Buf (1)'Address, size_t (K));
Last := Last + K;
end;
return 0;
end if;
end Get_Chunk;
-- Start of processing for Get_Line
begin
FIO.Check_Read_Status (AP (File));
-- Immediate exit for null string, this is a case in which we do not
-- need to test for end of file and we do not skip a line mark under
-- any circumstances.
if Item'First > Item'Last then
return;
end if;
N := Item'Last - Item'First + 1;
Last := Item'First - 1;
-- Here we have at least one character, if we are immediately before
-- a line mark, then we will just skip past it storing no characters.
if File.Before_LM then
File.Before_LM := False;
File.Before_LM_PM := False;
-- Otherwise we need to read some characters
else
while N >= Chunk_Size loop
if Get_Chunk (Chunk_Size) = 0 then
N := 0;
else
N := N - Chunk_Size + 1;
end if;
end loop;
if N > 1 then
N := Get_Chunk (N);
end if;
-- Almost there, only a little bit more to read
if N = 1 then
ch := Getc (File);
-- If we get EOF after already reading data, this is an incomplete
-- last line, in which case no End_Error should be raised.
if ch = EOF and then Last < Item'First then
raise End_Error;
elsif ch /= LM then
-- Buffer really is full without having seen LM, update col
Last := Last + 1;
Item (Last) := Character'Val (ch);
File.Col := File.Col + Count (Last - Item'First + 1);
return;
end if;
end if;
end if;
-- We have skipped past, but not stored, a line mark. Skip following
-- page mark if one follows, but do not do this for a non-regular file
-- (since otherwise we get annoying wait for an extra character)
File.Line := File.Line + 1;
File.Col := 1;
if File.Before_LM_PM then
File.Line := 1;
File.Before_LM_PM := False;
File.Page := File.Page + 1;
elsif File.Is_Regular_File then
ch := Getc (File);
if ch = PM and then File.Is_Regular_File then
File.Line := 1;
File.Page := File.Page + 1;
else
Ungetc (ch, File);
end if;
end if;
end Get_Line;
Last : out Natural) is separate;
procedure Get_Line
(Item : out String;
......
gcc/ada/a-tigeli.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- A D A . T E X T _ I O --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2010, 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with System; use System;
with System.Storage_Elements; use System.Storage_Elements;
separate (Ada.Text_IO)
procedure Get_Line
(File : File_Type;
Item : out String;
Last : out Natural)
is
Chunk_Size : constant := 80;
-- We read into a fixed size auxiliary buffer. Because this buffer
-- needs to be pre-initialized, there is a trade-off between size and
-- speed. Experiments find returns are diminishing after 50 and this
-- size allows most lines to be processed with a single read.
ch : int;
N : Natural;
procedure memcpy (s1, s2 : chars; n : size_t);
pragma Import (C, memcpy);
function memchr (s : chars; ch : int; n : size_t) return chars;
pragma Import (C, memchr);
procedure memset (b : chars; ch : int; n : size_t);
pragma Import (C, memset);
function Get_Chunk (N : Positive) return Natural;
-- Reads at most N - 1 characters into Item (Last + 1 .. Item'Last),
-- updating Last. Raises End_Error if nothing was read (End_Of_File).
-- Returns number of characters still to read (either 0 or 1) in
-- case of success.
---------------
-- Get_Chunk --
---------------
function Get_Chunk (N : Positive) return Natural is
Buf : String (1 .. Chunk_Size);
S : constant chars := Buf (1)'Address;
P : chars;
begin
if N = 1 then
return N;
end if;
memset (S, 10, size_t (N));
if fgets (S, N, File.Stream) = Null_Address then
if ferror (File.Stream) /= 0 then
raise Device_Error;
-- If incomplete last line, pretend we found a LM
elsif Last >= Item'First then
return 0;
else
raise End_Error;
end if;
end if;
P := memchr (S, LM, size_t (N));
-- If no LM is found, the buffer got filled without reading a new
-- line. Otherwise, the LM is either one from the input, or else one
-- from the initialization, which means an incomplete end-of-line was
-- encountered. Only in first case the LM will be followed by a 0.
if P = Null_Address then
pragma Assert (Buf (N) = ASCII.NUL);
memcpy (Item (Last + 1)'Address,
Buf (1)'Address, size_t (N - 1));
Last := Last + N - 1;
return 1;
else
-- P points to the LM character. Set K so Buf (K) is the character
-- right before.
declare
K : Natural := Natural (P - S);
begin
-- Now Buf (K + 2) should be 0, or otherwise Buf (K) is the 0
-- put in by fgets, so compensate.
if K + 2 > Buf'Last or else Buf (K + 2) /= ASCII.NUL then
-- Incomplete last line, so remove the extra 0
pragma Assert (Buf (K) = ASCII.NUL);
K := K - 1;
end if;
memcpy (Item (Last + 1)'Address,
Buf (1)'Address, size_t (K));
Last := Last + K;
end;
return 0;
end if;
end Get_Chunk;
-- Start of processing for Get_Line
begin
FIO.Check_Read_Status (AP (File));
-- Immediate exit for null string, this is a case in which we do not
-- need to test for end of file and we do not skip a line mark under
-- any circumstances.
if Item'First > Item'Last then
return;
end if;
N := Item'Last - Item'First + 1;
Last := Item'First - 1;
-- Here we have at least one character, if we are immediately before
-- a line mark, then we will just skip past it storing no characters.
if File.Before_LM then
File.Before_LM := False;
File.Before_LM_PM := False;
-- Otherwise we need to read some characters
else
while N >= Chunk_Size loop
if Get_Chunk (Chunk_Size) = 0 then
N := 0;
else
N := N - Chunk_Size + 1;
end if;
end loop;
if N > 1 then
N := Get_Chunk (N);
end if;
-- Almost there, only a little bit more to read
if N = 1 then
ch := Getc (File);
-- If we get EOF after already reading data, this is an incomplete
-- last line, in which case no End_Error should be raised.
if ch = EOF and then Last < Item'First then
raise End_Error;
elsif ch /= LM then
-- Buffer really is full without having seen LM, update col
Last := Last + 1;
Item (Last) := Character'Val (ch);
File.Col := File.Col + Count (Last - Item'First + 1);
return;
end if;
end if;
end if;
-- We have skipped past, but not stored, a line mark. Skip following
-- page mark if one follows, but do not do this for a non-regular file
-- (since otherwise we get annoying wait for an extra character)
File.Line := File.Line + 1;
File.Col := 1;
if File.Before_LM_PM then
File.Line := 1;
File.Before_LM_PM := False;
File.Page := File.Page + 1;
elsif File.Is_Regular_File then
ch := Getc (File);
if ch = PM and then File.Is_Regular_File then
File.Line := 1;
File.Page := File.Page + 1;
else
Ungetc (ch, File);
end if;
end if;
end Get_Line;
gcc/ada/sem_aux.adb
......@@ -578,7 +578,10 @@ package body Sem_Aux is
Btype : constant Entity_Id := Base_Type (Ent);
begin
if Ekind (Btype) = E_Limited_Private_Type
if Is_Limited_Record (Btype) then
return True;
elsif Ekind (Btype) = E_Limited_Private_Type
and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
then
return not In_Package_Body (Scope ((Btype)));
......@@ -595,8 +598,11 @@ package body Sem_Aux is
if not Is_Limited_Type (Etype (Btype)) then
return False;
-- A descendant of a limited formal type is not immutably limited
-- in the generic body, or in the body of a generic child.
elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
return not In_Package_Body (Scope (Etype (Btype)));
return not In_Package_Body (Scope (Btype));
else
return False;
......@@ -626,10 +632,7 @@ package body Sem_Aux is
-- handled as build in place even though they might return objects
-- of a type that is not inherently limited.
if Is_Limited_Record (Btype) then
return True;
elsif Is_Class_Wide_Type (Btype) then
if Is_Class_Wide_Type (Btype) then
return Is_Immutably_Limited_Type (Root_Type (Btype));
else
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment