[Ada] New unit GNAT.Formatted_String providing C/C++ format string support
Arnaud Charlet
charlet@adacore.com
Wed Jul 30 10:37:00 GMT 2014
The following code:
with Ada.Text_IO; use Ada.Text_IO;
with GNAT.Formatted_String; use GNAT.Formatted_String;
procedure Fout is
F : Formatted_String := +"%c %% %#08x";
Vc : Character := 'v';
Vi : Integer := 12;
begin
F := F & Vc & Vi;
Put_Line (-F);
end Fout;
Should output:
v % 0x00000c
Tested on x86_64-pc-linux-gnu, committed on trunk
2014-07-30 Pascal Obry <obry@adacore.com>
* g-forstr.adb, g-forstr.ads: New.
* gnat_rm.texi, impunit.adb Makefile.rtl: Add new unit
GNAT.Formatted_String.
-------------- next part --------------
Index: gnat_rm.texi
===================================================================
--- gnat_rm.texi (revision 213240)
+++ gnat_rm.texi (working copy)
@@ -594,6 +594,7 @@
* GNAT.Expect (g-expect.ads)::
* GNAT.Expect.TTY (g-exptty.ads)::
* GNAT.Float_Control (g-flocon.ads)::
+* GNAT.Formatted_String (g-forstr.ads)::
* GNAT.Heap_Sort (g-heasor.ads)::
* GNAT.Heap_Sort_A (g-hesora.ads)::
* GNAT.Heap_Sort_G (g-hesorg.ads)::
@@ -18934,6 +18935,7 @@
* GNAT.Expect (g-expect.ads)::
* GNAT.Expect.TTY (g-exptty.ads)::
* GNAT.Float_Control (g-flocon.ads)::
+* GNAT.Formatted_String (g-forstr.ads)::
* GNAT.Heap_Sort (g-heasor.ads)::
* GNAT.Heap_Sort_A (g-hesora.ads)::
* GNAT.Heap_Sort_G (g-hesorg.ads)::
@@ -19860,6 +19862,18 @@
library calls may cause this mode to be modified, and the Reset procedure
in this package can be used to reestablish the required mode.
+@node GNAT.Formatted_String (g-forstr.ads)
+@section @code{GNAT.Formatted_String} (@file{g-forstr.ads})
+@cindex @code{GNAT.Formatted_String} (@file{g-forstr.ads})
+@cindex Formatted String
+
+@noindent
+Provides support for C/C++ printf() formatted string. The format is
+copied from the printf() routine and should therefore gives identical
+output. Some generic routines are provided to be able to use types
+derived from Integer, Float or enumerations as values for the
+formatted string.
+
@node GNAT.Heap_Sort (g-heasor.ads)
@section @code{GNAT.Heap_Sort} (@file{g-heasor.ads})
@cindex @code{GNAT.Heap_Sort} (@file{g-heasor.ads})
Index: impunit.adb
===================================================================
--- impunit.adb (revision 213201)
+++ impunit.adb (working copy)
@@ -273,6 +273,7 @@
("g-expect", F), -- GNAT.Expect
("g-exptty", F), -- GNAT.Expect.TTY
("g-flocon", F), -- GNAT.Float_Control
+ ("g-forstr", F), -- GNAT.Formatted_String
("g-heasor", F), -- GNAT.Heap_Sort
("g-hesora", F), -- GNAT.Heap_Sort_A
("g-hesorg", F), -- GNAT.Heap_Sort_G
Index: Makefile.rtl
===================================================================
--- Makefile.rtl (revision 213201)
+++ Makefile.rtl (working copy)
@@ -411,6 +411,7 @@
g-expect$(objext) \
g-exptty$(objext) \
g-flocon$(objext) \
+ g-forstr$(objext) \
g-heasor$(objext) \
g-hesora$(objext) \
g-hesorg$(objext) \
Index: g-forstr.adb
===================================================================
--- g-forstr.adb (revision 0)
+++ g-forstr.adb (revision 0)
@@ -0,0 +1,951 @@
+------------------------------------------------------------------------------
+-- --
+-- 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, 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, Format, 1,
+ Null_Unbounded_String, 0, 0, (0, 0)));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-" (Format : Formatted_String) return String is
+ F : String renames Format.D.Format;
+ I : 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 (I <= F'Length and then F (I) /= '%')
+ or else (I < F'Length - 1 and then F (I + 1) = '%')
+ loop
+ Append (R, F (I));
+
+ -- If we have two consecutive %, skip the second one
+
+ if F (I) = '%' and then I < F'Length - 1 and then F (I + 1) = '%' then
+ I := I + 1;
+ end if;
+
+ I := I + 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
+ -- Let's hanfles 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 F_Spec.Left_Justify = False
+ 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;
+ I : 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 (I <= F'Last and then F (I) /= '%')
+ or else (I < F'Last - 1 and then F (I + 1) = '%')
+ loop
+ Append (Format.D.Result, F (I));
+
+ -- If we have two consecutive %, skip the second one
+
+ if F (I) = '%' and then I < F'Last - 1 and then F (I + 1) = '%' then
+ I := I + 1;
+ end if;
+
+ I := I + 1;
+ end loop;
+
+ if F (I) /= '%' or else I = F'Last then
+ raise Format_Error with "no format specifier found for parameter"
+ & Positive'Image (Format.D.Current);
+ end if;
+
+ Start := I;
+
+ I := I + 1;
+
+ -- Check for any flags
+
+ Flags_Check : while I < F'Last loop
+ if F (I) = '-' then
+ F_Spec.Left_Justify := True;
+ elsif F (I) = '+' then
+ F_Spec.Sign := Forced;
+ elsif F (I) = ' ' then
+ F_Spec.Sign := Space;
+ elsif F (I) = '#' then
+ F_Spec.Base := C_Style;
+ elsif F (I) = '~' then
+ F_Spec.Base := Ada_Style;
+ elsif F (I) = '0' then
+ F_Spec.Zero_Pad := True;
+ else
+ exit Flags_Check;
+ end if;
+
+ I := I + 1;
+ end loop Flags_Check;
+
+ -- Check width if any
+
+ if F (I) in '0' .. '9' then
+ -- We have a width parameter
+
+ S := I;
+
+ while I < F'Last and then F (I + 1) in '0' .. '9' loop
+ I := I + 1;
+ end loop;
+
+ F_Spec.Width := Natural'Value (F (S .. I));
+
+ I := I + 1;
+
+ elsif F (I) = '*' then
+ -- The width will be taken from the integer parameter
+
+ F_Spec.Value_Needed := 1;
+ Width_From_Var := True;
+
+ I := I + 1;
+ end if;
+
+ if F (I) = '.' then
+ -- We have a precision parameter
+
+ I := I + 1;
+
+ if F (I) in '0' .. '9' then
+ S := I;
+
+ while I < F'Length and then F (I + 1) in '0' .. '9' loop
+ I := I + 1;
+ end loop;
+
+ if F (I) = '.' then
+ -- No precision, 0 is assumed
+ F_Spec.Precision := 0;
+ else
+ F_Spec.Precision := Natural'Value (F (S .. I));
+ end if;
+
+ I := I + 1;
+
+ elsif F (I) = '*' then
+ -- The prevision will be taken from the integer parameter
+
+ F_Spec.Value_Needed := F_Spec.Value_Needed + 1;
+ I := I + 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 I <= F'Last
+ and then F (I) in 'h' | 'l' | 'j' | 'z' | 't' | 'L'
+ loop
+ I := I + 1;
+ end loop Length_Check;
+
+ if I > F'Last then
+ Raise_Wrong_Format (Format);
+ end if;
+
+ -- Read next character which should be the expected type
+
+ case F (I) 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;
+
+ I := I + 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;
+
+ 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;
Index: g-forstr.ads
===================================================================
--- g-forstr.ads (revision 0)
+++ g-forstr.ads (revision 0)
@@ -0,0 +1,285 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- G N A T . F O R M A T T E D _ S T R I N G --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2014, 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package add support for formatted string as supported by C printf().
+--
+-- A simple usage is:
+--
+-- declare
+-- F : Formatted_String := +"['%c' ; %10d]";
+-- C : Character := 'v';
+-- I : Integer := 98;
+-- begin
+-- F := F & C & I;
+-- Put_Line (-F);
+--
+-- end;
+--
+-- Which will display:
+--
+-- ['v' ; 98]
+--
+--
+-- Each format specifier is: %[flags][width][.precision][length]specifier
+--
+-- Specifiers:
+-- d or i Signed decimal integer
+-- u Unsigned decimal integer
+-- o Unsigned octal
+-- x Unsigned hexadecimal integer
+-- X Unsigned hexadecimal integer (uppercase)
+-- f Decimal floating point, lowercase
+-- F Decimal floating point, uppercase
+-- e Scientific notation (mantissa/exponent), lowercase
+-- E Scientific notation (mantissa/exponent), uppercase
+-- g Use the shortest representation: %e or %f
+-- G Use the shortest representation: %E or %F
+-- c Character
+-- s String of characters
+-- p Pointer address
+-- % A % followed by another % character will write a single %
+--
+-- Flags:
+-- - Left-justify within the given field width;
+-- Right justification is the default
+-- + Forces to preceed the result with a plus or minus sign (+ or -)
+-- even for positive numbers. By default, only negative numbers
+-- are preceded with a - sign.
+-- (space) If no sign is going to be written, a blank space is inserted
+-- before the value.
+-- # Used with o, x or X specifiers the value is preceeded with
+-- 0, 0x or 0X respectively for values different than zero.
+-- Used with a, A, e, E, f, F, g or G it forces the written
+-- output to contain a decimal point even if no more digits
+-- follow. By default, if no digits follow, no decimal point is
+-- written.
+-- ~ As above, but using Ada style based <base>#<number>#
+-- 0 Left-pads the number with zeroes (0) instead of spaces when
+-- padding is specified.
+-- Width:
+-- number Minimum number of characters to be printed. If the value to
+-- be printed is shorter than this number, the result is padded
+-- with blank spaces. The value is not truncated even if the
+-- result is larger.
+-- * The width is not specified in the format string, but as an
+-- additional integer value argument preceding the argument that
+-- has to be formatted.
+-- Precision:
+-- number For integer specifiers (d, i, o, u, x, X): precision specifies
+-- the minimum number of digits to be written. If the value to be
+-- written is shorter than this number, the result is padded with
+-- leading zeros. The value is not truncated even if the result
+-- is longer. A precision of 0 means that no character is written
+-- for the value 0.
+-- For e, E, f and F specifiers: this is the number of digits to
+-- be printed after the decimal point (by default, this is 6).
+-- For g and G specifiers: This is the maximum number of
+-- significant digits to be printed.
+-- For s: this is the maximum number of characters to be printed.
+-- By default all characters are printed until the ending null
+-- character is encountered.
+-- If the period is specified without an explicit value for
+-- precision, 0 is assumed.
+-- .* The precision is not specified in the format string, but as an
+-- additional integer value argument preceding the argument that
+-- has to be formatted.
+
+with Ada.Text_IO;
+with System;
+
+private with Ada.Finalization;
+private with Ada.Strings.Unbounded;
+
+package GNAT.Formatted_String is
+
+ use Ada;
+
+ type Formatted_String (<>) is private;
+ -- A format string as defined for printf routine
+
+ Format_Error : exception;
+ -- Raised for every mismatch between the parameter and the expected format
+ -- and for malformed format.
+
+ function "+" (Format : String) return Formatted_String;
+ -- Create the format string
+
+ function "-" (Format : Formatted_String) return String;
+ -- Get the result of the formatted string corresponding to the current
+ -- rendering (up to the last parameter formated).
+
+ function "&"
+ (Format : Formatted_String;
+ Var : Character) return Formatted_String;
+ -- A character, expect a %c
+
+ function "&"
+ (Format : Formatted_String;
+ Var : String) return Formatted_String;
+ -- A string, expect a %s
+
+ function "&"
+ (Format : Formatted_String;
+ Var : Boolean) return Formatted_String;
+ -- A boolean image, expect a %s
+
+ function "&"
+ (Format : Formatted_String;
+ Var : Integer) return Formatted_String;
+ -- An integer, expect a %d, %o, %x, %X
+
+ function "&"
+ (Format : Formatted_String;
+ Var : Long_Integer) return Formatted_String;
+ -- As above
+
+ function "&"
+ (Format : Formatted_String;
+ Var : System.Address) return Formatted_String;
+ -- An address, expect a %p
+
+ function "&"
+ (Format : Formatted_String;
+ Var : Float) return Formatted_String;
+ -- A float, expect %f, %e, %F, %E, %g, %G
+
+ function "&"
+ (Format : Formatted_String;
+ Var : Long_Float) return Formatted_String;
+ -- As above
+
+ function "&"
+ (Format : Formatted_String;
+ Var : Duration) return Formatted_String;
+ -- As above
+
+ -- Some generics
+
+ generic
+ type Int is range <>;
+
+ with procedure Put
+ (To : out String;
+ Item : Int;
+ Base : Text_IO.Number_Base);
+ function Int_Format
+ (Format : Formatted_String;
+ Var : Int) return Formatted_String;
+ -- As for Integer above
+
+ generic
+ type Int is mod <>;
+
+ with procedure Put
+ (To : out String;
+ Item : Int;
+ Base : Text_IO.Number_Base);
+ function Mod_Format
+ (Format : Formatted_String;
+ Var : Int) return Formatted_String;
+ -- As for Integer above
+
+ generic
+ type Flt is digits <>;
+
+ with procedure Put
+ (To : out String;
+ Item : Flt;
+ Aft : Text_IO.Field;
+ Exp : Text_IO.Field);
+ function Flt_Format
+ (Format : Formatted_String;
+ Var : Flt) return Formatted_String;
+ -- As for Float above
+
+ generic
+ type Flt is delta <>;
+
+ with procedure Put
+ (To : out String;
+ Item : Flt;
+ Aft : Text_IO.Field;
+ Exp : Text_IO.Field);
+ function Fixed_Format
+ (Format : Formatted_String;
+ Var : Flt) return Formatted_String;
+ -- As for Float above
+
+ generic
+ type Flt is delta <> digits <>;
+
+ with procedure Put
+ (To : out String;
+ Item : Flt;
+ Aft : Text_IO.Field;
+ Exp : Text_IO.Field);
+ function Decimal_Format
+ (Format : Formatted_String;
+ Var : Flt) return Formatted_String;
+ -- As for Float above
+
+ generic
+ type Enum is (<>);
+ function Enum_Format
+ (Format : Formatted_String; Var : Enum) return Formatted_String;
+ -- As for String above, output the string representation of the enumeration
+
+private
+
+ use Ada.Strings.Unbounded;
+
+ type I_Vars is array (Positive range 1 .. 2) of Integer;
+ -- Used to keep 2 numbers for the possible * for the width and precision
+
+ type Data (Size : Natural) is record
+ Ref_Count : Natural := 1;
+ Format : String (1 .. Size); -- the format string
+ Index : Positive := 1; -- format index for next value
+ Result : Unbounded_String; -- current value
+ Current : Natural; -- the current format number
+ Stored_Value : Natural := 0; -- number of stored values in Stack
+ Stack : I_Vars;
+ end record;
+
+ type Data_Access is access Data;
+
+ -- The formatted string record is controlled and do not need an initialize
+ -- as it requires an explit initial value. This is given with "+" and
+ -- properly initialize the record at this point.
+
+ type Formatted_String is new Finalization.Controlled with record
+ D : Data_Access;
+ end record;
+
+ overriding procedure Adjust (F : in out Formatted_String);
+ overriding procedure Finalize (F : in out Formatted_String);
+
+end GNAT.Formatted_String;
More information about the Gcc-patches
mailing list