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