blob: 8ce8d1cffd3027ac9137199f0a944ce0e7543e06 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . F O R M A T T E D _ S T R I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2014-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling;
with Ada.Float_Text_IO;
with Ada.Integer_Text_IO;
with Ada.Long_Float_Text_IO;
with Ada.Long_Integer_Text_IO;
with Ada.Strings.Fixed;
with Ada.Unchecked_Deallocation;
with System.Address_Image;
package body GNAT.Formatted_String is
type F_Kind is (Decimal_Int, -- %d %i
Unsigned_Decimal_Int, -- %u
Unsigned_Octal, -- %o
Unsigned_Hexadecimal_Int, -- %x
Unsigned_Hexadecimal_Int_Up, -- %X
Decimal_Float, -- %f %F
Decimal_Scientific_Float, -- %e
Decimal_Scientific_Float_Up, -- %E
Shortest_Decimal_Float, -- %g
Shortest_Decimal_Float_Up, -- %G
Char, -- %c
Str, -- %s
Pointer -- %p
);
type Sign_Kind is (Neg, Zero, Pos);
subtype Is_Number is F_Kind range Decimal_Int .. Decimal_Float;
type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg;
type F_Base is (None, C_Style, Ada_Style) with Default_Value => None;
Unset : constant Integer := -1;
type F_Data is record
Kind : F_Kind;
Width : Natural := 0;
Precision : Integer := Unset;
Left_Justify : Boolean := False;
Sign : F_Sign;
Base : F_Base;
Zero_Pad : Boolean := False;
Value_Needed : Natural range 0 .. 2 := 0;
end record;
procedure Next_Format
(Format : Formatted_String;
F_Spec : out F_Data;
Start : out Positive);
-- Parse the next format specifier, a format specifier has the following
-- syntax: %[flags][width][.precision][length]specifier
function Get_Formatted
(F_Spec : F_Data;
Value : String;
Len : Positive) return String;
-- Returns Value formatted given the information in F_Spec
procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return;
-- Raise the Format_Error exception which information about the context
generic
type Flt is private;
with procedure Put
(To : out String;
Item : Flt;
Aft : Text_IO.Field;
Exp : Text_IO.Field);
function P_Flt_Format
(Format : Formatted_String;
Var : Flt) return Formatted_String;
-- Generic routine which handles all floating point numbers
generic
type Int is private;
with function To_Integer (Item : Int) return Integer;
with function Sign (Item : Int) return Sign_Kind;
with procedure Put
(To : out String;
Item : Int;
Base : Text_IO.Number_Base);
function P_Int_Format
(Format : Formatted_String;
Var : Int) return Formatted_String;
-- Generic routine which handles all the integer numbers
---------
-- "+" --
---------
function "+" (Format : String) return Formatted_String is
begin
return Formatted_String'
(Finalization.Controlled with
D => new Data'(Format'Length, 1, 1,
Null_Unbounded_String, 0, 0, [0, 0], Format));
end "+";
---------
-- "-" --
---------
function "-" (Format : Formatted_String) return String is
F : String renames Format.D.Format;
J : Natural renames Format.D.Index;
R : Unbounded_String := Format.D.Result;
begin
-- Make sure we get the remaining character up to the next unhandled
-- format specifier.
while (J <= F'Length and then F (J) /= '%')
or else (J < F'Length - 1 and then F (J + 1) = '%')
loop
Append (R, F (J));
-- If we have two consecutive %, skip the second one
if F (J) = '%' and then J < F'Length - 1 and then F (J + 1) = '%' then
J := J + 1;
end if;
J := J + 1;
end loop;
return To_String (R);
end "-";
---------
-- "&" --
---------
function "&"
(Format : Formatted_String;
Var : Character) return Formatted_String
is
F : F_Data;
Start : Positive;
begin
Next_Format (Format, F, Start);
if F.Value_Needed > 0 then
Raise_Wrong_Format (Format);
end if;
case F.Kind is
when Char =>
Append (Format.D.Result, Get_Formatted (F, String'(1 => Var), 1));
when others =>
Raise_Wrong_Format (Format);
end case;
return Format;
end "&";
function "&"
(Format : Formatted_String;
Var : String) return Formatted_String
is
F : F_Data;
Start : Positive;
begin
Next_Format (Format, F, Start);
if F.Value_Needed > 0 then
Raise_Wrong_Format (Format);
end if;
case F.Kind is
when Str =>
declare
S : constant String := Get_Formatted (F, Var, Var'Length);
begin
if F.Precision = Unset then
Append (Format.D.Result, S);
else
Append
(Format.D.Result,
S (S'First .. S'First + F.Precision - 1));
end if;
end;
when others =>
Raise_Wrong_Format (Format);
end case;
return Format;
end "&";
function "&"
(Format : Formatted_String;
Var : Boolean) return Formatted_String is
begin
return Format & Boolean'Image (Var);
end "&";
function "&"
(Format : Formatted_String;
Var : Float) return Formatted_String
is
function Float_Format is new Flt_Format (Float, Float_Text_IO.Put);
begin
return Float_Format (Format, Var);
end "&";
function "&"
(Format : Formatted_String;
Var : Long_Float) return Formatted_String
is
function Float_Format is
new Flt_Format (Long_Float, Long_Float_Text_IO.Put);
begin
return Float_Format (Format, Var);
end "&";
function "&"
(Format : Formatted_String;
Var : Duration) return Formatted_String
is
package Duration_Text_IO is new Text_IO.Fixed_IO (Duration);
function Duration_Format is
new P_Flt_Format (Duration, Duration_Text_IO.Put);
begin
return Duration_Format (Format, Var);
end "&";
function "&"
(Format : Formatted_String;
Var : Integer) return Formatted_String
is
function Integer_Format is
new Int_Format (Integer, Integer_Text_IO.Put);
begin
return Integer_Format (Format, Var);
end "&";
function "&"
(Format : Formatted_String;
Var : Long_Integer) return Formatted_String
is
function Integer_Format is
new Int_Format (Long_Integer, Long_Integer_Text_IO.Put);
begin
return Integer_Format (Format, Var);
end "&";
function "&"
(Format : Formatted_String;
Var : System.Address) return Formatted_String
is
A_Img : constant String := System.Address_Image (Var);
F : F_Data;
Start : Positive;
begin
Next_Format (Format, F, Start);
if F.Value_Needed > 0 then
Raise_Wrong_Format (Format);
end if;
case F.Kind is
when Pointer =>
Append (Format.D.Result, Get_Formatted (F, A_Img, A_Img'Length));
when others =>
Raise_Wrong_Format (Format);
end case;
return Format;
end "&";
------------
-- Adjust --
------------
overriding procedure Adjust (F : in out Formatted_String) is
begin
F.D.Ref_Count := F.D.Ref_Count + 1;
end Adjust;
--------------------
-- Decimal_Format --
--------------------
function Decimal_Format
(Format : Formatted_String;
Var : Flt) return Formatted_String
is
function Flt_Format is new P_Flt_Format (Flt, Put);
begin
return Flt_Format (Format, Var);
end Decimal_Format;
-----------------
-- Enum_Format --
-----------------
function Enum_Format
(Format : Formatted_String;
Var : Enum) return Formatted_String is
begin
return Format & Enum'Image (Var);
end Enum_Format;
--------------
-- Finalize --
--------------
overriding procedure Finalize (F : in out Formatted_String) is
procedure Unchecked_Free is
new Unchecked_Deallocation (Data, Data_Access);
D : Data_Access := F.D;
begin
F.D := null;
D.Ref_Count := D.Ref_Count - 1;
if D.Ref_Count = 0 then
Unchecked_Free (D);
end if;
end Finalize;
------------------
-- Fixed_Format --
------------------
function Fixed_Format
(Format : Formatted_String;
Var : Flt) return Formatted_String
is
function Flt_Format is new P_Flt_Format (Flt, Put);
begin
return Flt_Format (Format, Var);
end Fixed_Format;
----------------
-- Flt_Format --
----------------
function Flt_Format
(Format : Formatted_String;
Var : Flt) return Formatted_String
is
function Flt_Format is new P_Flt_Format (Flt, Put);
begin
return Flt_Format (Format, Var);
end Flt_Format;
-------------------
-- Get_Formatted --
-------------------
function Get_Formatted
(F_Spec : F_Data;
Value : String;
Len : Positive) return String
is
use Ada.Strings.Fixed;
Res : Unbounded_String;
S : Positive := Value'First;
begin
-- Handle the flags
if F_Spec.Kind in Is_Number then
if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then
Append (Res, "+");
elsif F_Spec.Sign = Space and then Value (Value'First) /= '-' then
Append (Res, " ");
end if;
if Value (Value'First) = '-' then
Append (Res, "-");
S := S + 1;
end if;
end if;
-- Zero padding if required and possible
if not F_Spec.Left_Justify
and then F_Spec.Zero_Pad
and then F_Spec.Width > Len + Value'First - S
then
Append (Res, String'((F_Spec.Width - (Len + Value'First - S)) * '0'));
end if;
-- Add the value now
Append (Res, Value (S .. Value'Last));
declare
R : String (1 .. Natural'Max (Natural'Max (F_Spec.Width, Len),
Length (Res))) := [others => ' '];
begin
if F_Spec.Left_Justify then
R (1 .. Length (Res)) := To_String (Res);
else
R (R'Last - Length (Res) + 1 .. R'Last) := To_String (Res);
end if;
return R;
end;
end Get_Formatted;
----------------
-- Int_Format --
----------------
function Int_Format
(Format : Formatted_String;
Var : Int) return Formatted_String
is
function Sign (Var : Int) return Sign_Kind is
(if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
function To_Integer (Var : Int) return Integer is
(Integer (Var));
function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
begin
return Int_Format (Format, Var);
end Int_Format;
----------------
-- Mod_Format --
----------------
function Mod_Format
(Format : Formatted_String;
Var : Int) return Formatted_String
is
function Sign (Var : Int) return Sign_Kind is
(if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
function To_Integer (Var : Int) return Integer is
(Integer (Var));
function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
begin
return Int_Format (Format, Var);
end Mod_Format;
-----------------
-- Next_Format --
-----------------
procedure Next_Format
(Format : Formatted_String;
F_Spec : out F_Data;
Start : out Positive)
is
F : String renames Format.D.Format;
J : Natural renames Format.D.Index;
S : Natural;
Width_From_Var : Boolean := False;
begin
Format.D.Current := Format.D.Current + 1;
F_Spec.Value_Needed := 0;
-- Got to next %
while (J <= F'Last and then F (J) /= '%')
or else (J < F'Last - 1 and then F (J + 1) = '%')
loop
Append (Format.D.Result, F (J));
-- If we have two consecutive %, skip the second one
if F (J) = '%' and then J < F'Last - 1 and then F (J + 1) = '%' then
J := J + 1;
end if;
J := J + 1;
end loop;
if J >= F'Last or else F (J) /= '%' then
raise Format_Error with "no format specifier found for parameter"
& Positive'Image (Format.D.Current);
end if;
Start := J;
J := J + 1;
-- Check for any flags
Flags_Check : while J < F'Last loop
if F (J) = '-' then
F_Spec.Left_Justify := True;
elsif F (J) = '+' then
F_Spec.Sign := Forced;
elsif F (J) = ' ' then
F_Spec.Sign := Space;
elsif F (J) = '#' then
F_Spec.Base := C_Style;
elsif F (J) = '~' then
F_Spec.Base := Ada_Style;
elsif F (J) = '0' then
F_Spec.Zero_Pad := True;
else
exit Flags_Check;
end if;
J := J + 1;
end loop Flags_Check;
-- Check width if any
if F (J) in '0' .. '9' then
-- We have a width parameter
S := J;
while J < F'Last and then F (J + 1) in '0' .. '9' loop
J := J + 1;
end loop;
F_Spec.Width := Natural'Value (F (S .. J));
J := J + 1;
elsif F (J) = '*' then
-- The width will be taken from the integer parameter
F_Spec.Value_Needed := 1;
Width_From_Var := True;
J := J + 1;
end if;
if F (J) = '.' then
-- We have a precision parameter
J := J + 1;
if F (J) in '0' .. '9' then
S := J;
while J < F'Length and then F (J + 1) in '0' .. '9' loop
J := J + 1;
end loop;
if F (J) = '.' then
-- No precision, 0 is assumed
F_Spec.Precision := 0;
else
F_Spec.Precision := Natural'Value (F (S .. J));
end if;
J := J + 1;
elsif F (J) = '*' then
-- The prevision will be taken from the integer parameter
F_Spec.Value_Needed := F_Spec.Value_Needed + 1;
J := J + 1;
end if;
end if;
-- Skip the length specifier, this is not needed for this implementation
-- but yet for compatibility reason it is handled.
Length_Check :
while J <= F'Last
and then F (J) in 'h' | 'l' | 'j' | 'z' | 't' | 'L'
loop
J := J + 1;
end loop Length_Check;
if J > F'Last then
Raise_Wrong_Format (Format);
end if;
-- Read next character which should be the expected type
case F (J) is
when 'c' => F_Spec.Kind := Char;
when 's' => F_Spec.Kind := Str;
when 'd' | 'i' => F_Spec.Kind := Decimal_Int;
when 'u' => F_Spec.Kind := Unsigned_Decimal_Int;
when 'f' | 'F' => F_Spec.Kind := Decimal_Float;
when 'e' => F_Spec.Kind := Decimal_Scientific_Float;
when 'E' => F_Spec.Kind := Decimal_Scientific_Float_Up;
when 'g' => F_Spec.Kind := Shortest_Decimal_Float;
when 'G' => F_Spec.Kind := Shortest_Decimal_Float_Up;
when 'o' => F_Spec.Kind := Unsigned_Octal;
when 'x' => F_Spec.Kind := Unsigned_Hexadecimal_Int;
when 'X' => F_Spec.Kind := Unsigned_Hexadecimal_Int_Up;
when others =>
raise Format_Error with "unknown format specified for parameter"
& Positive'Image (Format.D.Current);
end case;
J := J + 1;
if F_Spec.Value_Needed > 0
and then F_Spec.Value_Needed = Format.D.Stored_Value
then
if F_Spec.Value_Needed = 1 then
if Width_From_Var then
F_Spec.Width := Format.D.Stack (1);
else
F_Spec.Precision := Format.D.Stack (1);
end if;
else
F_Spec.Width := Format.D.Stack (1);
F_Spec.Precision := Format.D.Stack (2);
end if;
end if;
end Next_Format;
------------------
-- P_Flt_Format --
------------------
function P_Flt_Format
(Format : Formatted_String;
Var : Flt) return Formatted_String
is
F : F_Data;
Buffer : String (1 .. 50);
S, E : Positive := 1;
Start : Positive;
Aft : Text_IO.Field;
begin
Next_Format (Format, F, Start);
if F.Value_Needed > 0 then
Raise_Wrong_Format (Format);
end if;
if F.Precision = Unset then
Aft := 6;
else
Aft := F.Precision;
end if;
case F.Kind is
when Decimal_Float =>
Put (Buffer, Var, Aft, Exp => 0);
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
when Decimal_Scientific_Float
| Decimal_Scientific_Float_Up
=>
Put (Buffer, Var, Aft, Exp => 3);
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
if F.Kind = Decimal_Scientific_Float then
Buffer (S .. E) :=
Characters.Handling.To_Lower (Buffer (S .. E));
end if;
when Shortest_Decimal_Float
| Shortest_Decimal_Float_Up
=>
-- Without exponent
Put (Buffer, Var, Aft, Exp => 0);
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
-- Check with exponent
declare
Buffer2 : String (1 .. 50);
S2, E2 : Positive;
begin
Put (Buffer2, Var, Aft, Exp => 3);
S2 := Strings.Fixed.Index_Non_Blank (Buffer2);
E2 := Buffer2'Last;
-- If with exponent it is shorter, use it
if (E2 - S2) < (E - S) then
Buffer := Buffer2;
S := S2;
E := E2;
end if;
end;
if F.Kind = Shortest_Decimal_Float then
Buffer (S .. E) :=
Characters.Handling.To_Lower (Buffer (S .. E));
end if;
when others =>
Raise_Wrong_Format (Format);
end case;
Append (Format.D.Result,
Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length));
return Format;
end P_Flt_Format;
------------------
-- P_Int_Format --
------------------
function P_Int_Format
(Format : Formatted_String;
Var : Int) return Formatted_String
is
function Handle_Precision return Boolean;
-- Return True if nothing else to do
F : F_Data;
Buffer : String (1 .. 50);
S, E : Positive := 1;
Len : Natural := 0;
Start : Positive;
----------------------
-- Handle_Precision --
----------------------
function Handle_Precision return Boolean is
begin
if F.Precision = 0 and then Sign (Var) = Zero then
return True;
elsif F.Precision = Natural'Last then
null;
elsif F.Precision > E - S + 1 then
Len := F.Precision - (E - S + 1);
Buffer (S - Len .. S - 1) := [others => '0'];
S := S - Len;
end if;
return False;
end Handle_Precision;
-- Start of processing for P_Int_Format
begin
Next_Format (Format, F, Start);
if Format.D.Stored_Value < F.Value_Needed then
Format.D.Stored_Value := Format.D.Stored_Value + 1;
Format.D.Stack (Format.D.Stored_Value) := To_Integer (Var);
Format.D.Index := Start;
return Format;
end if;
case F.Kind is
when Unsigned_Octal =>
if Sign (Var) = Neg then
Raise_Wrong_Format (Format);
end if;
Put (Buffer, Var, Base => 8);
S := Strings.Fixed.Index (Buffer, "8#") + 2;
E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
if Handle_Precision then
return Format;
end if;
case F.Base is
when None => null;
when C_Style => Len := 1;
when Ada_Style => Len := 3;
end case;
when Unsigned_Hexadecimal_Int =>
if Sign (Var) = Neg then
Raise_Wrong_Format (Format);
end if;
Put (Buffer, Var, Base => 16);
S := Strings.Fixed.Index (Buffer, "16#") + 3;
E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
Buffer (S .. E) := Characters.Handling.To_Lower (Buffer (S .. E));
if Handle_Precision then
return Format;
end if;
case F.Base is
when None => null;
when C_Style => Len := 2;
when Ada_Style => Len := 4;
end case;
when Unsigned_Hexadecimal_Int_Up =>
if Sign (Var) = Neg then
Raise_Wrong_Format (Format);
end if;
Put (Buffer, Var, Base => 16);
S := Strings.Fixed.Index (Buffer, "16#") + 3;
E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
if Handle_Precision then
return Format;
end if;
case F.Base is
when None => null;
when C_Style => Len := 2;
when Ada_Style => Len := 4;
end case;
when Unsigned_Decimal_Int =>
if Sign (Var) = Neg then
Raise_Wrong_Format (Format);
end if;
Put (Buffer, Var, Base => 10);
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
if Handle_Precision then
return Format;
end if;
when Decimal_Int =>
Put (Buffer, Var, Base => 10);
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
if Handle_Precision then
return Format;
end if;
when Char =>
S := Buffer'First;
E := Buffer'First;
Buffer (S) := Character'Val (To_Integer (Var));
if Handle_Precision then
return Format;
end if;
when others =>
Raise_Wrong_Format (Format);
end case;
-- Then add base if needed
declare
N : String := Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len);
P : constant Positive :=
(if F.Left_Justify
then N'First
else Natural'Max (Strings.Fixed.Index_Non_Blank (N) - 1,
N'First));
begin
case F.Base is
when None =>
null;
when C_Style =>
case F.Kind is
when Unsigned_Octal =>
N (P) := 'O';
when Unsigned_Hexadecimal_Int =>
if F.Left_Justify then
N (P .. P + 1) := "Ox";
else
N (P - 1 .. P) := "0x";
end if;
when Unsigned_Hexadecimal_Int_Up =>
if F.Left_Justify then
N (P .. P + 1) := "OX";
else
N (P - 1 .. P) := "0X";
end if;
when others =>
null;
end case;
when Ada_Style =>
case F.Kind is
when Unsigned_Octal =>
if F.Left_Justify then
N (N'First + 2 .. N'Last) := N (N'First .. N'Last - 2);
else
N (P .. N'Last - 1) := N (P + 1 .. N'Last);
end if;
N (N'First .. N'First + 1) := "8#";
N (N'Last) := '#';
when Unsigned_Hexadecimal_Int
| Unsigned_Hexadecimal_Int_Up
=>
if F.Left_Justify then
N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3);
else
N (P .. N'Last - 1) := N (P + 1 .. N'Last);
end if;
N (N'First .. N'First + 2) := "16#";
N (N'Last) := '#';
when others =>
null;
end case;
end case;
Append (Format.D.Result, N);
end;
return Format;
end P_Int_Format;
------------------------
-- Raise_Wrong_Format --
------------------------
procedure Raise_Wrong_Format (Format : Formatted_String) is
begin
raise Format_Error with
"wrong format specified for parameter"
& Positive'Image (Format.D.Current);
end Raise_Wrong_Format;
end GNAT.Formatted_String;