aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.4.3/gcc/ada/s-ststop.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.4.3/gcc/ada/s-ststop.adb')
-rw-r--r--gcc-4.4.3/gcc/ada/s-ststop.adb687
1 files changed, 687 insertions, 0 deletions
diff --git a/gcc-4.4.3/gcc/ada/s-ststop.adb b/gcc-4.4.3/gcc/ada/s-ststop.adb
new file mode 100644
index 000000000..cff6179a7
--- /dev/null
+++ b/gcc-4.4.3/gcc/ada/s-ststop.adb
@@ -0,0 +1,687 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
+-- --
+-- S Y S T E M . S T R I N G S . S T R E A M _ O P S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2009, 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. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Warnings (Off);
+pragma Compiler_Unit;
+pragma Warnings (On);
+
+with Ada.Streams; use Ada.Streams;
+with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
+with Ada.Unchecked_Conversion;
+
+with System.Stream_Attributes; use System;
+
+package body System.Strings.Stream_Ops is
+
+ -- The following type describes the low-level IO mechanism used in package
+ -- Stream_Ops_Internal.
+
+ type IO_Kind is (Byte_IO, Block_IO);
+
+ -- The following package provides an IO framework for strings. Depending
+ -- on the version of System.Stream_Attributes as well as the size of
+ -- formal parameter Character_Type, the package will either utilize block
+ -- IO or character-by-character IO.
+
+ generic
+ type Character_Type is private;
+ type String_Type is array (Positive range <>) of Character_Type;
+
+ package Stream_Ops_Internal is
+ function Input
+ (Strm : access Root_Stream_Type'Class;
+ IO : IO_Kind) return String_Type;
+
+ procedure Output
+ (Strm : access Root_Stream_Type'Class;
+ Item : String_Type;
+ IO : IO_Kind);
+
+ procedure Read
+ (Strm : access Root_Stream_Type'Class;
+ Item : out String_Type;
+ IO : IO_Kind);
+
+ procedure Write
+ (Strm : access Root_Stream_Type'Class;
+ Item : String_Type;
+ IO : IO_Kind);
+ end Stream_Ops_Internal;
+
+ -------------------------
+ -- Stream_Ops_Internal --
+ -------------------------
+
+ package body Stream_Ops_Internal is
+
+ -- The following value represents the number of BITS allocated for the
+ -- default block used in string IO. The sizes of all other types are
+ -- calculated relative to this value.
+
+ Default_Block_Size : constant := 512 * 8;
+
+ -- Shorthand notation for stream element and character sizes
+
+ C_Size : constant Integer := Character_Type'Size;
+ SE_Size : constant Integer := Stream_Element'Size;
+
+ -- The following constants describe the number of stream elements or
+ -- characters that can fit into a default block.
+
+ C_In_Default_Block : constant Integer := Default_Block_Size / C_Size;
+ SE_In_Default_Block : constant Integer := Default_Block_Size / SE_Size;
+
+ -- Buffer types
+
+ subtype Default_Block is Stream_Element_Array
+ (1 .. Stream_Element_Offset (SE_In_Default_Block));
+
+ subtype String_Block is String_Type (1 .. C_In_Default_Block);
+
+ -- Conversions to and from Default_Block
+
+ function To_Default_Block is
+ new Ada.Unchecked_Conversion (String_Block, Default_Block);
+
+ function To_String_Block is
+ new Ada.Unchecked_Conversion (Default_Block, String_Block);
+
+ -----------
+ -- Input --
+ -----------
+
+ function Input
+ (Strm : access Root_Stream_Type'Class;
+ IO : IO_Kind) return String_Type
+ is
+ begin
+ if Strm = null then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ Low : Positive;
+ High : Positive;
+
+ begin
+ -- Read the bounds of the string
+
+ Positive'Read (Strm, Low);
+ Positive'Read (Strm, High);
+
+ declare
+ Item : String_Type (Low .. High);
+
+ begin
+ -- Read the character content of the string
+
+ Read (Strm, Item, IO);
+
+ return Item;
+ end;
+ end;
+ end Input;
+
+ ------------
+ -- Output --
+ ------------
+
+ procedure Output
+ (Strm : access Root_Stream_Type'Class;
+ Item : String_Type;
+ IO : IO_Kind)
+ is
+ begin
+ if Strm = null then
+ raise Constraint_Error;
+ end if;
+
+ -- Write the bounds of the string
+
+ Positive'Write (Strm, Item'First);
+ Positive'Write (Strm, Item'Last);
+
+ -- Write the character content of the string
+
+ Write (Strm, Item, IO);
+ end Output;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Strm : access Root_Stream_Type'Class;
+ Item : out String_Type;
+ IO : IO_Kind)
+ is
+ begin
+ if Strm = null then
+ raise Constraint_Error;
+ end if;
+
+ -- Nothing to do if the desired string is empty
+
+ if Item'Length = 0 then
+ return;
+ end if;
+
+ -- Block IO
+
+ if IO = Block_IO
+ and then Stream_Attributes.Block_IO_OK
+ then
+ declare
+ -- Determine the size in BITS of the block necessary to contain
+ -- the whole string.
+
+ Block_Size : constant Natural :=
+ (Item'Last - Item'First + 1) * C_Size;
+
+ -- Item can be larger than what the default block can store,
+ -- determine the number of whole reads necessary to read the
+ -- string.
+
+ Blocks : constant Natural := Block_Size / Default_Block_Size;
+
+ -- The size of Item may not be a multiple of the default block
+ -- size, determine the size of the remaining chunk in BITS.
+
+ Rem_Size : constant Natural :=
+ Block_Size mod Default_Block_Size;
+
+ -- String indices
+
+ Low : Positive := Item'First;
+ High : Positive := Low + C_In_Default_Block - 1;
+
+ -- End of stream error detection
+
+ Last : Stream_Element_Offset := 0;
+ Sum : Stream_Element_Offset := 0;
+
+ begin
+ -- Step 1: If the string is too large, read in individual
+ -- chunks the size of the default block.
+
+ if Blocks > 0 then
+ declare
+ Block : Default_Block;
+
+ begin
+ for Counter in 1 .. Blocks loop
+ Read (Strm.all, Block, Last);
+ Item (Low .. High) := To_String_Block (Block);
+
+ Low := High + 1;
+ High := Low + C_In_Default_Block - 1;
+ Sum := Sum + Last;
+ Last := 0;
+ end loop;
+ end;
+ end if;
+
+ -- Step 2: Read in any remaining elements
+
+ if Rem_Size > 0 then
+ declare
+ subtype Rem_Block is Stream_Element_Array
+ (1 .. Stream_Element_Offset (Rem_Size / SE_Size));
+
+ subtype Rem_String_Block is
+ String_Type (1 .. Rem_Size / C_Size);
+
+ function To_Rem_String_Block is new
+ Ada.Unchecked_Conversion (Rem_Block, Rem_String_Block);
+
+ Block : Rem_Block;
+
+ begin
+ Read (Strm.all, Block, Last);
+ Item (Low .. Item'Last) := To_Rem_String_Block (Block);
+
+ Sum := Sum + Last;
+ end;
+ end if;
+
+ -- Step 3: Potential error detection. The sum of all the
+ -- chunks is less than we initially wanted to read. In other
+ -- words, the stream does not contain enough elements to fully
+ -- populate Item.
+
+ if (Integer (Sum) * SE_Size) / C_Size < Item'Length then
+ raise End_Error;
+ end if;
+ end;
+
+ -- Byte IO
+
+ else
+ declare
+ C : Character_Type;
+
+ begin
+ for Index in Item'First .. Item'Last loop
+ Character_Type'Read (Strm, C);
+ Item (Index) := C;
+ end loop;
+ end;
+ end if;
+ end Read;
+
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Strm : access Root_Stream_Type'Class;
+ Item : String_Type;
+ IO : IO_Kind)
+ is
+ begin
+ if Strm = null then
+ raise Constraint_Error;
+ end if;
+
+ -- Nothing to do if the input string is empty
+
+ if Item'Length = 0 then
+ return;
+ end if;
+
+ -- Block IO
+
+ if IO = Block_IO
+ and then Stream_Attributes.Block_IO_OK
+ then
+ declare
+ -- Determine the size in BITS of the block necessary to contain
+ -- the whole string.
+
+ Block_Size : constant Natural := Item'Length * C_Size;
+
+ -- Item can be larger than what the default block can store,
+ -- determine the number of whole writes necessary to output the
+ -- string.
+
+ Blocks : constant Natural := Block_Size / Default_Block_Size;
+
+ -- The size of Item may not be a multiple of the default block
+ -- size, determine the size of the remaining chunk.
+
+ Rem_Size : constant Natural :=
+ Block_Size mod Default_Block_Size;
+
+ -- String indices
+
+ Low : Positive := Item'First;
+ High : Positive := Low + C_In_Default_Block - 1;
+
+ begin
+ -- Step 1: If the string is too large, write out individual
+ -- chunks the size of the default block.
+
+ for Counter in 1 .. Blocks loop
+ Write (Strm.all, To_Default_Block (Item (Low .. High)));
+
+ Low := High + 1;
+ High := Low + C_In_Default_Block - 1;
+ end loop;
+
+ -- Step 2: Write out any remaining elements
+
+ if Rem_Size > 0 then
+ declare
+ subtype Rem_Block is Stream_Element_Array
+ (1 .. Stream_Element_Offset (Rem_Size / SE_Size));
+
+ subtype Rem_String_Block is
+ String_Type (1 .. Rem_Size / C_Size);
+
+ function To_Rem_Block is new
+ Ada.Unchecked_Conversion (Rem_String_Block, Rem_Block);
+
+ begin
+ Write (Strm.all, To_Rem_Block (Item (Low .. Item'Last)));
+ end;
+ end if;
+ end;
+
+ -- Byte IO
+
+ else
+ for Index in Item'First .. Item'Last loop
+ Character_Type'Write (Strm, Item (Index));
+ end loop;
+ end if;
+ end Write;
+ end Stream_Ops_Internal;
+
+ -- Specific instantiations for all Ada string types
+
+ package String_Ops is
+ new Stream_Ops_Internal
+ (Character_Type => Character,
+ String_Type => String);
+
+ package Wide_String_Ops is
+ new Stream_Ops_Internal
+ (Character_Type => Wide_Character,
+ String_Type => Wide_String);
+
+ package Wide_Wide_String_Ops is
+ new Stream_Ops_Internal
+ (Character_Type => Wide_Wide_Character,
+ String_Type => Wide_Wide_String);
+
+ ------------------
+ -- String_Input --
+ ------------------
+
+ function String_Input
+ (Strm : access Ada.Streams.Root_Stream_Type'Class) return String
+ is
+ begin
+ return String_Ops.Input (Strm, Byte_IO);
+ end String_Input;
+
+ -------------------------
+ -- String_Input_Blk_IO --
+ -------------------------
+
+ function String_Input_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class) return String
+ is
+ begin
+ return String_Ops.Input (Strm, Block_IO);
+ end String_Input_Blk_IO;
+
+ -------------------
+ -- String_Output --
+ -------------------
+
+ procedure String_Output
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : String)
+ is
+ begin
+ String_Ops.Output (Strm, Item, Byte_IO);
+ end String_Output;
+
+ --------------------------
+ -- String_Output_Blk_IO --
+ --------------------------
+
+ procedure String_Output_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : String)
+ is
+ begin
+ String_Ops.Output (Strm, Item, Block_IO);
+ end String_Output_Blk_IO;
+
+ -----------------
+ -- String_Read --
+ -----------------
+
+ procedure String_Read
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out String)
+ is
+ begin
+ String_Ops.Read (Strm, Item, Byte_IO);
+ end String_Read;
+
+ ------------------------
+ -- String_Read_Blk_IO --
+ ------------------------
+
+ procedure String_Read_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out String)
+ is
+ begin
+ String_Ops.Read (Strm, Item, Block_IO);
+ end String_Read_Blk_IO;
+
+ ------------------
+ -- String_Write --
+ ------------------
+
+ procedure String_Write
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : String)
+ is
+ begin
+ String_Ops.Write (Strm, Item, Byte_IO);
+ end String_Write;
+
+ -------------------------
+ -- String_Write_Blk_IO --
+ -------------------------
+
+ procedure String_Write_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : String)
+ is
+ begin
+ String_Ops.Write (Strm, Item, Block_IO);
+ end String_Write_Blk_IO;
+
+ -----------------------
+ -- Wide_String_Input --
+ -----------------------
+
+ function Wide_String_Input
+ (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String
+ is
+ begin
+ return Wide_String_Ops.Input (Strm, Byte_IO);
+ end Wide_String_Input;
+
+ ------------------------------
+ -- Wide_String_Input_Blk_IO --
+ ------------------------------
+
+ function Wide_String_Input_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String
+ is
+ begin
+ return Wide_String_Ops.Input (Strm, Block_IO);
+ end Wide_String_Input_Blk_IO;
+
+ ------------------------
+ -- Wide_String_Output --
+ ------------------------
+
+ procedure Wide_String_Output
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_String)
+ is
+ begin
+ Wide_String_Ops.Output (Strm, Item, Byte_IO);
+ end Wide_String_Output;
+
+ -------------------------------
+ -- Wide_String_Output_Blk_IO --
+ -------------------------------
+
+ procedure Wide_String_Output_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_String)
+ is
+ begin
+ Wide_String_Ops.Output (Strm, Item, Block_IO);
+ end Wide_String_Output_Blk_IO;
+
+ ----------------------
+ -- Wide_String_Read --
+ ----------------------
+
+ procedure Wide_String_Read
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out Wide_String)
+ is
+ begin
+ Wide_String_Ops.Read (Strm, Item, Byte_IO);
+ end Wide_String_Read;
+
+ -----------------------------
+ -- Wide_String_Read_Blk_IO --
+ -----------------------------
+
+ procedure Wide_String_Read_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out Wide_String)
+ is
+ begin
+ Wide_String_Ops.Read (Strm, Item, Block_IO);
+ end Wide_String_Read_Blk_IO;
+
+ -----------------------
+ -- Wide_String_Write --
+ -----------------------
+
+ procedure Wide_String_Write
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_String)
+ is
+ begin
+ Wide_String_Ops.Write (Strm, Item, Byte_IO);
+ end Wide_String_Write;
+
+ ------------------------------
+ -- Wide_String_Write_Blk_IO --
+ ------------------------------
+
+ procedure Wide_String_Write_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_String)
+ is
+ begin
+ Wide_String_Ops.Write (Strm, Item, Block_IO);
+ end Wide_String_Write_Blk_IO;
+
+ ----------------------------
+ -- Wide_Wide_String_Input --
+ ----------------------------
+
+ function Wide_Wide_String_Input
+ (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String
+ is
+ begin
+ return Wide_Wide_String_Ops.Input (Strm, Byte_IO);
+ end Wide_Wide_String_Input;
+
+ -----------------------------------
+ -- Wide_Wide_String_Input_Blk_IO --
+ -----------------------------------
+
+ function Wide_Wide_String_Input_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String
+ is
+ begin
+ return Wide_Wide_String_Ops.Input (Strm, Block_IO);
+ end Wide_Wide_String_Input_Blk_IO;
+
+ -----------------------------
+ -- Wide_Wide_String_Output --
+ -----------------------------
+
+ procedure Wide_Wide_String_Output
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_Wide_String)
+ is
+ begin
+ Wide_Wide_String_Ops.Output (Strm, Item, Byte_IO);
+ end Wide_Wide_String_Output;
+
+ ------------------------------------
+ -- Wide_Wide_String_Output_Blk_IO --
+ ------------------------------------
+
+ procedure Wide_Wide_String_Output_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_Wide_String)
+ is
+ begin
+ Wide_Wide_String_Ops.Output (Strm, Item, Block_IO);
+ end Wide_Wide_String_Output_Blk_IO;
+
+ ---------------------------
+ -- Wide_Wide_String_Read --
+ ---------------------------
+
+ procedure Wide_Wide_String_Read
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out Wide_Wide_String)
+ is
+ begin
+ Wide_Wide_String_Ops.Read (Strm, Item, Byte_IO);
+ end Wide_Wide_String_Read;
+
+ ----------------------------------
+ -- Wide_Wide_String_Read_Blk_IO --
+ ----------------------------------
+
+ procedure Wide_Wide_String_Read_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : out Wide_Wide_String)
+ is
+ begin
+ Wide_Wide_String_Ops.Read (Strm, Item, Block_IO);
+ end Wide_Wide_String_Read_Blk_IO;
+
+ ----------------------------
+ -- Wide_Wide_String_Write --
+ ----------------------------
+
+ procedure Wide_Wide_String_Write
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_Wide_String)
+ is
+ begin
+ Wide_Wide_String_Ops.Write (Strm, Item, Byte_IO);
+ end Wide_Wide_String_Write;
+
+ -----------------------------------
+ -- Wide_Wide_String_Write_Blk_IO --
+ -----------------------------------
+
+ procedure Wide_Wide_String_Write_Blk_IO
+ (Strm : access Ada.Streams.Root_Stream_Type'Class;
+ Item : Wide_Wide_String)
+ is
+ begin
+ Wide_Wide_String_Ops.Write (Strm, Item, Block_IO);
+ end Wide_Wide_String_Write_Blk_IO;
+
+end System.Strings.Stream_Ops;