--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ N E W --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2000-2007, 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. --
+-- --
+------------------------------------------------------------------------------
+
+pragma Warnings (Off);
+pragma Compiler_Unit;
+pragma Warnings (On);
+
+with Ada.Unchecked_Conversion;
+
+package body System.Img_Enum_New is
+
+ -------------------------
+ -- Image_Enumeration_8 --
+ -------------------------
+
+ procedure Image_Enumeration_8
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ is
+ pragma Assert (S'First = 1);
+
+ type Natural_8 is range 0 .. 2 ** 7 - 1;
+ type Index_Table is array (Natural) of Natural_8;
+ type Index_Table_Ptr is access Index_Table;
+
+ function To_Index_Table_Ptr is
+ new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
+
+ IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+
+ Start : constant Natural := Natural (IndexesT (Pos));
+ Next : constant Natural := Natural (IndexesT (Pos + 1));
+
+ begin
+ S (1 .. Next - Start) := Names (Start .. Next - 1);
+ P := Next - Start;
+ end Image_Enumeration_8;
+
+ --------------------------
+ -- Image_Enumeration_16 --
+ --------------------------
+
+ procedure Image_Enumeration_16
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ is
+ pragma Assert (S'First = 1);
+
+ type Natural_16 is range 0 .. 2 ** 15 - 1;
+ type Index_Table is array (Natural) of Natural_16;
+ type Index_Table_Ptr is access Index_Table;
+
+ function To_Index_Table_Ptr is
+ new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
+
+ IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+
+ Start : constant Natural := Natural (IndexesT (Pos));
+ Next : constant Natural := Natural (IndexesT (Pos + 1));
+
+ begin
+ S (1 .. Next - Start) := Names (Start .. Next - 1);
+ P := Next - Start;
+ end Image_Enumeration_16;
+
+ --------------------------
+ -- Image_Enumeration_32 --
+ --------------------------
+
+ procedure Image_Enumeration_32
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address)
+ is
+ pragma Assert (S'First = 1);
+
+ type Natural_32 is range 0 .. 2 ** 31 - 1;
+ type Index_Table is array (Natural) of Natural_32;
+ type Index_Table_Ptr is access Index_Table;
+
+ function To_Index_Table_Ptr is
+ new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr);
+
+ IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes);
+
+ Start : constant Natural := Natural (IndexesT (Pos));
+ Next : constant Natural := Natural (IndexesT (Pos + 1));
+
+ begin
+ S (1 .. Next - Start) := Names (Start .. Next - 1);
+ P := Next - Start;
+ end Image_Enumeration_32;
+
+end System.Img_Enum_New;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . I M G _ E N U M _ N E W --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2000-2007, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Enumeration_Type'Image for all enumeration types except those in package
+-- Standard (where we have no opportunity to build image tables), and in
+-- package System (where it is too early to start building image tables).
+-- Special routines exist for the enumeration types in these packages.
+
+-- This is the new version of the package, for use by compilers built after
+-- Nov 21st, 2007, which provides procedures that avoid using the secondary
+-- stack. The original package System.Img_Enum is maintained in the sources
+-- for bootstrapping with older versions of the compiler which expect to find
+-- functions in this package.
+
+pragma Warnings (Off);
+pragma Compiler_Unit;
+pragma Warnings (On);
+
+package System.Img_Enum_New is
+ pragma Pure;
+
+ procedure Image_Enumeration_8
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address);
+ -- Used to compute Enum'Image (Str) where Enum is some enumeration type
+ -- other than those defined in package Standard. Names is a string with
+ -- a lower bound of 1 containing the characters of all the enumeration
+ -- literals concatenated together in sequence. Indexes is the address of
+ -- an array of type array (0 .. N) of Natural_8, where N is the number of
+ -- enumeration literals in the type. The Indexes values are the starting
+ -- subscript of each enumeration literal, indexed by Pos values, with an
+ -- extra entry at the end containing Names'Length + 1. The reason that
+ -- Indexes is passed by address is that the actual type is created on the
+ -- fly by the expander. The desired 'Image value is stored in S (1 .. P)
+ -- and P is set on return. The caller guarantees that S is long enough to
+ -- hold the result and that the lower bound is 1.
+
+ procedure Image_Enumeration_16
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address);
+ -- Identical to Set_Image_Enumeration_8 except that it handles types
+ -- using array (0 .. Num) of Natural_16 for the Indexes table.
+
+ procedure Image_Enumeration_32
+ (Pos : Natural;
+ S : in out String;
+ P : out Natural;
+ Names : String;
+ Indexes : System.Address);
+ -- Identical to Set_Image_Enumeration_8 except that it handles types
+ -- using array (0 .. Num) of Natural_32 for the Indexes table.
+
+end System.Img_Enum_New;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Boolean --
-------------------
- function Image_Boolean (V : Boolean) return String is
+ procedure Image_Boolean
+ (V : Boolean;
+ S : in out String;
+ P : out Natural)
+ is
+ pragma Assert (S'First = 1);
begin
if V then
- return "TRUE";
+ S (1 .. 4) := "TRUE";
+ P := 4;
else
- return "FALSE";
+ S (1 .. 5) := "FALSE";
+ P := 5;
end if;
end Image_Boolean;
package System.Img_Bool is
pragma Pure;
- function Image_Boolean (V : Boolean) return String;
- -- Computes Boolean'Image (V) and returns the result
+ procedure Image_Boolean
+ (V : Boolean;
+ S : in out String;
+ P : out Natural);
+ -- Computes Boolean'Image (V) and stores the result in S (1 .. P)
+ -- setting the resulting value of P. The caller guarantees that S
+ -- is long enough to hold the result, and that S'First is 1.
end System.Img_Bool;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Character --
---------------------
- function Image_Character (V : Character) return String is
- subtype Cname is String (1 .. 3);
+ procedure Image_Character
+ (V : Character;
+ S : in out String;
+ P : out Natural)
+ is
+ pragma Assert (S'First = 1);
- S : Cname;
+ subtype Cname is String (1 .. 3);
subtype C0_Range is Character
range Character'Val (16#00#) .. Character'Val (16#1F#);
-- Control characters are represented by their names (RM 3.5(32))
if V in C0_Range then
- S := C0 (V);
+ S (1 .. 3) := C0 (V);
if S (3) = ' ' then
- return S (1 .. 2);
+ P := 2;
else
- return S;
+ P := 3;
end if;
elsif V in C1_Range then
- S := C1 (V);
+ S (1 .. 3) := C1 (V);
if S (1) /= 'r' then
if S (3) = ' ' then
- return S (1 .. 2);
+ P := 2;
else
- return S;
+ P := 3;
end if;
-- Special case, res means RESERVED_nnn where nnn is the three digit
else
declare
VP : constant Natural := Character'Pos (V);
- St : String (1 .. 12) := "RESERVED_xxx";
-
begin
- St (10) := Character'Val (48 + VP / 100);
- St (11) := Character'Val (48 + (VP / 10) mod 10);
- St (12) := Character'Val (48 + VP mod 10);
- return St;
+ S (1 .. 9) := "RESERVED_";
+ S (10) := Character'Val (48 + VP / 100);
+ S (11) := Character'Val (48 + (VP / 10) mod 10);
+ S (12) := Character'Val (48 + VP mod 10);
+ P := 12;
end;
end if;
S (1) := ''';
S (2) := V;
S (3) := ''';
- return S;
+ P := 3;
end if;
end Image_Character;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
package System.Img_Char is
pragma Pure;
- function Image_Character (V : Character) return String;
- -- Computes Character'Image (V) and returns the result
+ procedure Image_Character
+ (V : Character;
+ S : in out String;
+ P : out Natural);
+ -- Computes Character'Image (V) and stores the result in S (1 .. P)
+ -- setting the resulting value of P. The caller guarantees that S is
+ -- long enough to hold the result, and that S'First is 1.
end System.Img_Char;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Decimal --
-------------------
- function Image_Decimal
+ procedure Image_Decimal
(V : Integer;
- Scale : Integer) return String
+ S : in out String;
+ P : out Natural;
+ Scale : Integer)
is
- P : Natural := 0;
- S : String (1 .. 64);
+ pragma Assert (S'First = 1);
begin
- Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
-
- -- Mess around to make sure we have the objectionable space at the
- -- start for positive numbers in accordance with the annoying rules!
+ -- Add space at start for non-negative numbers
- if S (1) /= ' ' and then S (1) /= '-' then
- S (2 .. P + 1) := S (1 .. P);
+ if V >= 0 then
S (1) := ' ';
- return S (1 .. P + 1);
+ P := 1;
else
- return S (1 .. P);
+ P := 0;
end if;
+
+ Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
end Image_Decimal;
------------------------
end if;
end Round;
+ ---------
+ -- Set --
+ ---------
+
procedure Set (C : Character) is
begin
P := P + 1;
S (P) := C;
end Set;
+ -------------------------
+ -- Set_Blanks_And_Sign --
+ -------------------------
+
procedure Set_Blanks_And_Sign (N : Integer) is
W : Integer := N;
end if;
end Set_Blanks_And_Sign;
+ ----------------
+ -- Set_Digits --
+ ----------------
+
procedure Set_Digits (S, E : Natural) is
begin
for J in S .. E loop
end loop;
end Set_Digits;
+ ----------------
+ -- Set_Zeroes --
+ ----------------
+
procedure Set_Zeroes (N : Integer) is
begin
for J in 1 .. N loop
end if;
end if;
end if;
-
end Set_Decimal_Digits;
-----------------------
procedure Set_Image_Decimal
(V : Integer;
- S : out String;
+ S : in out String;
P : in out Natural;
Scale : Integer;
Fore : Natural;
Aft : Natural;
Exp : Natural)
is
- Digs : String := Image_Integer (V);
+ Digs : String := Integer'Image (V);
-- Sign and digits of decimal value
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- type does not exceed Integer'Size (also used for Text_IO.Decimal_IO output)
package System.Img_Dec is
- pragma Preelaborate;
+ pragma Pure;
- function Image_Decimal
+ procedure Image_Decimal
(V : Integer;
- Scale : Integer) return String;
- -- Compute 'Image of V, the integer value (in units of delta) of a decimal
- -- type whose Scale is as given and return the result. THe image is given
- -- by the rules in RM 3.5(34) for fixed-point type image functions.
+ S : in out String;
+ P : out Natural;
+ Scale : Integer);
+ -- Computes fixed_type'Image (V), where V is the integer value (in units of
+ -- delta) of a decimal type whose Scale is as given and stores the result
+ -- S (1 .. P), updating P to the value of L. The image is given by the
+ -- rules in RM 3.5(34) for fixed-point type image functions. The caller
+ -- guarantees that S is long enough to hold the result. S need not have a
+ -- lower bound of 1.
procedure Set_Image_Decimal
(V : Integer;
- S : out String;
+ S : in out String;
P : in out Natural;
Scale : Integer;
Fore : Natural;
-- will not necessarily be raised if this requirement is violated, since
-- it is perfectly valid to compile this unit with checks off. The Fore,
-- Aft and Exp values can be set to any valid values for the case of use
- -- by Text_IO.Decimal_IO.
+ -- by Text_IO.Decimal_IO. Note that there is no leading space stored.
procedure Set_Decimal_Digits
(Digs : in out String;
-- Enumeration_Type'Image for all enumeration types except those in package
-- Standard (where we have no opportunity to build image tables), and in
-- package System (where it is too early to start building image tables).
--- Special routines exist for the enumeration routines in these packages.
+-- Special routines exist for the enumeration types in these packages.
+
+-- Note: this is an obsolete package, replaced by System.Img_Enum_New, which
+-- provides procedures instead of functions for these enumeration image calls.
+-- The reason we maintain this package is that when bootstrapping with old
+-- compilers, the old compiler will search for this unit, expectinng to find
+-- these functions. The new commpiler will search for procedures in the new
+-- version of the unit.
pragma Warnings (Off);
pragma Compiler_Unit;
function Image_Enumeration_8
(Pos : Natural;
Names : String;
- Indexes : System.Address)
- return String;
+ Indexes : System.Address) return String;
-- Used to compute Enum'Image (Str) where Enum is some enumeration type
-- other than those defined in package Standard. Names is a string with a
-- lower bound of 1 containing the characters of all the enumeration
function Image_Enumeration_16
(Pos : Natural;
Names : String;
- Indexes : System.Address)
- return String;
+ Indexes : System.Address) return String;
-- Identical to Image_Enumeration_8 except that it handles types
-- using array (0 .. Num) of Natural_16 for the Indexes table.
function Image_Enumeration_32
(Pos : Natural;
Names : String;
- Indexes : System.Address)
- return String;
+ Indexes : System.Address) return String;
-- Identical to Image_Enumeration_8 except that it handles types
-- using array (0 .. Num) of Natural_32 for the Indexes table.
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Integer --
-------------------
- function Image_Integer (V : Integer) return String is
- P : Natural;
- S : String (1 .. Integer'Width);
+ procedure Image_Integer
+ (V : Integer;
+ S : in out String;
+ P : out Natural)
+ is
+ pragma Assert (S'First = 1);
+
+ procedure Set_Digits (T : Integer);
+ -- Set digits of absolute value of T, which is zero or negative. We work
+ -- with the negative of the value so that the largest negative number is
+ -- not a special case.
+
+ ----------------
+ -- Set_Digits --
+ ----------------
+
+ procedure Set_Digits (T : Integer) is
+ begin
+ if T <= -10 then
+ Set_Digits (T / 10);
+ P := P + 1;
+ S (P) := Character'Val (48 - (T rem 10));
+ else
+ P := P + 1;
+ S (P) := Character'Val (48 - T);
+ end if;
+ end Set_Digits;
+
+ -- Start of processinng for Image_Integer
begin
+ P := 1;
+
if V >= 0 then
- P := 1;
S (P) := ' ';
+ Set_Digits (-V);
else
- P := 0;
+ S (P) := '-';
+ Set_Digits (V);
end if;
-
- Set_Image_Integer (V, S, P);
- return S (1 .. P);
end Image_Integer;
-----------------------
procedure Set_Image_Integer
(V : Integer;
- S : out String;
+ S : in out String;
P : in out Natural)
is
procedure Set_Digits (T : Integer);
-- with the negative of the value so that the largest negative number is
-- not a special case.
+ ----------------
+ -- Set_Digits --
+ ----------------
+
procedure Set_Digits (T : Integer) is
begin
if T <= -10 then
Set_Digits (T / 10);
P := P + 1;
S (P) := Character'Val (48 - (T rem 10));
-
else
P := P + 1;
S (P) := Character'Val (48 - T);
begin
if V >= 0 then
Set_Digits (-V);
-
else
P := P + 1;
S (P) := '-';
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
package System.Img_Int is
pragma Pure;
- function Image_Integer (V : Integer) return String;
- -- Computes Integer'Image (V) and returns the result
+ procedure Image_Integer
+ (V : Integer;
+ S : in out String;
+ P : out Natural);
+ -- Computes Integer'Image (V) and stores the result in S (1 .. P)
+ -- setting the resulting value of P. The caller guarantees that S
+ -- is long enough to hold the result, and that S'First is 1.
procedure Set_Image_Integer
(V : Integer;
- S : out String;
+ S : in out String;
P : in out Natural);
- -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
- -- Text_IO format where Width = 0), starting at S (P + 1), updating P
- -- to point to the last character stored. The caller promises that the
- -- buffer is large enough and no check is made for this (Constraint_Error
- -- will not be necessarily raised if this is violated since it is perfectly
- -- valid to compile this unit with checks off).
+ -- Stores the image of V in S starting at S (P + 1), P is updated to point
+ -- to the last character stored. The value stored is identical to the value
+ -- of Integer'Image (V) except that no leading space is stored when V is
+ -- non-negative. The caller guarantees that S is long enough to hold the
+ -- result. S need not have a lower bound of 1.
end System.Img_Int;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
------------------------------------------------------------------------------
with System.Img_Dec; use System.Img_Dec;
-with System.Img_LLI; use System.Img_LLI;
package body System.Img_LLD is
-----------------------------
-- Image_Long_Long_Decimal --
- -----------------------------
+ ----------------------------
- function Image_Long_Long_Decimal
+ procedure Image_Long_Long_Decimal
(V : Long_Long_Integer;
+ S : in out String;
+ P : out Natural;
Scale : Integer)
- return String
is
- P : Natural := 0;
- S : String (1 .. 64);
+ pragma Assert (S'First = 1);
begin
- Set_Image_Long_Long_Decimal
- (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
-
- -- Mess around to make sure we have the objectionable space at the
- -- start for positive numbers in accordance with the annoying rules!
+ -- Add space at start for non-negative numbers
- if S (1) /= ' ' and then S (1) /= '-' then
- S (2 .. P + 1) := S (1 .. P);
+ if V >= 0 then
S (1) := ' ';
- return S (1 .. P + 1);
+ P := 1;
else
- return S (1 .. P);
+ P := 0;
end if;
+
+ Set_Image_Long_Long_Decimal
+ (V, S, P, Scale, 1, Integer'Max (1, Scale), 0);
end Image_Long_Long_Decimal;
---------------------------------
procedure Set_Image_Long_Long_Decimal
(V : Long_Long_Integer;
- S : out String;
+ S : in out String;
P : in out Natural;
Scale : Integer;
Fore : Natural;
Aft : Natural;
Exp : Natural)
is
- Digs : String := Image_Long_Long_Integer (V);
+ Digs : String := Long_Long_Integer'Image (V);
-- Sign and digits of decimal value
begin
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- type does exceeds Integer'Size (also used for Text_IO.Decimal_IO output)
package System.Img_LLD is
- pragma Preelaborate;
+ pragma Pure;
- function Image_Long_Long_Decimal
+ procedure Image_Long_Long_Decimal
(V : Long_Long_Integer;
- Scale : Integer)
- return String;
- -- Compute 'Image of V, the integer value (in units of delta) of a decimal
- -- type whose Scale is as given and returns the result. The image is given
- -- by the rules in RM 3.5(34) for fixed-point type image functions.
+ S : in out String;
+ P : out Natural;
+ Scale : Integer);
+ -- Computes fixed_type'Image (V), where V is the integer value (in units of
+ -- delta) of a decimal type whose Scale is as given and store the result in
+ -- S (P + 1 .. L), updating P to the value of L. The image is given by the
+ -- rules in RM 3.5(34) for fixed-point type image functions. The caller
+ -- guarantees that S is long enough to hold the result. S need not have a
+ -- lower bound of 1.
procedure Set_Image_Long_Long_Decimal
(V : Long_Long_Integer;
- S : out String;
+ S : in out String;
P : in out Natural;
Scale : Integer;
Fore : Natural;
-- will not necessarily be raised if this requirement is violated, since
-- it is perfectly valid to compile this unit with checks off. The Fore,
-- Aft and Exp values can be set to any valid values for the case of use
- -- by Text_IO.Decimal_IO.
+ -- by Text_IO.Decimal_IO. Note that there is no leading space stored.
end System.Img_LLD;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Long_Long_Integer --
-----------------------------
- function Image_Long_Long_Integer (V : Long_Long_Integer) return String is
- P : Natural;
- S : String (1 .. Long_Long_Integer'Width);
+ procedure Image_Long_Long_Integer
+ (V : Long_Long_Integer;
+ S : in out String;
+ P : out Natural)
+ is
+ pragma Assert (S'First = 1);
begin
if V >= 0 then
+ S (1) := ' ';
P := 1;
- S (P) := ' ';
else
P := 0;
end if;
Set_Image_Long_Long_Integer (V, S, P);
- return S (1 .. P);
end Image_Long_Long_Integer;
- ---------------------------------
+ ------------------------------
-- Set_Image_Long_Long_Integer --
- ---------------------------------
+ -----------------------------
procedure Set_Image_Long_Long_Integer
(V : Long_Long_Integer;
- S : out String;
+ S : in out String;
P : in out Natural)
is
procedure Set_Digits (T : Long_Long_Integer);
-- with the negative of the value so that the largest negative number is
-- not a special case.
+ ----------------
+ -- Set_Digits --
+ ----------------
+
procedure Set_Digits (T : Long_Long_Integer) is
begin
if T <= -10 then
Set_Digits (T / 10);
P := P + 1;
S (P) := Character'Val (48 - (T rem 10));
-
else
P := P + 1;
S (P) := Character'Val (48 - T);
begin
if V >= 0 then
Set_Digits (-V);
-
else
P := P + 1;
S (P) := '-';
Set_Digits (V);
end if;
-
end Set_Image_Long_Long_Integer;
end System.Img_LLI;
-- operations required in Text_IO.Integer_IO for such types.
package System.Img_LLI is
- pragma Preelaborate;
+ pragma Pure;
- function Image_Long_Long_Integer (V : Long_Long_Integer) return String;
- -- Computes Long_Long_Integer'Image (V) and returns the result
+ procedure Image_Long_Long_Integer
+ (V : Long_Long_Integer;
+ S : in out String;
+ P : out Natural);
+ -- Computes Long_Long_Integer'Image (V) and stores the result in
+ -- S (1 .. P) setting the resulting value of P. The caller guarantees
+ -- that S is long enough to hold the result, and that S'First is 1.
procedure Set_Image_Long_Long_Integer
(V : Long_Long_Integer;
- S : out String;
+ S : in out String;
P : in out Natural);
- -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
- -- Text_IO format where Width = 0), starting at S (P + 1), updating P
- -- to point to the last character stored. The caller promises that the
- -- buffer is large enough and no check is made for this (Constraint_Error
- -- will not be necessarily raised if this is violated since it is perfectly
- -- valid to compile this unit with checks off).
+ -- Stores the image of V in S starting at S (P + 1), P is updated to point
+ -- to the last character stored. The value stored is identical to the value
+ -- of Long_Long_Integer'Image (V) except that no leading space is stored
+ -- when V is non-negative. The caller guarantees that S is long enough to
+ -- hold the result. S need not have a lower bound of 1.
end System.Img_LLI;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Long_Long_Unsigned --
------------------------------
- function Image_Long_Long_Unsigned
- (V : Long_Long_Unsigned)
- return String
+ procedure Image_Long_Long_Unsigned
+ (V : System.Unsigned_Types.Long_Long_Unsigned;
+ S : in out String;
+ P : out Natural)
is
- P : Natural;
- S : String (1 .. Long_Long_Unsigned'Width);
-
+ pragma Assert (S'First = 1);
begin
+ S (1) := ' ';
P := 1;
- S (P) := ' ';
Set_Image_Long_Long_Unsigned (V, S, P);
- return S (1 .. P);
end Image_Long_Long_Unsigned;
- -----------------------
+ ----------------------------------
-- Set_Image_Long_Long_Unsigned --
- -----------------------
+ ----------------------------------
procedure Set_Image_Long_Long_Unsigned
(V : Long_Long_Unsigned;
- S : out String;
+ S : in out String;
P : in out Natural)
is
procedure Set_Digits (T : Long_Long_Unsigned);
-- Set digits of absolute value of T
+ ----------------
+ -- Set_Digits --
+ ----------------
+
procedure Set_Digits (T : Long_Long_Unsigned) is
begin
if T >= 10 then
begin
Set_Digits (V);
-
end Set_Image_Long_Long_Unsigned;
end System.Img_LLU;
package System.Img_LLU is
pragma Pure;
- function Image_Long_Long_Unsigned
- (V : System.Unsigned_Types.Long_Long_Unsigned)
- return String;
- -- Computes Long_Long_Unsigned'Image (V) and returns the result
+ procedure Image_Long_Long_Unsigned
+ (V : System.Unsigned_Types.Long_Long_Unsigned;
+ S : in out String;
+ P : out Natural);
+ pragma Inline (Image_Long_Long_Unsigned);
+
+ -- Computes Long_Long_Unsigned'Image (V) and stores the result in
+ -- S (1 .. P) setting the resulting value of P. The caller guarantees
+ -- that S is long enough to hold the result, and that S'First is 1.
procedure Set_Image_Long_Long_Unsigned
(V : System.Unsigned_Types.Long_Long_Unsigned;
- S : out String;
+ S : in out String;
P : in out Natural);
- -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
- -- Text_IO format where Width = 0), starting at S (P + 1), updating P
- -- to point to the last character stored. The caller promises that the
- -- buffer is large enough and no check is made for this (Constraint_Error
- -- will not be necessarily raised if this is violated since it is perfectly
- -- valid to compile this unit with checks off).
+ -- Stores the image of V in S starting at S (P + 1), P is updated to point
+ -- to the last character stored. The value stored is identical to the value
+ -- of Long_Long_Unsigned'Image (V) except that no leading space is stored.
+ -- The caller guarantees that S is long enough to hold the result. S need
+ -- not have a lower bound of 1.
end System.Img_LLU;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Floating_Point --
--------------------------
- function Image_Floating_Point
+ procedure Image_Floating_Point
(V : Long_Long_Float;
+ S : in out String;
+ P : out Natural;
Digs : Natural)
- return String
is
- P : Natural := 0;
- S : String (1 .. Long_Long_Float'Width);
+ pragma Assert (S'First = 1);
begin
-- Decide wether a blank should be prepended before the call to
then
S (1) := ' ';
P := 1;
+ else
+ P := 0;
end if;
Set_Image_Real (V, S, P, 1, Digs - 1, 3);
- return S (1 .. P);
end Image_Floating_Point;
--------------------------------
-- Image_Ordinary_Fixed_Point --
--------------------------------
- function Image_Ordinary_Fixed_Point
- (V : Long_Long_Float;
- Aft : Natural)
- return String
+ procedure Image_Ordinary_Fixed_Point
+ (V : Long_Long_Float;
+ S : in out String;
+ P : out Natural;
+ Aft : Natural)
is
- P : Natural := 0;
- S : String (1 .. Long_Long_Float'Width);
+ pragma Assert (S'First = 1);
begin
+ -- Output space at start if non-negative
+
if V >= 0.0 then
S (1) := ' ';
P := 1;
+ else
+ P := 0;
end if;
Set_Image_Real (V, S, P, 1, Aft, 0);
- return S (1 .. P);
end Image_Ordinary_Fixed_Point;
--------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image for fixed and float types (also used for Float_IO/Fixed_IO output)
package System.Img_Real is
- pragma Preelaborate;
+ pragma Pure;
- function Image_Ordinary_Fixed_Point
- (V : Long_Long_Float;
- Aft : Natural)
- return String;
- -- Computes the image of V and returns the result according to the rules
- -- for image for fixed-point types (RM 3.5(34)), where Aft is the value of
- -- the Aft attribute for the fixed-point type. This function is used only
- -- for ordinary fixed point (see package System.Img_Dec for handling of
- -- decimal fixed-point).
+ procedure Image_Ordinary_Fixed_Point
+ (V : Long_Long_Float;
+ S : in out String;
+ P : out Natural;
+ Aft : Natural);
+ -- Computes fixed_type'Image (V) and returns the result in S (1 .. P)
+ -- updating P on return. The result is computed according to the rules for
+ -- image for fixed-point types (RM 3.5(34)), where Aft is the value of the
+ -- Aft attribute for the fixed-point type. This function is used only for
+ -- ordinary fixed point (see package System.Img_Dec for handling of decimal
+ -- fixed-point). The caller guarantees that S is long enough to hold the
+ -- result and has a lower bound of 1.
- function Image_Floating_Point
+ procedure Image_Floating_Point
(V : Long_Long_Float;
- Digs : Natural)
- return String;
- -- Computes the image of V and returns the result according to the rules
- -- for image for foating-point types (RM 3.5(33)), where Digs is the value
- -- of the Digits attribute for the floating-point type.
+ S : in out String;
+ P : out Natural;
+ Digs : Natural);
+ -- Computes fixed_type'Image (V) and returns the result in S (1 .. P)
+ -- updating P on return. The result is computed according to the rules for
+ -- image for floating-point types (RM 3.5(33)), where Digs is the value of
+ -- the Digits attribute for the floating-point type. The caller guarantees
+ -- that S is long enough to hold the result and has a lower bound of 1.
procedure Set_Image_Real
(V : Long_Long_Float;
-- enough and no check is made for this. Constraint_Error will not
-- necessarily be raised if this is violated, since it is perfectly valid
-- to compile this unit with checks off). The Fore, Aft and Exp values
- -- can be set to any valid values for the case of use from Text_IO.
+ -- can be set to any valid values for the case of use from Text_IO. Note
+ -- that no space is stored at the start for non-negative values.
end System.Img_Real;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Unsigned --
--------------------
- function Image_Unsigned
- (V : Unsigned)
- return String
+ procedure Image_Unsigned
+ (V : System.Unsigned_Types.Unsigned;
+ S : in out String;
+ P : out Natural)
is
- P : Natural;
- S : String (1 .. Unsigned'Width);
-
+ pragma Assert (S'First = 1);
begin
+ S (1) := ' ';
P := 1;
- S (P) := ' ';
Set_Image_Unsigned (V, S, P);
- return S (1 .. P);
end Image_Unsigned;
------------------------
procedure Set_Image_Unsigned
(V : Unsigned;
- S : out String;
+ S : in out String;
P : in out Natural)
is
procedure Set_Digits (T : Unsigned);
-- Set decimal digits of value of T
+ ----------------
+ -- Set_Digits --
+ ----------------
+
procedure Set_Digits (T : Unsigned) is
begin
if T >= 10 then
begin
Set_Digits (V);
-
end Set_Image_Unsigned;
end System.Img_Uns;
package System.Img_Uns is
pragma Pure;
- function Image_Unsigned
- (V : System.Unsigned_Types.Unsigned)
- return String;
- -- Computes Unsigned'Image (V) and returns the result
+ procedure Image_Unsigned
+ (V : System.Unsigned_Types.Unsigned;
+ S : in out String;
+ P : out Natural);
+ pragma Inline (Image_Unsigned);
+ -- Computes Unsigned'Image (V) and stores the result in S (1 .. P)
+ -- setting the resulting value of P. The caller guarantees that S
+ -- is long enough to hold the result, and that S'First is 1.
procedure Set_Image_Unsigned
(V : System.Unsigned_Types.Unsigned;
- S : out String;
+ S : in out String;
P : in out Natural);
- -- Sets the image of V starting at S (P + 1) with no leading spaces (i.e.
- -- Text_IO format where Width = 0), starting at S (P + 1), updating P
- -- to point to the last character stored. The caller promises that the
- -- buffer is large enough and no check is made for this (Constraint_Error
- -- will not be necessarily raised if this is violated since it is perfectly
- -- valid to compile this unit with checks off).
+ -- Stores the image of V in S starting at S (P + 1), P is updated to point
+ -- to the last character stored. The value stored is identical to the value
+ -- of Unsigned'Image (V) except that no leading space is stored. The caller
+ -- guarantees that S is long enough to hold the result. S need not have a
+ -- lower bound of 1.
end System.Img_Uns;
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
-- Image_Wide_Character --
--------------------------
- function Image_Wide_Character
+ procedure Image_Wide_Character
(V : Wide_Character;
- Ada_2005 : Boolean) return String
+ S : in out String;
+ P : out Natural;
+ Ada_2005 : Boolean)
is
+ pragma Assert (S'First = 1);
+
begin
-- Annoying Ada 95 incompatibility with FFFE/FFFF
and then not Ada_2005
then
if V = Wide_Character'Val (16#FFFE#) then
- return "FFFE";
+ S (1 .. 4) := "FFFE";
else
- return "FFFF";
+ S (1 .. 4) := "FFFF";
end if;
- end if;
+
+ P := 4;
-- Normal case, same as Wide_Wide_Character
- return
- Image_Wide_Wide_Character
- (Wide_Wide_Character'Val (Wide_Character'Pos (V)));
+ else
+ Image_Wide_Wide_Character
+ (Wide_Wide_Character'Val (Wide_Character'Pos (V)), S, P);
+ end if;
end Image_Wide_Character;
-------------------------------
-- Image_Wide_Wide_Character --
-------------------------------
- function Image_Wide_Wide_Character
- (V : Wide_Wide_Character) return String
+ procedure Image_Wide_Wide_Character
+ (V : Wide_Wide_Character;
+ S : in out String;
+ P : out Natural)
is
+ pragma Assert (S'First = 1);
+
Val : Unsigned_32 := Wide_Wide_Character'Pos (V);
begin
-- If in range of standard Character, use Character routine
if Val <= 16#FF# then
- return Image_Character (Character'Val (Wide_Wide_Character'Pos (V)));
+ Image_Character (Character'Val (Wide_Wide_Character'Pos (V)), S, P);
-- Otherwise value returned is Hex_hhhhhhhh
else
declare
- Result : String (1 .. 12) := "Hex_hhhhhhhh";
- Hex : constant array (Unsigned_32 range 0 .. 15) of Character :=
- "0123456789ABCDEF";
+ Hex : constant array (Unsigned_32 range 0 .. 15) of Character :=
+ "0123456789ABCDEF";
begin
+ S (1 .. 4) := "Hex_";
+
for J in reverse 5 .. 12 loop
- Result (J) := Hex (Val mod 16);
+ S (J) := Hex (Val mod 16);
Val := Val / 16;
end loop;
- return Result;
+ P := 12;
end;
end if;
end Image_Wide_Wide_Character;
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2007, 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- --
package System.Img_WChar is
pragma Pure;
- function Image_Wide_Character
+ procedure Image_Wide_Character
(V : Wide_Character;
- Ada_2005 : Boolean) return String;
- -- Computes Wide_Character'Image (V) and returns the computed result. The
- -- parameter Ada_2005 is True if operating in Ada 2005 mode (or beyond).
- -- This is needed for the annoying FFFE/FFFF incompatibility.
+ S : in out String;
+ P : out Natural;
+ Ada_2005 : Boolean);
+ -- Computes Wide_Character'Image (V) and stores the result in S (1 .. P)
+ -- setting the resulting value of P. The caller guarantees that S is long
+ -- enough to hold the result, and that S'First is 1. The parameter Ada_2005
+ -- is True if operating in Ada 2005 mode (or beyond). This is required to
+ -- deal with the annoying FFFE/FFFF incompatibility.
- function Image_Wide_Wide_Character (V : Wide_Wide_Character) return String;
- -- Computes Wide_Wide_Character'Image (V) and returns the computed result
+ procedure Image_Wide_Wide_Character
+ (V : Wide_Wide_Character;
+ S : in out String;
+ P : out Natural);
+ -- Computes Wide_Wide_Character'Image (V) and stores the result in
+ -- S (1 .. P) setting the resulting value of P. The caller guarantees
+ -- that S is long enough to hold the result, and that S'First is 1.
end System.Img_WChar;
projects / platform / upstream / gcc.git / commitdiff