gcc/ada/prj-util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P R J . U T I L                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2010, 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Ada.Unchecked_Deallocation;
  27
  28 with GNAT.Case_Util; use GNAT.Case_Util;
  29
  30 with Osint;    use Osint;
  31 with Output;   use Output;
  32 with Prj.Com;
  33 with Snames;   use Snames;
  34 with Targparm; use Targparm;
  35
  36 package body Prj.Util is
  37
  38    procedure Free is new Ada.Unchecked_Deallocation
  39      (Text_File_Data, Text_File);
  40
  41    -----------
  42    -- Close --
  43    -----------
  44
  45    procedure Close (File : in out Text_File) is
  46    begin
  47       if File = null then
  48          Prj.Com.Fail ("Close attempted on an invalid Text_File");
  49       end if;
  50
  51       --  Close file, no need to test status, since this is a file that we
  52       --  read, and the file was read successfully before we closed it.
  53
  54       Close (File.FD);
  55       Free (File);
  56    end Close;
  57
  58    ---------------
  59    -- Duplicate --
  60    ---------------
  61
  62    procedure Duplicate
  63      (This    : in out Name_List_Index;
  64       In_Tree : Project_Tree_Ref)
  65    is
  66       Old_Current : Name_List_Index;
  67       New_Current : Name_List_Index;
  68
  69    begin
  70       if This /= No_Name_List then
  71          Old_Current := This;
  72          Name_List_Table.Increment_Last (In_Tree.Name_Lists);
  73          New_Current := Name_List_Table.Last (In_Tree.Name_Lists);
  74          This := New_Current;
  75          In_Tree.Name_Lists.Table (New_Current) :=
  76            (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
  77
  78          loop
  79             Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next;
  80             exit when Old_Current = No_Name_List;
  81             In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1;
  82             Name_List_Table.Increment_Last (In_Tree.Name_Lists);
  83             New_Current := New_Current + 1;
  84             In_Tree.Name_Lists.Table (New_Current) :=
  85               (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
  86          end loop;
  87       end if;
  88    end Duplicate;
  89
  90    -----------------
  91    -- End_Of_File --
  92    -----------------
  93
  94    function End_Of_File (File : Text_File) return Boolean is
  95    begin
  96       if File = null then
  97          Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
  98       end if;
  99
 100       return File.End_Of_File_Reached;
 101    end End_Of_File;
 102
 103    -------------------
 104    -- Executable_Of --
 105    -------------------
 106
 107    function Executable_Of
 108      (Project  : Project_Id;
 109       In_Tree  : Project_Tree_Ref;
 110       Main     : File_Name_Type;
 111       Index    : Int;
 112       Ada_Main : Boolean := True;
 113       Language : String := "";
 114       Include_Suffix : Boolean := True) return File_Name_Type
 115    is
 116       pragma Assert (Project /= No_Project);
 117
 118       The_Packages : constant Package_Id := Project.Decl.Packages;
 119
 120       Builder_Package : constant Prj.Package_Id :=
 121                           Prj.Util.Value_Of
 122                             (Name        => Name_Builder,
 123                              In_Packages => The_Packages,
 124                              In_Tree     => In_Tree);
 125
 126       Executable : Variable_Value :=
 127                      Prj.Util.Value_Of
 128                        (Name                    => Name_Id (Main),
 129                         Index                   => Index,
 130                         Attribute_Or_Array_Name => Name_Executable,
 131                         In_Package              => Builder_Package,
 132                         In_Tree                 => In_Tree);
 133
 134       Lang   : Language_Ptr;
 135
 136       Spec_Suffix : Name_Id := No_Name;
 137       Body_Suffix : Name_Id := No_Name;
 138
 139       Spec_Suffix_Length : Natural := 0;
 140       Body_Suffix_Length : Natural := 0;
 141
 142       procedure Get_Suffixes
 143         (B_Suffix : File_Name_Type;
 144          S_Suffix : File_Name_Type);
 145       --  Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
 146
 147       function Add_Suffix (File : File_Name_Type) return File_Name_Type;
 148       --  Return the name of the executable, based on File, and adding the
 149       --  executable suffix if needed
 150
 151       ------------------
 152       -- Get_Suffixes --
 153       ------------------
 154
 155       procedure Get_Suffixes
 156         (B_Suffix : File_Name_Type;
 157          S_Suffix : File_Name_Type)
 158       is
 159       begin
 160          if B_Suffix /= No_File then
 161             Body_Suffix := Name_Id (B_Suffix);
 162             Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
 163          end if;
 164
 165          if S_Suffix /= No_File then
 166             Spec_Suffix := Name_Id (S_Suffix);
 167             Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
 168          end if;
 169       end Get_Suffixes;
 170
 171       ----------------
 172       -- Add_Suffix --
 173       ----------------
 174
 175       function Add_Suffix (File : File_Name_Type) return File_Name_Type is
 176          Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
 177          Result     : File_Name_Type;
 178          Suffix_From_Project : Variable_Value;
 179       begin
 180          if Include_Suffix then
 181             if Project.Config.Executable_Suffix /= No_Name then
 182                Executable_Extension_On_Target :=
 183                  Project.Config.Executable_Suffix;
 184             end if;
 185
 186             Result :=  Executable_Name (File);
 187             Executable_Extension_On_Target := Saved_EEOT;
 188             return Result;
 189
 190          elsif Builder_Package /= No_Package then
 191
 192             --  If the suffix is specified in the project itself, as opposed to
 193             --  the config file, it needs to be taken into account. However,
 194             --  when the project was processed, in both cases the suffix was
 195             --  stored in Project.Config, so get it from the project again.
 196
 197             Suffix_From_Project :=
 198               Prj.Util.Value_Of
 199                 (Variable_Name => Name_Executable_Suffix,
 200                  In_Variables  =>
 201                    In_Tree.Packages.Table (Builder_Package).Decl.Attributes,
 202                  In_Tree       => In_Tree);
 203
 204             if Suffix_From_Project /= Nil_Variable_Value
 205               and then Suffix_From_Project.Value /= No_Name
 206             then
 207                Executable_Extension_On_Target := Suffix_From_Project.Value;
 208                Result :=  Executable_Name (File);
 209                Executable_Extension_On_Target := Saved_EEOT;
 210                return Result;
 211             end if;
 212          end if;
 213
 214          return File;
 215       end Add_Suffix;
 216
 217    --  Start of processing for Executable_Of
 218
 219    begin
 220       if Ada_Main then
 221          Lang := Get_Language_From_Name (Project, "ada");
 222       elsif Language /= "" then
 223          Lang := Get_Language_From_Name (Project, Language);
 224       end if;
 225
 226       if Lang /= null then
 227          Get_Suffixes
 228            (B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
 229             S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
 230       end if;
 231
 232       if Builder_Package /= No_Package then
 233          if Executable = Nil_Variable_Value and then Ada_Main then
 234             Get_Name_String (Main);
 235
 236             --  Try as index the name minus the implementation suffix or minus
 237             --  the specification suffix.
 238
 239             declare
 240                Name : constant String (1 .. Name_Len) :=
 241                         Name_Buffer (1 .. Name_Len);
 242                Last : Positive := Name_Len;
 243
 244                Truncated : Boolean := False;
 245
 246             begin
 247                if Body_Suffix /= No_Name
 248                  and then Last > Natural (Length_Of_Name (Body_Suffix))
 249                  and then Name (Last - Body_Suffix_Length + 1 .. Last) =
 250                             Get_Name_String (Body_Suffix)
 251                then
 252                   Truncated := True;
 253                   Last := Last - Body_Suffix_Length;
 254                end if;
 255
 256                if Spec_Suffix /= No_Name
 257                  and then not Truncated
 258                  and then Last > Spec_Suffix_Length
 259                  and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
 260                             Get_Name_String (Spec_Suffix)
 261                then
 262                   Truncated := True;
 263                   Last := Last - Spec_Suffix_Length;
 264                end if;
 265
 266                if Truncated then
 267                   Name_Len := Last;
 268                   Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
 269                   Executable :=
 270                     Prj.Util.Value_Of
 271                       (Name                    => Name_Find,
 272                        Index                   => 0,
 273                        Attribute_Or_Array_Name => Name_Executable,
 274                        In_Package              => Builder_Package,
 275                        In_Tree                 => In_Tree);
 276                end if;
 277             end;
 278          end if;
 279
 280          --  If we have found an Executable attribute, return its value,
 281          --  possibly suffixed by the executable suffix.
 282
 283          if Executable /= Nil_Variable_Value
 284            and then Executable.Value /= No_Name
 285            and then Length_Of_Name (Executable.Value) /= 0
 286          then
 287             return Add_Suffix (File_Name_Type (Executable.Value));
 288          end if;
 289       end if;
 290
 291       Get_Name_String (Main);
 292
 293       --  If there is a body suffix or a spec suffix, remove this suffix,
 294       --  otherwise remove any suffix ('.' followed by other characters), if
 295       --  there is one.
 296
 297       if Body_Suffix /= No_Name
 298          and then Name_Len > Body_Suffix_Length
 299          and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =
 300                     Get_Name_String (Body_Suffix)
 301       then
 302          --  Found the body termination, remove it
 303
 304          Name_Len := Name_Len - Body_Suffix_Length;
 305
 306       elsif Spec_Suffix /= No_Name
 307             and then Name_Len > Spec_Suffix_Length
 308             and then
 309               Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
 310                 Get_Name_String (Spec_Suffix)
 311       then
 312          --  Found the spec termination, remove it
 313
 314          Name_Len := Name_Len - Spec_Suffix_Length;
 315
 316       else
 317          --  Remove any suffix, if there is one
 318
 319          Get_Name_String (Strip_Suffix (Main));
 320       end if;
 321
 322       return Add_Suffix (Name_Find);
 323    end Executable_Of;
 324
 325    --------------
 326    -- Get_Line --
 327    --------------
 328
 329    procedure Get_Line
 330      (File : Text_File;
 331       Line : out String;
 332       Last : out Natural)
 333    is
 334       C : Character;
 335
 336       procedure Advance;
 337
 338       -------------
 339       -- Advance --
 340       -------------
 341
 342       procedure Advance is
 343       begin
 344          if File.Cursor = File.Buffer_Len then
 345             File.Buffer_Len :=
 346               Read
 347                (FD => File.FD,
 348                 A  => File.Buffer'Address,
 349                 N  => File.Buffer'Length);
 350
 351             if File.Buffer_Len = 0 then
 352                File.End_Of_File_Reached := True;
 353                return;
 354             else
 355                File.Cursor := 1;
 356             end if;
 357
 358          else
 359             File.Cursor := File.Cursor + 1;
 360          end if;
 361       end Advance;
 362
 363    --  Start of processing for Get_Line
 364
 365    begin
 366       if File = null then
 367          Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
 368       end if;
 369
 370       Last := Line'First - 1;
 371
 372       if not File.End_Of_File_Reached then
 373          loop
 374             C := File.Buffer (File.Cursor);
 375             exit when C = ASCII.CR or else C = ASCII.LF;
 376             Last := Last + 1;
 377             Line (Last) := C;
 378             Advance;
 379
 380             if File.End_Of_File_Reached then
 381                return;
 382             end if;
 383
 384             exit when Last = Line'Last;
 385          end loop;
 386
 387          if C = ASCII.CR or else C = ASCII.LF then
 388             Advance;
 389
 390             if File.End_Of_File_Reached then
 391                return;
 392             end if;
 393          end if;
 394
 395          if C = ASCII.CR
 396            and then File.Buffer (File.Cursor) = ASCII.LF
 397          then
 398             Advance;
 399          end if;
 400       end if;
 401    end Get_Line;
 402
 403    --------------
 404    -- Is_Valid --
 405    --------------
 406
 407    function Is_Valid (File : Text_File) return Boolean is
 408    begin
 409       return File /= null;
 410    end Is_Valid;
 411
 412    ----------
 413    -- Open --
 414    ----------
 415
 416    procedure Open (File : out Text_File; Name : String) is
 417       FD        : File_Descriptor;
 418       File_Name : String (1 .. Name'Length + 1);
 419
 420    begin
 421       File_Name (1 .. Name'Length) := Name;
 422       File_Name (File_Name'Last) := ASCII.NUL;
 423       FD := Open_Read (Name => File_Name'Address,
 424                        Fmode => GNAT.OS_Lib.Text);
 425
 426       if FD = Invalid_FD then
 427          File := null;
 428
 429       else
 430          File := new Text_File_Data;
 431          File.FD := FD;
 432          File.Buffer_Len :=
 433            Read (FD => FD,
 434                  A  => File.Buffer'Address,
 435                  N  => File.Buffer'Length);
 436
 437          if File.Buffer_Len = 0 then
 438             File.End_Of_File_Reached := True;
 439          else
 440             File.Cursor := 1;
 441          end if;
 442       end if;
 443    end Open;
 444
 445    ---------
 446    -- Put --
 447    ---------
 448
 449    procedure Put
 450      (Into_List  : in out Name_List_Index;
 451       From_List  : String_List_Id;
 452       In_Tree    : Project_Tree_Ref;
 453       Lower_Case : Boolean := False)
 454    is
 455       Current_Name : Name_List_Index;
 456       List         : String_List_Id;
 457       Element      : String_Element;
 458       Last         : Name_List_Index :=
 459                        Name_List_Table.Last (In_Tree.Name_Lists);
 460       Value        : Name_Id;
 461
 462    begin
 463       Current_Name := Into_List;
 464       while Current_Name /= No_Name_List
 465         and then In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List
 466       loop
 467          Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next;
 468       end loop;
 469
 470       List := From_List;
 471       while List /= Nil_String loop
 472          Element := In_Tree.String_Elements.Table (List);
 473          Value := Element.Value;
 474
 475          if Lower_Case then
 476             Get_Name_String (Value);
 477             To_Lower (Name_Buffer (1 .. Name_Len));
 478             Value := Name_Find;
 479          end if;
 480
 481          Name_List_Table.Append
 482            (In_Tree.Name_Lists, (Name => Value, Next => No_Name_List));
 483
 484          Last := Last + 1;
 485
 486          if Current_Name = No_Name_List then
 487             Into_List := Last;
 488
 489          else
 490             In_Tree.Name_Lists.Table (Current_Name).Next := Last;
 491          end if;
 492
 493          Current_Name := Last;
 494
 495          List := Element.Next;
 496       end loop;
 497    end Put;
 498
 499    --------------
 500    -- Value_Of --
 501    --------------
 502
 503    function Value_Of
 504      (Variable : Variable_Value;
 505       Default  : String) return String
 506    is
 507    begin
 508       if Variable.Kind /= Single
 509         or else Variable.Default
 510         or else Variable.Value = No_Name
 511       then
 512          return Default;
 513       else
 514          return Get_Name_String (Variable.Value);
 515       end if;
 516    end Value_Of;
 517
 518    function Value_Of
 519      (Index    : Name_Id;
 520       In_Array : Array_Element_Id;
 521       In_Tree  : Project_Tree_Ref) return Name_Id
 522    is
 523       Current    : Array_Element_Id;
 524       Element    : Array_Element;
 525       Real_Index : Name_Id := Index;
 526
 527    begin
 528       Current := In_Array;
 529
 530       if Current = No_Array_Element then
 531          return No_Name;
 532       end if;
 533
 534       Element := In_Tree.Array_Elements.Table (Current);
 535
 536       if not Element.Index_Case_Sensitive then
 537          Get_Name_String (Index);
 538          To_Lower (Name_Buffer (1 .. Name_Len));
 539          Real_Index := Name_Find;
 540       end if;
 541
 542       while Current /= No_Array_Element loop
 543          Element := In_Tree.Array_Elements.Table (Current);
 544
 545          if Real_Index = Element.Index then
 546             exit when Element.Value.Kind /= Single;
 547             exit when Element.Value.Value = Empty_String;
 548             return Element.Value.Value;
 549          else
 550             Current := Element.Next;
 551          end if;
 552       end loop;
 553
 554       return No_Name;
 555    end Value_Of;
 556
 557    function Value_Of
 558      (Index                  : Name_Id;
 559       Src_Index              : Int := 0;
 560       In_Array               : Array_Element_Id;
 561       In_Tree                : Project_Tree_Ref;
 562       Force_Lower_Case_Index : Boolean := False) return Variable_Value
 563    is
 564       Current      : Array_Element_Id;
 565       Element      : Array_Element;
 566       Real_Index_1 : Name_Id;
 567       Real_Index_2 : Name_Id;
 568
 569    begin
 570       Current := In_Array;
 571
 572       if Current = No_Array_Element then
 573          return Nil_Variable_Value;
 574       end if;
 575
 576       Element := In_Tree.Array_Elements.Table (Current);
 577
 578       Real_Index_1 := Index;
 579
 580       if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
 581          if Index /= All_Other_Names then
 582             Get_Name_String (Index);
 583             To_Lower (Name_Buffer (1 .. Name_Len));
 584             Real_Index_1 := Name_Find;
 585          end if;
 586       end if;
 587
 588       while Current /= No_Array_Element loop
 589          Element := In_Tree.Array_Elements.Table (Current);
 590          Real_Index_2 := Element.Index;
 591
 592          if not Element.Index_Case_Sensitive
 593            or else Force_Lower_Case_Index
 594          then
 595             if Element.Index /= All_Other_Names then
 596                Get_Name_String (Element.Index);
 597                To_Lower (Name_Buffer (1 .. Name_Len));
 598                Real_Index_2 := Name_Find;
 599             end if;
 600          end if;
 601
 602          if Real_Index_1 = Real_Index_2 and then
 603            Src_Index = Element.Src_Index
 604          then
 605             return Element.Value;
 606          else
 607             Current := Element.Next;
 608          end if;
 609       end loop;
 610
 611       return Nil_Variable_Value;
 612    end Value_Of;
 613
 614    function Value_Of
 615      (Name                    : Name_Id;
 616       Index                   : Int := 0;
 617       Attribute_Or_Array_Name : Name_Id;
 618       In_Package              : Package_Id;
 619       In_Tree                 : Project_Tree_Ref;
 620       Force_Lower_Case_Index  : Boolean := False) return Variable_Value
 621    is
 622       The_Array     : Array_Element_Id;
 623       The_Attribute : Variable_Value := Nil_Variable_Value;
 624
 625    begin
 626       if In_Package /= No_Package then
 627
 628          --  First, look if there is an array element that fits
 629
 630          The_Array :=
 631            Value_Of
 632              (Name      => Attribute_Or_Array_Name,
 633               In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
 634               In_Tree   => In_Tree);
 635          The_Attribute :=
 636            Value_Of
 637              (Index                  => Name,
 638               Src_Index              => Index,
 639               In_Array               => The_Array,
 640               In_Tree                => In_Tree,
 641               Force_Lower_Case_Index => Force_Lower_Case_Index);
 642
 643          --  If there is no array element, look for a variable
 644
 645          if The_Attribute = Nil_Variable_Value then
 646             The_Attribute :=
 647               Value_Of
 648                 (Variable_Name => Attribute_Or_Array_Name,
 649                  In_Variables  => In_Tree.Packages.Table
 650                                     (In_Package).Decl.Attributes,
 651                  In_Tree       => In_Tree);
 652          end if;
 653       end if;
 654
 655       return The_Attribute;
 656    end Value_Of;
 657
 658    function Value_Of
 659      (Index     : Name_Id;
 660       In_Array  : Name_Id;
 661       In_Arrays : Array_Id;
 662       In_Tree   : Project_Tree_Ref) return Name_Id
 663    is
 664       Current   : Array_Id;
 665       The_Array : Array_Data;
 666
 667    begin
 668       Current := In_Arrays;
 669       while Current /= No_Array loop
 670          The_Array := In_Tree.Arrays.Table (Current);
 671          if The_Array.Name = In_Array then
 672             return Value_Of
 673               (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
 674          else
 675             Current := The_Array.Next;
 676          end if;
 677       end loop;
 678
 679       return No_Name;
 680    end Value_Of;
 681
 682    function Value_Of
 683      (Name      : Name_Id;
 684       In_Arrays : Array_Id;
 685       In_Tree   : Project_Tree_Ref) return Array_Element_Id
 686    is
 687       Current   : Array_Id;
 688       The_Array : Array_Data;
 689
 690    begin
 691       Current := In_Arrays;
 692       while Current /= No_Array loop
 693          The_Array := In_Tree.Arrays.Table (Current);
 694
 695          if The_Array.Name = Name then
 696             return The_Array.Value;
 697          else
 698             Current := The_Array.Next;
 699          end if;
 700       end loop;
 701
 702       return No_Array_Element;
 703    end Value_Of;
 704
 705    function Value_Of
 706      (Name        : Name_Id;
 707       In_Packages : Package_Id;
 708       In_Tree     : Project_Tree_Ref) return Package_Id
 709    is
 710       Current     : Package_Id;
 711       The_Package : Package_Element;
 712
 713    begin
 714       Current := In_Packages;
 715       while Current /= No_Package loop
 716          The_Package := In_Tree.Packages.Table (Current);
 717          exit when The_Package.Name /= No_Name
 718            and then The_Package.Name = Name;
 719          Current := The_Package.Next;
 720       end loop;
 721
 722       return Current;
 723    end Value_Of;
 724
 725    function Value_Of
 726      (Variable_Name : Name_Id;
 727       In_Variables  : Variable_Id;
 728       In_Tree       : Project_Tree_Ref) return Variable_Value
 729    is
 730       Current      : Variable_Id;
 731       The_Variable : Variable;
 732
 733    begin
 734       Current := In_Variables;
 735       while Current /= No_Variable loop
 736          The_Variable :=
 737            In_Tree.Variable_Elements.Table (Current);
 738
 739          if Variable_Name = The_Variable.Name then
 740             return The_Variable.Value;
 741          else
 742             Current := The_Variable.Next;
 743          end if;
 744       end loop;
 745
 746       return Nil_Variable_Value;
 747    end Value_Of;
 748
 749    ---------------
 750    -- Write_Str --
 751    ---------------
 752
 753    procedure Write_Str
 754      (S          : String;
 755       Max_Length : Positive;
 756       Separator  : Character)
 757    is
 758       First : Positive := S'First;
 759       Last  : Natural  := S'Last;
 760
 761    begin
 762       --  Nothing to do for empty strings
 763
 764       if S'Length > 0 then
 765
 766          --  Start on a new line if current line is already longer than
 767          --  Max_Length.
 768
 769          if Positive (Column) >= Max_Length then
 770             Write_Eol;
 771          end if;
 772
 773          --  If length of remainder is longer than Max_Length, we need to
 774          --  cut the remainder in several lines.
 775
 776          while Positive (Column) + S'Last - First > Max_Length loop
 777
 778             --  Try the maximum length possible
 779
 780             Last := First + Max_Length - Positive (Column);
 781
 782             --  Look for last Separator in the line
 783
 784             while Last >= First and then S (Last) /= Separator loop
 785                Last := Last - 1;
 786             end loop;
 787
 788             --  If we do not find a separator, we output the maximum length
 789             --  possible.
 790
 791             if Last < First then
 792                Last := First + Max_Length - Positive (Column);
 793             end if;
 794
 795             Write_Line (S (First .. Last));
 796
 797             --  Set the beginning of the new remainder
 798
 799             First := Last + 1;
 800          end loop;
 801
 802          --  What is left goes to the buffer, without EOL
 803
 804          Write_Str (S (First .. S'Last));
 805       end if;
 806    end Write_Str;
 807 end Prj.Util;