------------------------------------------------------------------------------ -- -- -- 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-2023, 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 -- -- . -- -- -- -- 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; 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 G_Specifier, -- %g G_Specifier_Up, -- %G Char, -- %c Str, -- %s Pointer -- %p ); type Sign_Kind is (Neg, Zero, Pos); subtype Is_Number is F_Kind range Decimal_Int .. G_Specifier_Up; 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; type Notation is (Decimal, Scientific); procedure Advance_And_Accumulate_Until_Next_Specifier (Format : Formatted_String); -- Advance Format.D.Index until either the next format specifier is -- encountered, or the end of Format.D.Format is reached. The characters -- advanced over are appended to Format.D.Result. 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 procedure Determine_Notation_And_Aft (Exponent : Integer; Precision : Text_IO.Field; Nota : out Notation; Aft : out Text_IO.Field); -- Determine whether to use scientific or decimal notation and the value of -- Aft given the exponent and precision of a real number, as described in -- the C language specification, section 7.21.6.1. function Get_Formatted (F_Spec : F_Data; Value : String; Len : Positive) return String; -- Returns Value formatted given the information in F_Spec procedure Increment_Integral_Part (Buffer : in out String; First_Non_Blank : in out Positive; Last_Digit_Position : Positive); -- Buffer must contain the textual representation of a number. -- Last_Digit_Position must be the position of the rightmost digit of the -- integral part. Buffer must have at least one padding blank. Increment -- the integral part. 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 procedure Remove_Extraneous_Decimal_Digit (Textual_Rep : in out String; First_Non_Blank : in out Positive); -- Remove the unique digit to the right of the point in Textual_Rep procedure Trim_Fractional_Part (Textual_Rep : in out String; First_Non_Blank : in out Positive); -- Remove trailing zeros from Textual_Rep, which must be the textual -- representation of a real number. If the fractional part only contains -- zeros, also remove the point. --------- -- "+" -- --------- 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 begin -- Make sure we get the remaining character up to the next unhandled -- format specifier. Advance_And_Accumulate_Until_Next_Specifier (Format); return To_String (Format.D.Result); 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; ------------------------------------------------- -- Advance_And_Accumulate_Until_Next_Specifier -- ------------------------------------------------- procedure Advance_And_Accumulate_Until_Next_Specifier (Format : Formatted_String) is begin loop if Format.D.Index > Format.D.Format'Last then exit; end if; if Format.D.Format (Format.D.Index) /= '%' then Append (Format.D.Result, Format.D.Format (Format.D.Index)); Format.D.Index := Format.D.Index + 1; elsif Format.D.Index + 1 <= Format.D.Format'Last and then Format.D.Format (Format.D.Index + 1) = '%' then Append (Format.D.Result, '%'); Format.D.Index := Format.D.Index + 2; else exit; end if; end loop; end Advance_And_Accumulate_Until_Next_Specifier; -------------------------------- -- Determine_Notation_And_Aft -- -------------------------------- procedure Determine_Notation_And_Aft (Exponent : Integer; Precision : Text_IO.Field; Nota : out Notation; Aft : out Text_IO.Field) is -- The constants use the same names as those from the C specification -- in order to match the description of the predicate. P : constant Text_IO.Field := (if Precision /= 0 then Precision else 1); X : constant Integer := Exponent; begin if P > X and X >= -4 then Nota := Decimal; Aft := P - (X + 1); else Nota := Scientific; Aft := P - 1; end if; end Determine_Notation_And_Aft; -------------------- -- 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; ----------------------------- -- Increment_Integral_Part -- ----------------------------- procedure Increment_Integral_Part (Buffer : in out String; First_Non_Blank : in out Positive; Last_Digit_Position : Positive) is Cursor : Natural := Last_Digit_Position; begin while Buffer (Cursor) = '9' loop Buffer (Cursor) := '0'; Cursor := Cursor - 1; end loop; pragma Assert (Cursor > 0); if Buffer (Cursor) in '0' .. '8' then Buffer (Cursor) := Character'Succ (Buffer (Cursor)); else Ada.Strings.Fixed.Insert (Buffer, Cursor + 1, "1"); First_Non_Blank := First_Non_Blank - 1; end if; end Increment_Integral_Part; ---------------- -- 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 % Advance_And_Accumulate_Until_Next_Specifier (Format); 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 := G_Specifier; when 'G' => F_Spec.Kind := G_Specifier_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 procedure Compute_Exponent (Var : Flt; Valid : out Boolean; Exponent : out Integer); -- If Var is invalid (for example, a NaN of an inf), set Valid False and -- set Exponent to 0. Otherwise, set Valid True, and store the exponent -- of the scientific notation representation of Var in Exponent. The -- exponent can also be defined as: -- - If Var = 0, 0. -- - Otherwise, Floor (Log_10 (Abs (Var))). procedure Format_With_Notation (Var : Flt; Nota : Notation; Aft : Text_IO.Field; Buffer : out String); -- Fill buffer with the formatted value of Var following the notation -- specified through Nota. procedure Handle_G_Specifier (Buffer : out String; First_Non_Blank : out Positive; Aft : Text_IO.Field); -- Fill Buffer with the formatted value of Var according to the rules of -- the "%g" specifier. Buffer is right-justified and padded with blanks. ---------------------- -- Compute_Exponent -- ---------------------- procedure Compute_Exponent (Var : Flt; Valid : out Boolean; Exponent : out Integer) is -- The way the exponent is computed is convoluted. It is not possible -- to use the logarithm in base 10 of Var and floor it, because the -- math functions for this are not available for fixed point types. -- Instead, use the generic Put procedure to produce a scientific -- representation of Var, and parse the exponent part of that back -- into an Integer. Scientific_Rep : String (1 .. 50); E_Position : Natural; begin Put (Scientific_Rep, Var, Aft => 1, Exp => 1); E_Position := Ada.Strings.Fixed.Index (Scientific_Rep, "E"); if E_Position = 0 then Valid := False; Exponent := 0; else Valid := True; Exponent := Integer'Value (Scientific_Rep (E_Position + 1 .. Scientific_Rep'Last)); end if; end Compute_Exponent; -------------------------- -- Format_With_Notation -- -------------------------- procedure Format_With_Notation (Var : Flt; Nota : Notation; Aft : Text_IO.Field; Buffer : out String) is Exp : constant Text_IO.Field := (case Nota is when Decimal => 0, when Scientific => 3); begin Put (Buffer, Var, Aft, Exp); end Format_With_Notation; ------------------------ -- Handle_G_Specifier -- ------------------------ procedure Handle_G_Specifier (Buffer : out String; First_Non_Blank : out Positive; Aft : Text_IO.Field) is -- There is nothing that is directly equivalent to the "%g" specifier -- in the standard Ada functionality provided by Ada.Text_IO. The -- procedure Put will still be used, but significant postprocessing -- will be performed on the output of that procedure. -- The following code is intended to match the behavior of C's printf -- for %g, as described by paragraph "7.21.6.1 The fprintf function" -- of the C language specification. -- As explained in the C specification, we're going to have to make a -- choice between decimal notation and scientific notation. One of -- the elements we need in order to make that choice is the value of -- the exponent in the decimal representation of Var. We will store -- that value in Exponent. Exponent : Integer; Valid : Boolean; Nota : Notation; -- The value of the formal Aft comes from the precision specifier in -- the format string. For %g, the precision specifier corresponds to -- the number of significant figures desired, whereas the formal Aft -- in Put corresponds to the number of digits after the point. -- Effective_Aft is what will be passed to Put as Aft in order to -- respect the semantics of %g. Effective_Aft : Text_IO.Field; Textual_Rep : String (Buffer'Range); begin Compute_Exponent (Var, Valid, Exponent); Determine_Notation_And_Aft (Exponent, Aft, Nota, Effective_Aft); Format_With_Notation (Var, Nota, Effective_Aft, Textual_Rep); First_Non_Blank := Strings.Fixed.Index_Non_Blank (Textual_Rep); if not Valid then null; elsif Effective_Aft = 0 then -- Special case: it is possible at this point that Effective_Aft -- is zero. But when Put is passed zero through Aft, it still -- outputs one digit after the point. See the reference manual, -- A.10.9.25. Remove_Extraneous_Decimal_Digit (Textual_Rep, First_Non_Blank); else Trim_Fractional_Part (Textual_Rep, First_Non_Blank); end if; Buffer := Textual_Rep; end Handle_G_Specifier; -- Local variables F : F_Data; Buffer : String (1 .. 50); S, E : Positive := 1; Start : Positive; Aft : Text_IO.Field; -- Start of processing for P_Flt_Format begin Next_Format (Format, F, Start); if F.Value_Needed /= Format.D.Stored_Value then Raise_Wrong_Format (Format); end if; Format.D.Stored_Value := 0; 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 G_Specifier | G_Specifier_Up => Handle_G_Specifier (Buffer, S, Aft); E := Buffer'Last; if F.Kind = G_Specifier 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; Format.D.Stored_Value := 0; 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; ------------------------------------- -- Remove_Extraneous_Decimal_Digit -- ------------------------------------- procedure Remove_Extraneous_Decimal_Digit (Textual_Rep : in out String; First_Non_Blank : in out Positive) is Point_Position : constant Positive := Ada.Strings.Fixed.Index (Textual_Rep, ".", First_Non_Blank); Integral_Part_Needs_Increment : constant Boolean := Textual_Rep (Point_Position + 1) in '5' .. '9'; begin Ada.Strings.Fixed.Delete (Textual_Rep, Point_Position, Point_Position + 1, Ada.Strings.Right); First_Non_Blank := First_Non_Blank + 2; if Integral_Part_Needs_Increment then Increment_Integral_Part (Textual_Rep, First_Non_Blank, Last_Digit_Position => Point_Position + 1); end if; end Remove_Extraneous_Decimal_Digit; -------------------------- -- Trim_Fractional_Part -- -------------------------- procedure Trim_Fractional_Part (Textual_Rep : in out String; First_Non_Blank : in out Positive) is Cursor : Positive := Ada.Strings.Fixed.Index (Textual_Rep, ".", First_Non_Blank); First_To_Trim : Positive; Fractional_Part_Last : Positive; begin while Cursor + 1 <= Textual_Rep'Last and then Textual_Rep (Cursor + 1) in '0' .. '9' loop Cursor := Cursor + 1; end loop; Fractional_Part_Last := Cursor; while Textual_Rep (Cursor) = '0' loop Cursor := Cursor - 1; end loop; if Textual_Rep (Cursor) = '.' then Cursor := Cursor - 1; end if; First_To_Trim := Cursor + 1; Ada.Strings.Fixed.Delete (Textual_Rep, First_To_Trim, Fractional_Part_Last, Ada.Strings.Right); First_Non_Blank := First_Non_Blank + (Fractional_Part_Last - First_To_Trim + 1); end Trim_Fractional_Part; end GNAT.Formatted_String;