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 <o...@adacore.com> * g-forstr.adb, g-forstr.ads: New. * gnat_rm.texi, impunit.adb Makefile.rtl: Add new unit GNAT.Formatted_String.
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;