Skip to content

R
riscv-gcc-1
Commit 01b18343 by Robert Dewar Committed by Arnaud Charlet
Options

s-imenne.adb, [...]: New files. 

2007-12-06  Robert Dewar  <dewar@adacore.com>

	* s-imenne.adb, s-imenne.ads: New files.

	* s-imgboo.adb, s-imgboo.ads, s-imgcha.adb, s-imgcha.ads, s-imgdec.adb, 
	s-imgdec.ads, s-imgenu.ads, s-imgint.adb, s-imgint.ads, s-imglld.adb, 
	s-imglld.ads, s-imglli.adb, s-imglli.ads, s-imgllu.adb, s-imgllu.ads, 
	s-imgrea.adb, s-imgrea.ads, s-imguns.adb, s-imguns.ads, s-imgwch.adb, 
	s-imgwch.ads: New calling sequence for Image routines to avoid sec
	stack usage.

From-SVN: r130852
parent 859fd598
Showing with 576 additions and 232 deletions
gcc/ada/s-imenne.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-imenne.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- 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;
gcc/ada/s-imgboo.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,12 +37,19 @@ package body System.Img_Bool is
-- 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;
......
gcc/ada/s-imgboo.ads
......@@ -36,7 +36,12 @@
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;
gcc/ada/s-imgcha.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,10 +37,14 @@ package body System.Img_Char is
-- 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#);
......@@ -121,22 +125,22 @@ package body System.Img_Char is
-- 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
......@@ -146,13 +150,12 @@ package body System.Img_Char is
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;
......@@ -162,7 +165,7 @@ package body System.Img_Char is
S (1) := ''';
S (2) := V;
S (3) := ''';
return S;
P := 3;
end if;
end Image_Character;
......
gcc/ada/s-imgcha.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -36,7 +36,12 @@
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;
gcc/ada/s-imgdec.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -39,26 +39,25 @@ package body System.Img_Dec is
-- 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;
------------------------
......@@ -188,12 +187,20 @@ package body System.Img_Dec is
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;
......@@ -214,6 +221,10 @@ package body System.Img_Dec is
end if;
end Set_Blanks_And_Sign;
----------------
-- Set_Digits --
----------------
procedure Set_Digits (S, E : Natural) is
begin
for J in S .. E loop
......@@ -221,6 +232,10 @@ package body System.Img_Dec is
end loop;
end Set_Digits;
----------------
-- Set_Zeroes --
----------------
procedure Set_Zeroes (N : Integer) is
begin
for J in 1 .. N loop
......@@ -330,7 +345,6 @@ package body System.Img_Dec is
end if;
end if;
end if;
end Set_Decimal_Digits;
-----------------------
......@@ -339,14 +353,14 @@ package body System.Img_Dec is
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
......
gcc/ada/s-imgdec.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -35,18 +35,23 @@
-- 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;
......@@ -59,7 +64,7 @@ package System.Img_Dec is
-- 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;
......
gcc/ada/s-imgenu.ads
......@@ -34,7 +34,14 @@
-- 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;
......@@ -46,8 +53,7 @@ package System.Img_Enum is
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
......@@ -62,16 +68,14 @@ package System.Img_Enum is
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.
......
gcc/ada/s-imgint.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,20 +37,46 @@ package body System.Img_Int is
-- 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;
-----------------------
......@@ -59,7 +85,7 @@ package body System.Img_Int is
procedure Set_Image_Integer
(V : Integer;
S : out String;
S : in out String;
P : in out Natural)
is
procedure Set_Digits (T : Integer);
......@@ -67,13 +93,16 @@ package body System.Img_Int is
-- 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);
......@@ -85,7 +114,6 @@ package body System.Img_Int is
begin
if V >= 0 then
Set_Digits (-V);
else
P := P + 1;
S (P) := '-';
......
gcc/ada/s-imgint.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -38,18 +38,22 @@
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;
gcc/ada/s-imglld.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -32,36 +32,33 @@
------------------------------------------------------------------------------
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;
---------------------------------
......@@ -70,14 +67,14 @@ package body System.Img_LLD is
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
......
gcc/ada/s-imglld.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -35,19 +35,23 @@
-- 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;
......@@ -60,6 +64,6 @@ package System.Img_LLD is
-- 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;
gcc/ada/s-imglli.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -37,29 +37,31 @@ package body System.Img_LLI is
-- 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);
......@@ -67,13 +69,16 @@ package body System.Img_LLI is
-- 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);
......@@ -85,13 +90,11 @@ package body System.Img_LLI is
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;
gcc/ada/s-imglli.ads
......@@ -36,20 +36,24 @@
-- 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;
gcc/ada/s-imgllu.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -39,32 +39,34 @@ package body System.Img_LLU is
-- 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
......@@ -82,7 +84,6 @@ package body System.Img_LLU is
begin
Set_Digits (V);
end Set_Image_Long_Long_Unsigned;
end System.Img_LLU;
gcc/ada/s-imgllu.ads
......@@ -40,20 +40,24 @@ with System.Unsigned_Types;
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;
gcc/ada/s-imgrea.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -78,13 +78,13 @@ package body System.Img_Real is
-- 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
......@@ -101,32 +101,36 @@ package body System.Img_Real is
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;
--------------------
......
gcc/ada/s-imgrea.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -34,25 +34,31 @@
-- 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;
......@@ -66,6 +72,7 @@ package System.Img_Real is
-- 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;
gcc/ada/s-imguns.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -39,18 +39,16 @@ package body System.Img_Uns is
-- 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;
------------------------
......@@ -59,12 +57,16 @@ package body System.Img_Uns is
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
......@@ -82,7 +84,6 @@ package body System.Img_Uns is
begin
Set_Digits (V);
end Set_Image_Unsigned;
end System.Img_Uns;
gcc/ada/s-imguns.ads
......@@ -40,20 +40,23 @@ with System.Unsigned_Types;
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;
gcc/ada/s-imgwch.adb
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -41,10 +41,14 @@ package body System.Img_WChar is
-- 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
......@@ -52,49 +56,56 @@ package body System.Img_WChar is
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;
......
gcc/ada/s-imgwch.ads
......@@ -6,7 +6,7 @@
-- --
-- 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- --
......@@ -36,14 +36,23 @@
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;
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