gcc/ada/libgnat/g-forstr.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                G N A T . F O R M A T T E D _ S T R I N G                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2014-2023, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.Characters.Handling;
  33 with Ada.Float_Text_IO;
  34 with Ada.Integer_Text_IO;
  35 with Ada.Long_Float_Text_IO;
  36 with Ada.Long_Integer_Text_IO;
  37 with Ada.Strings;
  38 with Ada.Strings.Fixed;
  39 with Ada.Unchecked_Deallocation;
  40
  41 with System.Address_Image;
  42
  43 package body GNAT.Formatted_String is
  44
  45    type F_Kind is (Decimal_Int,                 -- %d %i
  46                    Unsigned_Decimal_Int,        -- %u
  47                    Unsigned_Octal,              -- %o
  48                    Unsigned_Hexadecimal_Int,    -- %x
  49                    Unsigned_Hexadecimal_Int_Up, -- %X
  50                    Decimal_Float,               -- %f %F
  51                    Decimal_Scientific_Float,    -- %e
  52                    Decimal_Scientific_Float_Up, -- %E
  53                    G_Specifier,                 -- %g
  54                    G_Specifier_Up,              -- %G
  55                    Char,                        -- %c
  56                    Str,                         -- %s
  57                    Pointer                      -- %p
  58                   );
  59
  60    type Sign_Kind is (Neg, Zero, Pos);
  61
  62    subtype Is_Number is F_Kind range Decimal_Int .. G_Specifier_Up;
  63
  64    type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg;
  65
  66    type F_Base is (None, C_Style, Ada_Style) with Default_Value => None;
  67
  68    Unset : constant Integer := -1;
  69
  70    type F_Data is record
  71       Kind         : F_Kind;
  72       Width        : Natural := 0;
  73       Precision    : Integer := Unset;
  74       Left_Justify : Boolean := False;
  75       Sign         : F_Sign;
  76       Base         : F_Base;
  77       Zero_Pad     : Boolean := False;
  78       Value_Needed : Natural range 0 .. 2 := 0;
  79    end record;
  80
  81    type Notation is (Decimal, Scientific);
  82
  83    procedure Advance_And_Accumulate_Until_Next_Specifier
  84      (Format : Formatted_String);
  85    --  Advance Format.D.Index until either the next format specifier is
  86    --  encountered, or the end of Format.D.Format is reached. The characters
  87    --  advanced over are appended to Format.D.Result.
  88
  89    procedure Next_Format
  90      (Format : Formatted_String;
  91       F_Spec : out F_Data;
  92       Start  : out Positive);
  93    --  Parse the next format specifier, a format specifier has the following
  94    --  syntax: %[flags][width][.precision][length]specifier
  95
  96    procedure Determine_Notation_And_Aft
  97      (Exponent                : Integer;
  98       Precision               : Text_IO.Field;
  99       Nota                    : out Notation;
 100       Aft                     : out Text_IO.Field);
 101    --  Determine whether to use scientific or decimal notation and the value of
 102    --  Aft given the exponent and precision of a real number, as described in
 103    --  the C language specification, section 7.21.6.1.
 104
 105    function Get_Formatted
 106      (F_Spec : F_Data;
 107       Value  : String;
 108       Len    : Positive) return String;
 109    --  Returns Value formatted given the information in F_Spec
 110
 111    procedure Increment_Integral_Part
 112      (Buffer              : in out String;
 113       First_Non_Blank     : in out Positive;
 114       Last_Digit_Position : Positive);
 115    --  Buffer must contain the textual representation of a number.
 116    --  Last_Digit_Position must be the position of the rightmost digit of the
 117    --  integral part. Buffer must have at least one padding blank. Increment
 118    --  the integral part.
 119
 120    procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return;
 121    --  Raise the Format_Error exception which information about the context
 122
 123    generic
 124       type Flt is private;
 125
 126       with procedure Put
 127         (To   : out String;
 128          Item : Flt;
 129          Aft  : Text_IO.Field;
 130          Exp  : Text_IO.Field);
 131    function P_Flt_Format
 132      (Format : Formatted_String;
 133       Var    : Flt) return Formatted_String;
 134    --  Generic routine which handles all floating point numbers
 135
 136    generic
 137       type Int is private;
 138
 139       with function To_Integer (Item : Int) return Integer;
 140
 141       with function Sign (Item : Int) return Sign_Kind;
 142
 143       with procedure Put
 144         (To   : out String;
 145          Item : Int;
 146          Base : Text_IO.Number_Base);
 147    function P_Int_Format
 148      (Format : Formatted_String;
 149       Var    : Int) return Formatted_String;
 150    --  Generic routine which handles all the integer numbers
 151
 152    procedure Remove_Extraneous_Decimal_Digit
 153      (Textual_Rep     : in out String;
 154       First_Non_Blank : in out Positive);
 155    --  Remove the unique digit to the right of the point in Textual_Rep
 156
 157    procedure Trim_Fractional_Part
 158      (Textual_Rep     : in out String;
 159       First_Non_Blank : in out Positive);
 160    --  Remove trailing zeros from Textual_Rep, which must be the textual
 161    --  representation of a real number. If the fractional part only contains
 162    --  zeros, also remove the point.
 163
 164    ---------
 165    -- "+" --
 166    ---------
 167
 168    function "+" (Format : String) return Formatted_String is
 169    begin
 170       return Formatted_String'
 171         (Finalization.Controlled with
 172            D => new Data'(Format'Length, 1, 1,
 173              Null_Unbounded_String, 0, 0, [0, 0], Format));
 174    end "+";
 175
 176    ---------
 177    -- "-" --
 178    ---------
 179
 180    function "-" (Format : Formatted_String) return String is
 181    begin
 182       --  Make sure we get the remaining character up to the next unhandled
 183       --  format specifier.
 184
 185       Advance_And_Accumulate_Until_Next_Specifier (Format);
 186
 187       return To_String (Format.D.Result);
 188    end "-";
 189
 190    ---------
 191    -- "&" --
 192    ---------
 193
 194    function "&"
 195      (Format : Formatted_String;
 196       Var    : Character) return Formatted_String
 197    is
 198       F     : F_Data;
 199       Start : Positive;
 200
 201    begin
 202       Next_Format (Format, F, Start);
 203
 204       if F.Value_Needed > 0 then
 205          Raise_Wrong_Format (Format);
 206       end if;
 207
 208       case F.Kind is
 209          when Char =>
 210             Append (Format.D.Result, Get_Formatted (F, String'(1 => Var), 1));
 211          when others =>
 212             Raise_Wrong_Format (Format);
 213       end case;
 214
 215       return Format;
 216    end "&";
 217
 218    function "&"
 219      (Format : Formatted_String;
 220       Var    : String) return Formatted_String
 221    is
 222       F     : F_Data;
 223       Start : Positive;
 224
 225    begin
 226       Next_Format (Format, F, Start);
 227
 228       if F.Value_Needed > 0 then
 229          Raise_Wrong_Format (Format);
 230       end if;
 231
 232       case F.Kind is
 233          when Str =>
 234             declare
 235                S : constant String := Get_Formatted (F, Var, Var'Length);
 236             begin
 237                if F.Precision = Unset then
 238                   Append (Format.D.Result, S);
 239                else
 240                   Append
 241                     (Format.D.Result,
 242                      S (S'First .. S'First + F.Precision - 1));
 243                end if;
 244             end;
 245
 246          when others =>
 247             Raise_Wrong_Format (Format);
 248       end case;
 249
 250       return Format;
 251    end "&";
 252
 253    function "&"
 254      (Format : Formatted_String;
 255       Var    : Boolean) return Formatted_String is
 256    begin
 257       return Format & Boolean'Image (Var);
 258    end "&";
 259
 260    function "&"
 261      (Format : Formatted_String;
 262       Var    : Float) return Formatted_String
 263    is
 264       function Float_Format is new Flt_Format (Float, Float_Text_IO.Put);
 265    begin
 266       return Float_Format (Format, Var);
 267    end "&";
 268
 269    function "&"
 270      (Format : Formatted_String;
 271       Var    : Long_Float) return Formatted_String
 272    is
 273       function Float_Format is
 274         new Flt_Format (Long_Float, Long_Float_Text_IO.Put);
 275    begin
 276       return Float_Format (Format, Var);
 277    end "&";
 278
 279    function "&"
 280      (Format : Formatted_String;
 281       Var    : Duration) return Formatted_String
 282    is
 283       package Duration_Text_IO is new Text_IO.Fixed_IO (Duration);
 284       function Duration_Format is
 285         new P_Flt_Format (Duration, Duration_Text_IO.Put);
 286    begin
 287       return Duration_Format (Format, Var);
 288    end "&";
 289
 290    function "&"
 291      (Format : Formatted_String;
 292       Var    : Integer) return Formatted_String
 293    is
 294       function Integer_Format is
 295         new Int_Format (Integer, Integer_Text_IO.Put);
 296    begin
 297       return Integer_Format (Format, Var);
 298    end "&";
 299
 300    function "&"
 301      (Format : Formatted_String;
 302       Var    : Long_Integer) return Formatted_String
 303    is
 304       function Integer_Format is
 305         new Int_Format (Long_Integer, Long_Integer_Text_IO.Put);
 306    begin
 307       return Integer_Format (Format, Var);
 308    end "&";
 309
 310    function "&"
 311      (Format : Formatted_String;
 312       Var    : System.Address) return Formatted_String
 313    is
 314       A_Img : constant String := System.Address_Image (Var);
 315       F     : F_Data;
 316       Start : Positive;
 317
 318    begin
 319       Next_Format (Format, F, Start);
 320
 321       if F.Value_Needed > 0 then
 322          Raise_Wrong_Format (Format);
 323       end if;
 324
 325       case F.Kind is
 326          when Pointer =>
 327             Append (Format.D.Result, Get_Formatted (F, A_Img, A_Img'Length));
 328          when others =>
 329             Raise_Wrong_Format (Format);
 330       end case;
 331
 332       return Format;
 333    end "&";
 334
 335    ------------
 336    -- Adjust --
 337    ------------
 338
 339    overriding procedure Adjust (F : in out Formatted_String) is
 340    begin
 341       F.D.Ref_Count := F.D.Ref_Count + 1;
 342    end Adjust;
 343
 344    -------------------------------------------------
 345    -- Advance_And_Accumulate_Until_Next_Specifier --
 346    -------------------------------------------------
 347
 348    procedure Advance_And_Accumulate_Until_Next_Specifier
 349      (Format : Formatted_String)
 350    is
 351    begin
 352       loop
 353          if Format.D.Index > Format.D.Format'Last then
 354             exit;
 355          end if;
 356
 357          if Format.D.Format (Format.D.Index) /= '%' then
 358             Append (Format.D.Result, Format.D.Format (Format.D.Index));
 359             Format.D.Index := Format.D.Index + 1;
 360          elsif Format.D.Index + 1 <= Format.D.Format'Last
 361            and then Format.D.Format (Format.D.Index + 1) = '%'
 362          then
 363             Append (Format.D.Result, '%');
 364             Format.D.Index := Format.D.Index + 2;
 365          else
 366             exit;
 367          end if;
 368       end loop;
 369    end Advance_And_Accumulate_Until_Next_Specifier;
 370
 371    --------------------------------
 372    -- Determine_Notation_And_Aft --
 373    --------------------------------
 374
 375    procedure Determine_Notation_And_Aft
 376      (Exponent  : Integer;
 377       Precision : Text_IO.Field;
 378       Nota      : out Notation;
 379       Aft       : out Text_IO.Field)
 380    is
 381       --  The constants use the same names as those from the C specification
 382       --  in order to match the description of the predicate.
 383       P : constant Text_IO.Field := (if Precision /= 0 then Precision else 1);
 384       X : constant Integer       := Exponent;
 385    begin
 386       if P > X and X >= -4 then
 387          Nota := Decimal;
 388          Aft  := P - (X + 1);
 389       else
 390          Nota := Scientific;
 391          Aft  := P - 1;
 392       end if;
 393    end Determine_Notation_And_Aft;
 394
 395    --------------------
 396    -- Decimal_Format --
 397    --------------------
 398
 399    function Decimal_Format
 400      (Format : Formatted_String;
 401       Var    : Flt) return Formatted_String
 402    is
 403       function Flt_Format is new P_Flt_Format (Flt, Put);
 404    begin
 405       return Flt_Format (Format, Var);
 406    end Decimal_Format;
 407
 408    -----------------
 409    -- Enum_Format --
 410    -----------------
 411
 412    function Enum_Format
 413      (Format : Formatted_String;
 414       Var    : Enum) return Formatted_String is
 415    begin
 416       return Format & Enum'Image (Var);
 417    end Enum_Format;
 418
 419    --------------
 420    -- Finalize --
 421    --------------
 422
 423    overriding procedure Finalize (F : in out Formatted_String) is
 424       procedure Unchecked_Free is
 425         new Unchecked_Deallocation (Data, Data_Access);
 426
 427       D : Data_Access := F.D;
 428
 429    begin
 430       F.D := null;
 431
 432       D.Ref_Count := D.Ref_Count - 1;
 433
 434       if D.Ref_Count = 0 then
 435          Unchecked_Free (D);
 436       end if;
 437    end Finalize;
 438
 439    ------------------
 440    -- Fixed_Format --
 441    ------------------
 442
 443    function Fixed_Format
 444      (Format : Formatted_String;
 445       Var    : Flt) return Formatted_String
 446    is
 447       function Flt_Format is new P_Flt_Format (Flt, Put);
 448    begin
 449       return Flt_Format (Format, Var);
 450    end Fixed_Format;
 451
 452    ----------------
 453    -- Flt_Format --
 454    ----------------
 455
 456    function Flt_Format
 457      (Format : Formatted_String;
 458       Var    : Flt) return Formatted_String
 459    is
 460       function Flt_Format is new P_Flt_Format (Flt, Put);
 461    begin
 462       return Flt_Format (Format, Var);
 463    end Flt_Format;
 464
 465    -------------------
 466    -- Get_Formatted --
 467    -------------------
 468
 469    function Get_Formatted
 470      (F_Spec : F_Data;
 471       Value  : String;
 472       Len    : Positive) return String
 473    is
 474       use Ada.Strings.Fixed;
 475
 476       Res : Unbounded_String;
 477       S   : Positive := Value'First;
 478
 479    begin
 480       --  Handle the flags
 481
 482       if F_Spec.Kind in Is_Number then
 483          if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then
 484             Append (Res, "+");
 485          elsif F_Spec.Sign = Space and then Value (Value'First) /= '-' then
 486             Append (Res, " ");
 487          end if;
 488
 489          if Value (Value'First) = '-' then
 490             Append (Res, "-");
 491             S := S + 1;
 492          end if;
 493       end if;
 494
 495       --  Zero padding if required and possible
 496
 497       if not F_Spec.Left_Justify
 498         and then F_Spec.Zero_Pad
 499         and then F_Spec.Width > Len + Value'First - S
 500       then
 501          Append (Res, String'((F_Spec.Width - (Len + Value'First - S)) * '0'));
 502       end if;
 503
 504       --  Add the value now
 505
 506       Append (Res, Value (S .. Value'Last));
 507
 508       declare
 509          R : String (1 .. Natural'Max (Natural'Max (F_Spec.Width, Len),
 510                                        Length (Res))) := [others => ' '];
 511       begin
 512          if F_Spec.Left_Justify then
 513             R (1 .. Length (Res)) := To_String (Res);
 514          else
 515             R (R'Last - Length (Res) + 1 .. R'Last) := To_String (Res);
 516          end if;
 517
 518          return R;
 519       end;
 520    end Get_Formatted;
 521
 522    -----------------------------
 523    -- Increment_Integral_Part --
 524    -----------------------------
 525
 526    procedure Increment_Integral_Part
 527      (Buffer              : in out String;
 528       First_Non_Blank     : in out Positive;
 529       Last_Digit_Position : Positive)
 530    is
 531       Cursor : Natural := Last_Digit_Position;
 532    begin
 533       while Buffer (Cursor) = '9' loop
 534          Buffer (Cursor) := '0';
 535          Cursor          := Cursor - 1;
 536       end loop;
 537
 538       pragma Assert (Cursor > 0);
 539
 540       if Buffer (Cursor) in '0' .. '8' then
 541          Buffer (Cursor) := Character'Succ (Buffer (Cursor));
 542       else
 543          Ada.Strings.Fixed.Insert
 544            (Buffer,
 545             Cursor + 1,
 546             "1");
 547          First_Non_Blank := First_Non_Blank - 1;
 548       end if;
 549    end Increment_Integral_Part;
 550
 551    ----------------
 552    -- Int_Format --
 553    ----------------
 554
 555    function Int_Format
 556      (Format : Formatted_String;
 557       Var    : Int) return Formatted_String
 558    is
 559       function Sign (Var : Int) return Sign_Kind is
 560         (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
 561
 562       function To_Integer (Var : Int) return Integer is
 563         (Integer (Var));
 564
 565       function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
 566
 567    begin
 568       return Int_Format (Format, Var);
 569    end Int_Format;
 570
 571    ----------------
 572    -- Mod_Format --
 573    ----------------
 574
 575    function Mod_Format
 576      (Format : Formatted_String;
 577       Var    : Int) return Formatted_String
 578    is
 579       function Sign (Var : Int) return Sign_Kind is
 580         (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
 581
 582       function To_Integer (Var : Int) return Integer is
 583         (Integer (Var));
 584
 585       function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
 586
 587    begin
 588       return Int_Format (Format, Var);
 589    end Mod_Format;
 590
 591    -----------------
 592    -- Next_Format --
 593    -----------------
 594
 595    procedure Next_Format
 596      (Format : Formatted_String;
 597       F_Spec : out F_Data;
 598       Start  : out Positive)
 599    is
 600       F              : String  renames Format.D.Format;
 601       J              : Natural renames Format.D.Index;
 602       S              : Natural;
 603       Width_From_Var : Boolean := False;
 604
 605    begin
 606       Format.D.Current := Format.D.Current + 1;
 607       F_Spec.Value_Needed := 0;
 608
 609       --  Got to next %
 610
 611       Advance_And_Accumulate_Until_Next_Specifier (Format);
 612
 613       if J >= F'Last or else F (J) /= '%'  then
 614          raise Format_Error with "no format specifier found for parameter"
 615            & Positive'Image (Format.D.Current);
 616       end if;
 617
 618       Start := J;
 619
 620       J := J + 1;
 621
 622       --  Check for any flags
 623
 624       Flags_Check : while J < F'Last loop
 625          if F (J) = '-' then
 626             F_Spec.Left_Justify := True;
 627          elsif F (J) = '+' then
 628             F_Spec.Sign         := Forced;
 629          elsif F (J) = ' ' then
 630             F_Spec.Sign         := Space;
 631          elsif F (J) = '#' then
 632             F_Spec.Base         := C_Style;
 633          elsif F (J) = '~' then
 634             F_Spec.Base         := Ada_Style;
 635          elsif F (J) = '0' then
 636             F_Spec.Zero_Pad     := True;
 637          else
 638             exit Flags_Check;
 639          end if;
 640
 641          J := J + 1;
 642       end loop Flags_Check;
 643
 644       --  Check width if any
 645
 646       if F (J) in '0' .. '9' then
 647
 648          --  We have a width parameter
 649
 650          S := J;
 651
 652          while J < F'Last and then F (J + 1) in '0' .. '9' loop
 653             J := J + 1;
 654          end loop;
 655
 656          F_Spec.Width := Natural'Value (F (S .. J));
 657
 658          J := J + 1;
 659
 660       elsif F (J) = '*' then
 661
 662          --  The width will be taken from the integer parameter
 663
 664          F_Spec.Value_Needed := 1;
 665          Width_From_Var := True;
 666
 667          J := J + 1;
 668       end if;
 669
 670       if F (J) = '.' then
 671
 672          --  We have a precision parameter
 673
 674          J := J + 1;
 675
 676          if F (J) in '0' .. '9' then
 677             S := J;
 678
 679             while J < F'Length and then F (J + 1) in '0' .. '9' loop
 680                J := J + 1;
 681             end loop;
 682
 683             if F (J) = '.' then
 684
 685                --  No precision, 0 is assumed
 686
 687                F_Spec.Precision := 0;
 688
 689             else
 690                F_Spec.Precision := Natural'Value (F (S .. J));
 691             end if;
 692
 693             J := J + 1;
 694
 695          elsif F (J) = '*' then
 696
 697             --  The prevision will be taken from the integer parameter
 698
 699             F_Spec.Value_Needed := F_Spec.Value_Needed + 1;
 700             J := J + 1;
 701          end if;
 702       end if;
 703
 704       --  Skip the length specifier, this is not needed for this implementation
 705       --  but yet for compatibility reason it is handled.
 706
 707       Length_Check :
 708       while J <= F'Last
 709         and then F (J) in 'h' | 'l' | 'j' | 'z' | 't' | 'L'
 710       loop
 711          J := J + 1;
 712       end loop Length_Check;
 713
 714       if J > F'Last then
 715          Raise_Wrong_Format (Format);
 716       end if;
 717
 718       --  Read next character which should be the expected type
 719
 720       case F (J) is
 721          when 'c'       => F_Spec.Kind := Char;
 722          when 's'       => F_Spec.Kind := Str;
 723          when 'd' | 'i' => F_Spec.Kind := Decimal_Int;
 724          when 'u'       => F_Spec.Kind := Unsigned_Decimal_Int;
 725          when 'f' | 'F' => F_Spec.Kind := Decimal_Float;
 726          when 'e'       => F_Spec.Kind := Decimal_Scientific_Float;
 727          when 'E'       => F_Spec.Kind := Decimal_Scientific_Float_Up;
 728          when 'g'       => F_Spec.Kind := G_Specifier;
 729          when 'G'       => F_Spec.Kind := G_Specifier_Up;
 730          when 'o'       => F_Spec.Kind := Unsigned_Octal;
 731          when 'x'       => F_Spec.Kind := Unsigned_Hexadecimal_Int;
 732          when 'X'       => F_Spec.Kind := Unsigned_Hexadecimal_Int_Up;
 733
 734          when others =>
 735             raise Format_Error with "unknown format specified for parameter"
 736               & Positive'Image (Format.D.Current);
 737       end case;
 738
 739       J := J + 1;
 740
 741       if F_Spec.Value_Needed > 0
 742         and then F_Spec.Value_Needed = Format.D.Stored_Value
 743       then
 744          if F_Spec.Value_Needed = 1 then
 745             if Width_From_Var then
 746                F_Spec.Width := Format.D.Stack (1);
 747             else
 748                F_Spec.Precision := Format.D.Stack (1);
 749             end if;
 750
 751          else
 752             F_Spec.Width := Format.D.Stack (1);
 753             F_Spec.Precision := Format.D.Stack (2);
 754          end if;
 755       end if;
 756    end Next_Format;
 757
 758    ------------------
 759    -- P_Flt_Format --
 760    ------------------
 761
 762    function P_Flt_Format
 763      (Format : Formatted_String;
 764       Var    : Flt) return Formatted_String
 765    is
 766       procedure Compute_Exponent
 767         (Var      : Flt;
 768          Valid    : out Boolean;
 769          Exponent : out Integer);
 770       --  If Var is invalid (for example, a NaN of an inf), set Valid False and
 771       --  set Exponent to 0. Otherwise, set Valid True, and store the exponent
 772       --  of the scientific notation representation of Var in Exponent. The
 773       --  exponent can also be defined as:
 774       --  - If Var = 0, 0.
 775       --  - Otherwise, Floor (Log_10 (Abs (Var))).
 776
 777       procedure Format_With_Notation
 778         (Var : Flt;
 779          Nota : Notation;
 780          Aft : Text_IO.Field;
 781          Buffer : out String);
 782       --  Fill buffer with the formatted value of Var following the notation
 783       --  specified through Nota.
 784
 785       procedure Handle_G_Specifier
 786         (Buffer          : out String;
 787          First_Non_Blank : out Positive;
 788          Aft             : Text_IO.Field);
 789       --  Fill Buffer with the formatted value of Var according to the rules of
 790       --  the "%g" specifier. Buffer is right-justified and padded with blanks.
 791
 792       ----------------------
 793       -- Compute_Exponent --
 794       ----------------------
 795
 796       procedure Compute_Exponent
 797         (Var      : Flt;
 798          Valid    : out Boolean;
 799          Exponent : out Integer)
 800       is
 801          --  The way the exponent is computed is convoluted. It is not possible
 802          --  to use the logarithm in base 10 of Var and floor it, because the
 803          --  math functions for this are not available for fixed point types.
 804          --  Instead, use the generic Put procedure to produce a scientific
 805          --  representation of Var, and parse the exponent part of that back
 806          --  into an Integer.
 807          Scientific_Rep : String (1 .. 50);
 808
 809          E_Position : Natural;
 810       begin
 811          Put (Scientific_Rep, Var, Aft => 1, Exp => 1);
 812
 813          E_Position := Ada.Strings.Fixed.Index (Scientific_Rep, "E");
 814
 815          if E_Position = 0 then
 816             Valid    := False;
 817             Exponent := 0;
 818          else
 819             Valid    := True;
 820             Exponent :=
 821               Integer'Value
 822                 (Scientific_Rep (E_Position + 1 .. Scientific_Rep'Last));
 823          end if;
 824       end Compute_Exponent;
 825
 826       --------------------------
 827       -- Format_With_Notation --
 828       --------------------------
 829
 830       procedure Format_With_Notation
 831         (Var : Flt;
 832          Nota : Notation;
 833          Aft : Text_IO.Field;
 834          Buffer : out String)
 835       is
 836          Exp : constant Text_IO.Field :=
 837            (case Nota is when Decimal => 0, when Scientific => 3);
 838       begin
 839          Put (Buffer, Var, Aft, Exp);
 840       end Format_With_Notation;
 841
 842       ------------------------
 843       -- Handle_G_Specifier --
 844       ------------------------
 845
 846       procedure Handle_G_Specifier
 847         (Buffer          : out String;
 848          First_Non_Blank : out Positive;
 849          Aft             : Text_IO.Field)
 850       is
 851          --  There is nothing that is directly equivalent to the "%g" specifier
 852          --  in the standard Ada functionality provided by Ada.Text_IO. The
 853          --  procedure Put will still be used, but significant postprocessing
 854          --  will be performed on the output of that procedure.
 855
 856          --  The following code is intended to match the behavior of C's printf
 857          --  for %g, as described by paragraph "7.21.6.1 The fprintf function"
 858          --  of the C language specification.
 859
 860          --  As explained in the C specification, we're going to have to make a
 861          --  choice between decimal notation and scientific notation. One of
 862          --  the elements we need in order to make that choice is the value of
 863          --  the exponent in the decimal representation of Var. We will store
 864          --  that value in Exponent.
 865          Exponent : Integer;
 866          Valid    : Boolean;
 867
 868          Nota : Notation;
 869
 870          --  The value of the formal Aft comes from the precision specifier in
 871          --  the format string. For %g, the precision specifier corresponds to
 872          --  the number of significant figures desired, whereas the formal Aft
 873          --  in Put corresponds to the number of digits after the point.
 874          --  Effective_Aft is what will be passed to Put as Aft in order to
 875          --  respect the semantics of %g.
 876          Effective_Aft : Text_IO.Field;
 877
 878          Textual_Rep : String (Buffer'Range);
 879       begin
 880          Compute_Exponent (Var, Valid, Exponent);
 881
 882          Determine_Notation_And_Aft
 883            (Exponent, Aft, Nota, Effective_Aft);
 884
 885          Format_With_Notation (Var, Nota, Effective_Aft, Textual_Rep);
 886
 887          First_Non_Blank := Strings.Fixed.Index_Non_Blank (Textual_Rep);
 888
 889          if not Valid then
 890             null;
 891          elsif Effective_Aft = 0 then
 892             --  Special case: it is possible at this point that Effective_Aft
 893             --  is zero. But when Put is passed zero through Aft, it still
 894             --  outputs one digit after the point. See the reference manual,
 895             --  A.10.9.25.
 896
 897             Remove_Extraneous_Decimal_Digit (Textual_Rep, First_Non_Blank);
 898          else
 899             Trim_Fractional_Part
 900               (Textual_Rep, First_Non_Blank);
 901          end if;
 902
 903          Buffer := Textual_Rep;
 904       end Handle_G_Specifier;
 905
 906       --  Local variables
 907
 908       F      : F_Data;
 909       Buffer : String (1 .. 50);
 910       S, E   : Positive := 1;
 911       Start  : Positive;
 912       Aft    : Text_IO.Field;
 913
 914    --  Start of processing for P_Flt_Format
 915
 916    begin
 917       Next_Format (Format, F, Start);
 918
 919       if F.Value_Needed /= Format.D.Stored_Value then
 920          Raise_Wrong_Format (Format);
 921       end if;
 922       Format.D.Stored_Value := 0;
 923
 924       if F.Precision = Unset then
 925          Aft := 6;
 926       else
 927          Aft := F.Precision;
 928       end if;
 929
 930       case F.Kind is
 931          when Decimal_Float =>
 932
 933             Put (Buffer, Var, Aft, Exp => 0);
 934             S := Strings.Fixed.Index_Non_Blank (Buffer);
 935             E := Buffer'Last;
 936
 937          when Decimal_Scientific_Float
 938             | Decimal_Scientific_Float_Up
 939          =>
 940             Put (Buffer, Var, Aft, Exp => 3);
 941             S := Strings.Fixed.Index_Non_Blank (Buffer);
 942             E := Buffer'Last;
 943
 944             if F.Kind = Decimal_Scientific_Float then
 945                Buffer (S .. E) :=
 946                  Characters.Handling.To_Lower (Buffer (S .. E));
 947             end if;
 948
 949          when G_Specifier
 950             | G_Specifier_Up
 951          =>
 952             Handle_G_Specifier (Buffer, S, Aft);
 953             E := Buffer'Last;
 954
 955             if F.Kind = G_Specifier then
 956                Buffer (S .. E) :=
 957                  Characters.Handling.To_Lower (Buffer (S .. E));
 958             end if;
 959
 960          when others =>
 961             Raise_Wrong_Format (Format);
 962       end case;
 963
 964       Append (Format.D.Result,
 965         Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length));
 966
 967       return Format;
 968    end P_Flt_Format;
 969
 970    ------------------
 971    -- P_Int_Format --
 972    ------------------
 973
 974    function P_Int_Format
 975      (Format : Formatted_String;
 976       Var    : Int) return Formatted_String
 977    is
 978       function Handle_Precision return Boolean;
 979       --  Return True if nothing else to do
 980
 981       F      : F_Data;
 982       Buffer : String (1 .. 50);
 983       S, E   : Positive := 1;
 984       Len    : Natural := 0;
 985       Start  : Positive;
 986
 987       ----------------------
 988       -- Handle_Precision --
 989       ----------------------
 990
 991       function Handle_Precision return Boolean is
 992       begin
 993          if F.Precision = 0 and then Sign (Var) = Zero then
 994             return True;
 995
 996          elsif F.Precision = Natural'Last then
 997             null;
 998
 999          elsif F.Precision > E - S + 1 then
1000             Len := F.Precision - (E - S + 1);
1001             Buffer (S - Len .. S - 1) := [others => '0'];
1002             S := S - Len;
1003          end if;
1004
1005          return False;
1006       end Handle_Precision;
1007
1008    --  Start of processing for P_Int_Format
1009
1010    begin
1011       Next_Format (Format, F, Start);
1012
1013       if Format.D.Stored_Value < F.Value_Needed then
1014          Format.D.Stored_Value := Format.D.Stored_Value + 1;
1015          Format.D.Stack (Format.D.Stored_Value) := To_Integer (Var);
1016          Format.D.Index := Start;
1017          return Format;
1018       end if;
1019       Format.D.Stored_Value := 0;
1020
1021       case F.Kind is
1022          when Unsigned_Octal =>
1023             if Sign (Var) = Neg then
1024                Raise_Wrong_Format (Format);
1025             end if;
1026
1027             Put (Buffer, Var, Base => 8);
1028             S := Strings.Fixed.Index (Buffer, "8#") + 2;
1029             E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
1030
1031             if Handle_Precision then
1032                return Format;
1033             end if;
1034
1035             case F.Base is
1036                when None      => null;
1037                when C_Style   => Len := 1;
1038                when Ada_Style => Len := 3;
1039             end case;
1040
1041          when Unsigned_Hexadecimal_Int =>
1042             if Sign (Var) = Neg then
1043                Raise_Wrong_Format (Format);
1044             end if;
1045
1046             Put (Buffer, Var, Base => 16);
1047             S := Strings.Fixed.Index (Buffer, "16#") + 3;
1048             E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
1049             Buffer (S .. E) := Characters.Handling.To_Lower (Buffer (S .. E));
1050
1051             if Handle_Precision then
1052                return Format;
1053             end if;
1054
1055             case F.Base is
1056                when None      => null;
1057                when C_Style   => Len := 2;
1058                when Ada_Style => Len := 4;
1059             end case;
1060
1061          when Unsigned_Hexadecimal_Int_Up =>
1062             if Sign (Var) = Neg then
1063                Raise_Wrong_Format (Format);
1064             end if;
1065
1066             Put (Buffer, Var, Base => 16);
1067             S := Strings.Fixed.Index (Buffer, "16#") + 3;
1068             E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
1069
1070             if Handle_Precision then
1071                return Format;
1072             end if;
1073
1074             case F.Base is
1075                when None      => null;
1076                when C_Style   => Len := 2;
1077                when Ada_Style => Len := 4;
1078             end case;
1079
1080          when Unsigned_Decimal_Int =>
1081             if Sign (Var) = Neg then
1082                Raise_Wrong_Format (Format);
1083             end if;
1084
1085             Put (Buffer, Var, Base => 10);
1086             S := Strings.Fixed.Index_Non_Blank (Buffer);
1087             E := Buffer'Last;
1088
1089             if Handle_Precision then
1090                return Format;
1091             end if;
1092
1093          when Decimal_Int =>
1094             Put (Buffer, Var, Base => 10);
1095             S := Strings.Fixed.Index_Non_Blank (Buffer);
1096             E := Buffer'Last;
1097
1098             if Handle_Precision then
1099                return Format;
1100             end if;
1101
1102          when Char =>
1103             S := Buffer'First;
1104             E := Buffer'First;
1105             Buffer (S) := Character'Val (To_Integer (Var));
1106
1107             if Handle_Precision then
1108                return Format;
1109             end if;
1110
1111          when others =>
1112             Raise_Wrong_Format (Format);
1113       end case;
1114
1115       --  Then add base if needed
1116
1117       declare
1118          N : String := Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len);
1119          P : constant Positive :=
1120                (if F.Left_Justify
1121                 then N'First
1122                 else Natural'Max (Strings.Fixed.Index_Non_Blank (N) - 1,
1123                                   N'First));
1124       begin
1125          case F.Base is
1126             when None =>
1127                null;
1128
1129             when C_Style =>
1130                case F.Kind is
1131                   when Unsigned_Octal =>
1132                      N (P) := 'O';
1133
1134                   when Unsigned_Hexadecimal_Int =>
1135                      if F.Left_Justify then
1136                         N (P .. P + 1) := "Ox";
1137                      else
1138                         N (P - 1 .. P) := "0x";
1139                      end if;
1140
1141                   when Unsigned_Hexadecimal_Int_Up =>
1142                      if F.Left_Justify then
1143                         N (P .. P + 1) := "OX";
1144                      else
1145                         N (P - 1 .. P) := "0X";
1146                      end if;
1147
1148                   when others =>
1149                      null;
1150                end case;
1151
1152             when Ada_Style =>
1153                case F.Kind is
1154                   when Unsigned_Octal =>
1155                      if F.Left_Justify then
1156                         N (N'First + 2 .. N'Last) := N (N'First .. N'Last - 2);
1157                      else
1158                         N (P .. N'Last - 1) := N (P + 1 .. N'Last);
1159                      end if;
1160
1161                      N (N'First .. N'First + 1) := "8#";
1162                      N (N'Last) := '#';
1163
1164                   when Unsigned_Hexadecimal_Int
1165                      | Unsigned_Hexadecimal_Int_Up
1166                   =>
1167                      if F.Left_Justify then
1168                         N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3);
1169                      else
1170                         N (P .. N'Last - 1) := N (P + 1 .. N'Last);
1171                      end if;
1172
1173                      N (N'First .. N'First + 2) := "16#";
1174                      N (N'Last) := '#';
1175
1176                   when others =>
1177                      null;
1178                end case;
1179          end case;
1180
1181          Append (Format.D.Result, N);
1182       end;
1183
1184       return Format;
1185    end P_Int_Format;
1186
1187    ------------------------
1188    -- Raise_Wrong_Format --
1189    ------------------------
1190
1191    procedure Raise_Wrong_Format (Format : Formatted_String) is
1192    begin
1193       raise Format_Error with
1194         "wrong format specified for parameter"
1195         & Positive'Image (Format.D.Current);
1196    end Raise_Wrong_Format;
1197
1198    -------------------------------------
1199    -- Remove_Extraneous_Decimal_Digit --
1200    -------------------------------------
1201
1202    procedure Remove_Extraneous_Decimal_Digit
1203      (Textual_Rep     : in out String;
1204       First_Non_Blank : in out Positive)
1205    is
1206       Point_Position : constant Positive := Ada.Strings.Fixed.Index
1207         (Textual_Rep,
1208          ".",
1209          First_Non_Blank);
1210
1211       Integral_Part_Needs_Increment : constant Boolean :=
1212         Textual_Rep (Point_Position + 1) in '5' .. '9';
1213    begin
1214       Ada.Strings.Fixed.Delete
1215         (Textual_Rep,
1216          Point_Position,
1217          Point_Position + 1,
1218          Ada.Strings.Right);
1219
1220       First_Non_Blank := First_Non_Blank + 2;
1221
1222       if Integral_Part_Needs_Increment then
1223          Increment_Integral_Part
1224            (Textual_Rep,
1225             First_Non_Blank,
1226             Last_Digit_Position => Point_Position + 1);
1227       end if;
1228    end Remove_Extraneous_Decimal_Digit;
1229
1230    --------------------------
1231    -- Trim_Fractional_Part --
1232    --------------------------
1233
1234    procedure Trim_Fractional_Part
1235      (Textual_Rep     : in out String;
1236       First_Non_Blank : in out Positive)
1237    is
1238       Cursor : Positive :=
1239         Ada.Strings.Fixed.Index (Textual_Rep, ".", First_Non_Blank);
1240
1241       First_To_Trim : Positive;
1242       Fractional_Part_Last : Positive;
1243    begin
1244       while Cursor + 1 <= Textual_Rep'Last
1245         and then Textual_Rep (Cursor + 1) in '0' .. '9' loop
1246          Cursor := Cursor + 1;
1247       end loop;
1248
1249       Fractional_Part_Last := Cursor;
1250
1251       while Textual_Rep (Cursor) = '0' loop
1252          Cursor := Cursor - 1;
1253       end loop;
1254
1255       if Textual_Rep (Cursor) = '.' then
1256          Cursor := Cursor - 1;
1257       end if;
1258
1259       First_To_Trim := Cursor + 1;
1260
1261       Ada.Strings.Fixed.Delete
1262         (Textual_Rep, First_To_Trim, Fractional_Part_Last, Ada.Strings.Right);
1263
1264       First_Non_Blank :=
1265         First_Non_Blank + (Fractional_Part_Last - First_To_Trim + 1);
1266    end Trim_Fractional_Part;
1267
1268 end GNAT.Formatted_String;