{
Copyright (C) 1997-99 Free Software Foundation, Inc.

Authors: Frank Heckenbach <frank@pascal.gnu.de>
         Jukka Virtanen <jtv@hut.fi>

String handling routines

This file is part of GNU Pascal Library. The GNU Pascal Library is free
software; you can redistribute it and/or modify it under the terms of
the GNU Library General Public License as published by the Free Software
Foundation; either version 2 of the License, or (at your option) any
later version.

The GNU Pascal Library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Library General Public License for more details.

You should have received a copy of the GNU Library General Public
License along with the GNU Pascal Library; see the file COPYING.LIB.  If
not, write to the Free Software Foundation, Inc., 675 Mass Ave,
Cambridge, MA 02139, USA.
}

unit GStrings;

interface

uses GPC;

{ TString is a string type that is used for function results and local
  variables, as long as undiscriminated strings are not allowed there.
  The default size of 2048 characters should be enough for file names
  on any system, but can be changed when necessary. This should be at
  least as big as MAXPATHLEN. }

const
  TStringSize = 2048;
  SpaceCharacters = [' ', #9];
  UndiscriminatedStringSizeStep = 64;

type
  TString    = String (TStringSize);
  TStringBuf = packed array [0 .. TStringSize] of Char;
  PString    = ^String;
  CharSet    = set of Char;

function  GPC_UpCase      (ch : Char) : Char;                                    asmname '_p_gpc_upcase';
function  GPC_LoCase      (ch : Char) : Char;                                    asmname '_p_gpc_locase';
function  BP_UpCase       (ch : Char) : Char;                                    asmname '_p_bp_upcase';
function  BP_LoCase       (ch : Char) : Char;                                    asmname '_p_bp_locase';

procedure UpCaseString    (var s : String);                                      asmname '_p_upcase_string';
procedure LoCaseString    (var s : String);                                      asmname '_p_locase_string';
function  UpCaseStr       (const s : String) : TString;                          asmname '_p_upcase_str';
function  LoCaseStr       (const s : String) : TString;                          asmname '_p_locase_str';

function  Pos             (const SubStr, Str : String) : Integer;                asmname '_p_pos';
function  LastPos         (const SubStr, Str : String) : Integer;                asmname '_p_lastpos';
function  CharPos         (const Chars : CharSet; const Str : String) : Integer; asmname '_p_charpos';
function  LastCharPos     (const Chars : CharSet; const Str : String) : Integer; asmname '_p_lastcharpos';

function  PosFrom         (const SubStr, Str : String; From : Integer) : Integer;                asmname '_p_posfrom';
function  LastPosTill     (const SubStr, Str : String; Till : Integer) : Integer;                asmname '_p_lastpostill';
function  CharPosFrom     (const Chars : CharSet; const Str : String; From : Integer) : Integer; asmname '_p_charposfrom';
function  LastCharPosTill (const Chars : CharSet; const Str : String; Till : Integer) : Integer; asmname '_p_lastcharpostill';

function  IsPrefix        (const Prefix, s : String) : Boolean;                  asmname '_p_isprefix';
function  IsSuffix        (const Suffix, s : String) : Boolean;                  asmname '_p_issuffix';

function  StrLen          (Src : CString) : SizeType;                            asmname '_p_strlen';
function  StrEnd          (Src : CString) : CString;                             asmname '_p_strend';
function  StrDup          (Src : CString) : CString;                             asmname '_p_strdup';
function  StrNew          (Src : CString) : CString;                             asmname '_p_strdup';
procedure StrDispose      (s : CString);                                         asmname '_p_dispose';
function  StrCmp          (s1, s2 : CString) : Integer;                          asmname '_p_strcmp';
function  StrComp         (s1, s2 : CString) : Integer;                          asmname '_p_strcmp';
function  StrLCmp         (s1, s2 : CString; MaxLen : SizeType) : Integer;       asmname '_p_strlcmp';
function  StrLComp        (s1, s2 : CString; MaxLen : SizeType) : Integer;       asmname '_p_strlcmp';
function  StrCaseCmp      (s1, s2 : CString) : Integer;                          asmname '_p_strcasecmp';
function  StrIComp        (s1, s2 : CString) : Integer;                          asmname '_p_strcasecmp';
function  StrLCaseCmp     (s1, s2 : CString; MaxLen : SizeType) : Integer;       asmname '_p_strlcasecmp';
function  StrLIComp       (s1, s2 : CString; MaxLen : SizeType) : Integer;       asmname '_p_strlcasecmp';
function  StrCpy          (Dest, Source : CString) : CString;                    asmname '_p_strcpy';
function  StrCopy         (Dest, Source : CString) : CString;                    asmname '_p_strcpy';
function  StrECpy         (Dest, Source : CString) : CString;                    asmname '_p_strecpy';
function  StrECopy        (Dest, Source : CString) : CString;                    asmname '_p_strecpy';
function  StrLCpy         (Dest, Source : CString; MaxLen : SizeType) : CString; asmname '_p_strlcpy';
function  StrLCopy        (Dest, Source : CString; MaxLen : SizeType) : CString; asmname '_p_strlcpy';
function  StrMove         (Dest, Source : CString; Count : SizeType) : CString;  asmname '_p_strmove';
function  StrCat          (Dest, Source : CString) : CString;                    asmname '_p_strcat';
function  StrLCat         (Dest, Source : CString; MaxLen : SizeType) : CString; asmname '_p_strlcat';
function  StrScan         (Src : CString; Ch : Char) : CString;                  asmname '_p_strscan';
function  StrRScan        (Src : CString; Ch : Char) : CString;                  asmname '_p_strrscan';
function  StrPos          (Str, SubStr : CString) : CString;                     asmname '_p_strpos';
function  StrRPos         (Str, SubStr : CString) : CString;                     asmname '_p_strrpos';
function  StrCasePos      (Str, SubStr : CString) : CString;                     asmname '_p_strcasepos';
function  StrRCasePos     (Str, SubStr : CString) : CString;                     asmname '_p_strrcasepos';
function  StrUpper        (s : CString) : CString;                               asmname '_p_strupper';
function  StrLower        (s : CString) : CString;                               asmname '_p_strlower';
function  StrEmpty        (s : CString) : Boolean;                               asmname '_p_strempty';

function  NewCString      (const Source : String) : CString;                     asmname '_p_newcstring';
function  StrPCopy        (Dest : CString; const Source : String) : CString;     asmname '_p_strpcopy';
procedure StrCCopy        (Source : CString; var Dest : String);                 asmname '_p_strccopy';

function  NewString       (const s : String) : PString;                          asmname '_p_newstring';
procedure DisposeString   (p : PString);                                         asmname '_p_dispose';

procedure SetString       (var s : String; Buffer : PChar; Count : Integer);     asmname '_p_set_string';
function  StringOfChar    (Ch : Char; Count : Integer) = s : TString;            asmname '_p_string_of_char';

procedure TrimLeft        (var s : String);                                      asmname '_p_trimleft';
procedure TrimRight       (var s : String);                                      asmname '_p_trimright';
procedure TrimBoth        (var s : String);                                      asmname '_p_trimboth';
function  TrimLeftStr     (const s : String) : TString;                          asmname '_p_trimleft_str';
function  TrimRightStr    (const s : String) : TString;                          asmname '_p_trimright_str';
function  TrimBothStr     (const s : String) : TString;                          asmname '_p_trimboth_str';

{ Internal routines for the strtring operators }

{ Compare strings for equality without padding }
function  StrEQ (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Boolean;    asmname '_p_eq';

{ Compare strings for `less-than' without padding }
function  StrLT (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Boolean;    asmname '_p_lt';

{ Compare strings for equality, padding the shorter string with spaces }
function  StrEQPad (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Boolean; asmname '_p_str_eq';

{ Compare strings for `less-than', padding the shorter string with spaces }
function  StrLTPad (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Boolean; asmname '_p_str_lt';

{ Internal routine for Index/Pos }
function  StrIndex (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Integer; asmname '_p_index';

{ Internal routine for Trim }
function  StrTrim (Src : PChar; SrcLength : Integer; Dest : PChar) : Integer; asmname '_p_trim';

{ Internal routine for SubStr/Copy }
function  SubStr (Src : PChar; SrcLength, Position, Count : Integer; Dest : PChar; Truncate : Boolean) : Integer; asmname '_p_substr';

function  GetStringCapacity (const s : String) : Integer;                        asmname '_p_get_string_capacity';

procedure GPC_Insert      (const Source: String; var Dest : String;
                           Index : Integer; Truncate : Boolean);                 asmname '_p_insert';
procedure GPC_Delete      (var s : String; Index, Count : Integer);              asmname '_p_delete';

{ Under development }
function VarAnyStringLength (var s : VarAnyString) : Integer; asmname '_p_var_anystring_length';
function VarAnyStringSetLength (var s : VarAnyString; NewLength : Integer) : Integer; asmname '_p_var_anystring_setlength';
procedure AnyStringTFDD_Reset (var f : AnyFile; var Buf : ConstAnyString); asmname '_p_anystring_tfdd_reset';
procedure AnyStringTFDD_Rewrite (var f : AnyFile; var Buf : VarAnyString); asmname '_p_anystring_tfdd_rewrite';
procedure StringTFDD_Reset (var f : AnyFile; var Buf : ConstAnyString; const s : String); asmname '_p_string_tfdd_reset';
procedure StringTFDD_Rewrite (var f : AnyFile; var Buf : VarAnyString; var s : String); asmname '_p_string_tfdd_rewrite';

implementation

{$I-,B-,X+}

function ToUpper (ch: Integer) : Integer; C;
function ToLower (ch: Integer) : Integer; C;

(*@@maur3.pas inline*) function GPC_UpCase (ch : Char) : Char;
begin
  GPC_UpCase := Chr (ToUpper (Ord (ch)))
end;

(*@@inline*) function GPC_LoCase (ch : Char) : Char;
begin
  GPC_LoCase := Chr (ToLower (Ord (ch)))
end;

(*@@inline*) function BP_UpCase (ch : Char) : Char;
begin
  if ch in ['a'..'z']
    then BP_UpCase := Pred (ch, Ord ('a') - Ord ('A'))
    else BP_UpCase := ch
end;

(*@@inline*) function BP_LoCase (ch : Char) : Char;
begin
  if ch in ['A'..'Z']
    then BP_LoCase := Succ (ch, Ord ('a') - Ord ('A'))
    else BP_LoCase := ch
end;

procedure UpCaseString (var s : String);
var i : Integer;
begin
  for i := 1 to Length (s) do s [i] := UpCase (s [i])
end;

procedure LoCaseString (var s : String);
var i : Integer;
begin
  for i := 1 to Length (s) do s [i] := LoCase (s [i])
end;

function  UpCaseStr (const s : String) = Result : TString;
begin
  Result := s;
  UpCaseString (Result)
end;

function  LoCaseStr (const s : String) = Result : TString;
begin
  Result := s;
  LoCaseString (Result)
end;

function Pos (const SubStr, Str : String) : Integer;
begin
  Pos := PosFrom (SubStr, Str, 1)
end;

function LastPos (const SubStr, Str : String) : Integer;
begin
  LastPos := LastPosTill (SubStr, Str, Length (Str))
end;

function CharPos (const Chars : CharSet; const Str : String) : Integer;
var i : Integer;
begin
  i := 1;
  while (i <= Length (Str)) and not (Str [i] in Chars) do Inc (i);
  if i > Length (Str) then CharPos := 0 else CharPos := i
end;

function LastCharPos (const Chars : CharSet; const Str : String) : Integer;
var i : Integer;
begin
  i := Length (Str);
  while (i > 0) and not (Str [i] in Chars) do Dec (i);
  LastCharPos := i
end;

function PosFrom (const SubStr, Str : String; From : Integer) : Integer;
var m, i, n : Integer;
begin
  m := Max (1, From);
  case Length (SubStr) of
    0: PosFrom := From;
    1: begin
         i := m;
         while (i <= Length (Str)) and (Str [i] <> SubStr [1]) do Inc (i);
         if i > Length (Str) then PosFrom := 0 else PosFrom := i
       end;
    else
      n := Length (Str) - Length (SubStr) + 1;
      i := m;
      while (i <= n) and (MemComp (Str [i], SubStr [1], Length (SubStr)) <> 0) do Inc (i);
      if i > n then PosFrom := 0 else PosFrom := i
  end
end;

function LastPosTill (const SubStr, Str : String; Till : Integer) : Integer;
var m, i : Integer;
begin
  m := Max (0, Min (Length (Str), Till));
  case Length (SubStr) of
    0: LastPosTill := m + 1;
    1: begin
         i := m;
         while (i > 0) and (Str [i] <> SubStr [1]) do Dec (i);
         LastPosTill := i
       end;
    else
      i := m - Length (SubStr) + 1;
      while (i > 0) and (MemComp (Str [i], SubStr [1], Length (SubStr)) <> 0) do Dec (i);
      if i < 0 then LastPosTill := 0 else LastPosTill := i
  end
end;

function CharPosFrom (const Chars : CharSet; const Str : String; From : Integer) : Integer;
var i : Integer;
begin
  i := Max (1, From);
  while (i <= Length (Str)) and not (Str [i] in Chars) do Inc (i);
  if i > Length (Str) then CharPosFrom := 0 else CharPosFrom := i
end;

function LastCharPosTill (const Chars : CharSet; const Str : String; Till : Integer) : Integer;
var i : Integer;
begin
  i := Max (0, Min (Length (Str), Till));
  while (i > 0) and not (Str [i] in Chars) do Dec (i);
  LastCharPosTill := i
end;

function IsPrefix (const Prefix, s : String) : Boolean;
begin
  (*@@fjf226*)if not (Length (s) >= Length (Prefix)) then IsPrefix := False
    else IsPrefix := EQ (s [1 .. Length (Prefix)], Prefix)
end;

function IsSuffix (const Suffix, s : String) : Boolean;
begin
  (*@@fjf226*)if not (Length (s) >= Length (Suffix)) then IsSuffix := False
    else IsSuffix := EQ (s [Length (s) - Length (Suffix) + 1 .. Length (s)], Suffix)
end;

(*@@inline*) function StrLen (Src : CString) : SizeType;
var Temp : CString;
begin
  if Src = nil then return 0;
  Temp := Src;
  while Temp^ <> #0 do Inc (Temp);
  StrLen := Temp - Src
end;

(*@@inline*) function StrEnd (Src : CString) : CString;
var Temp : CString;
begin
  if Src = nil then return nil;
  Temp := Src;
  while Temp^ <> #0 do Inc (Temp);
  StrEnd := Temp
end;

function StrDup (Src : CString) : CString;
var
  Size : SizeType;
  Dest : CString;
begin
  if Src = nil then return nil;
  Size := StrLen (Src) + 1;
  GetMem (Dest, Size);
  Move (Src^, Dest^, Size);
  StrDup := Dest
end;

function StrLCmp (s1, s2 : CString; MaxLen : SizeType) : Integer;
var c1, c2: Char;
begin
  if s1 = nil then
    if (s2 = nil) or (s2^ = #0)
      then StrLCmp := 0
      else StrLCmp := -1
  else if s2 = nil then
    if s1^ = #0
      then StrLCmp := 0
      else StrLCmp := 1
  else
    begin
      if MaxLen > 0 then
        repeat
          c1 := s1^;
          c2 := s2^;
          Inc (s1);
          Inc (s2);
          if c1 <> c2 then return Ord (c1) - Ord (c2);
          Dec (MaxLen)
        until (c1 = #0) or (MaxLen = 0);
      StrLCmp := 0
    end
end;

function StrCmp (s1, s2 : CString) : Integer;
begin
  StrCmp := StrLCmp (s1, s2, MaxInt)
end;

function StrLCaseCmp (s1, s2 : CString; MaxLen : SizeType) : Integer;
var c1, c2: Char;
begin
  if s1 = nil then
    if (s2 = nil) or (s2^ = #0)
      then StrLCaseCmp := 0
      else StrLCaseCmp := -1
  else if s2 = nil then
    if s1^ = #0
      then StrLCaseCmp := 0
      else StrLCaseCmp := 1
  else
    begin
      if MaxLen > 0 then
        repeat
          c1 := LoCase (s1^);
          c2 := LoCase (s2^);
          Inc (s1);
          Inc (s2);
          if c1 <> c2 then return Ord (c1) - Ord (c2);
          Dec (MaxLen)
        until (c1 = #0) or (MaxLen = 0);
      StrLCaseCmp := 0
    end
end;

function StrCaseCmp (s1, s2 : CString) : Integer;
begin
  StrCaseCmp := StrLCaseCmp (s1, s2, MaxInt)
end;

function StrCpy (Dest, Source : CString) : CString;
var Size : SizeType;
begin
  if Source = nil
    then Size := 0
    else
      begin
        Size := StrLen (Source);
        Move (Source^, Dest^, Size)
      end;
  Dest [Size] := #0;
  StrCpy := Dest
end;

function StrECpy (Dest, Source : CString) : CString;
var Size : SizeType;
begin
  if Source = nil
    then Size := 0
    else
      begin
        Size := StrLen (Source);
        Move (Source^, Dest^, Size)
      end;
  Dest [Size] := #0;
  StrECpy := Dest + Size
end;

function StrLCpy (Dest, Source : CString; MaxLen : SizeType) : CString;
var Size : SizeType;
begin
  if Source = nil
    then Size := 0
    else
      begin
        Size := Min (StrLen (Source), MaxLen);
        Move (Source^, Dest^, Size)
      end;
  Dest [Size] := #0;
  StrLCpy := Dest
end;

function StrMove (Dest, Source : CString; Count : SizeType) : CString;
begin
  if Source = nil
    then FillChar (Dest^, Count, 0)
    else Move (Source^, Dest^, Count);
  StrMove := Dest
end;

function StrCat (Dest, Source : CString) : CString;
begin
  StrCpy (StrEnd (Dest), Source);
  StrCat := Dest
end;

function StrLCat (Dest, Source : CString; MaxLen : SizeType) : CString;
var s : SizeType;
begin
  s := StrLen (Dest);
  StrLCpy (Dest + s, Source, Max (MaxLen, s) - s);
  StrLCat := Dest
end;

(*@@inline*) function StrScan (Src : CString; Ch : Char) : CString;
var Temp : CString;
begin
  if Src = nil then return nil;
  Temp := Src;
  while (Temp^ <> #0) and (Temp^ <> Ch) do Inc (Temp);
  if Temp^ = Ch then StrScan := Temp else StrScan := nil
end;

(*@@inline*) function StrRScan (Src : CString; Ch : Char) : CString;
var Temp : CString;
begin
  if Src = nil then return nil;
  Temp := StrEnd (Src);
  while (Temp <> Src) and (Temp^ <> Ch) do Dec (Temp);
  if Temp^ = Ch then StrRScan := Temp else StrRScan := nil
end;

function StrPos (Str, SubStr : CString) : CString;
var
  Temp : CString;
  s : SizeType;
begin
  if (Str = nil) or (SubStr = nil) then return Str;
  s := StrLen (SubStr);
  Temp := Str;
  while Temp^ <> #0 do
    begin
      if StrLCmp (Temp, SubStr, s) = 0 then return Temp;
      Inc (Temp)
    end;
  StrPos := nil
end;

function StrRPos (Str, SubStr : CString) : CString;
var
  Temp : CString;
  s : SizeType;
begin
  if (Str = nil) or (SubStr = nil) then return Str;
  s := StrLen (SubStr);
  Temp := StrEnd (Str);
  while Temp >= Str do
    begin
      if StrLCmp (Temp, SubStr, s) = 0 then return Temp;
      Dec (Temp)
    end;
  StrRPos := nil
end;

function StrCasePos (Str, SubStr : CString) : CString;
var
  Temp : CString;
  s : SizeType;
begin
  if (Str = nil) or (SubStr = nil) then return Str;
  s := StrLen (SubStr);
  Temp := Str;
  while Temp^ <> #0 do
    begin
      if StrLCaseCmp (Temp, SubStr, s) = 0 then return Temp;
      Inc (Temp)
    end;
  StrCasePos := nil
end;

function StrRCasePos (Str, SubStr : CString) : CString;
var
  Temp : CString;
  s : SizeType;
begin
  if (Str = nil) or (SubStr = nil) then return Str;
  s := StrLen (SubStr);
  Temp := StrEnd (Str);
  while Temp >= Str do
    begin
      if StrLCaseCmp (Temp, SubStr, s) = 0 then return Temp;
      Dec (Temp)
    end;
  StrRCasePos := nil
end;

function StrUpper (s : CString) : CString;
var Temp : CString;
begin
  Temp := s;
  if Temp <> nil then
    while Temp^ <> #0 do
      begin
        Temp^ := UpCase (Temp^);
        Inc (Temp)
      end;
  StrUpper := s
end;

function StrLower (s : CString) : CString;
var Temp : CString;
begin
  Temp := s;
  if Temp <> nil then
    while Temp^ <> #0 do
      begin
        Temp^ := LoCase (Temp^);
        Inc (Temp)
      end;
  StrLower := s
end;

function StrEmpty (s : CString) : Boolean;
begin
  StrEmpty := (s = nil) or (s^ = #0)
end;

function NewCString (const Source : String) : CString;
var Dest : CString;
begin
  GetMem (Dest, Length (Source) + 1);
  MoveLeft (Source [1], Dest [0], Length (Source));
  Dest [Length (Source)] := #0;
  NewCString := Dest
end;

function StrPCopy (Dest : CString; const Source : String) : CString;
begin
  MoveLeft (Source [1], Dest [0], Length (Source));
  Dest [Length (Source)] := #0;
  StrPCopy := Dest
end;

procedure StrCCopy (Source : CString; var Dest : String);
var Source_Length : SizeType;
begin
  if Source = nil
    then SetLength (Dest, 0)
    else
      begin
        Source_Length := Min (StrLen (Source), Dest.Capacity);
        SetLength (Dest, Source_Length);
        MoveLeft (Source [0], Dest [1], Source_Length)
      end
end;

function NewString (const s : String) = Result : PString;
begin
  New (Result, Length (s));
  Result^ := s
end;

procedure SetString (var s : String; Buffer : PChar; Count : Integer);
var i : Integer;
begin
  SetLength (s, Min (GetStringCapacity (s), Max (0, Count)));
  if Buffer <> nil then
    for i := 1 to (*@@return value of SetLength*)Length (s) do s [i] := Buffer [i - 1]
end;

function StringOfChar (Ch : Char; Count : Integer) = s : TString;
var i : Integer;
begin
  SetLength (s, Min (GetStringCapacity (s), Max (0, Count)));
  for i := 1 to (*@@return value of SetLength*)Length (s) do s [i] := Ch
end;

procedure TrimLeft (var s : String);
var i : Integer;
begin
  i := 1;
  while (i <= Length (s)) and (s [i] in SpaceCharacters) do Inc (i);
  Delete (s, 1, i - 1)
end;

procedure TrimRight (var s : String);
var i : Integer;
begin
  i := Length (s);
  while (i > 0) and (s [i] in SpaceCharacters) do Dec (i);
  Delete (s, i + 1, Length(s) - i)
end;

procedure TrimBoth (var s : String);
begin
  TrimLeft (s);
  TrimRight (s)
end;

function TrimLeftStr (const s : String) = Result : TString;
begin
  Result := s;
  TrimLeft (Result)
end;

function TrimRightStr (const s : String) = Result : TString;
begin
  Result := s;
  TrimRight (Result)
end;

function TrimBothStr (const s : String) = Result : TString;
begin
  Result := s;
  TrimBoth (Result)
end;

function StrEQ (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Boolean;
begin
  StrEq := (Length1 = Length2) and (MemCmp (s1 [0], s2 [0], Length1) = 0)
end;

function StrLT (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Boolean;
begin
  if Length1 < Length2
    then StrLT := MemCmp (s1 [0], s2 [0], Length1) <= 0
    else StrLT := MemCmp (s1 [0], s2 [0], Length2) < 0
end;

function StrEQPad (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) = Result : Boolean;
var
  s : PChar;
  l, c : Integer;
begin
  if Length1 > Length2 then
    begin
      s := s1; s1 := s2; s2 := s;
      l := Length1; Length1 := Length2; Length2 := l
    end;
  Result := MemCmp (s1 [0], s2 [0], Length1) = 0;
  if Result and (Length1 <> Length2) then
    for c := Length1 to Length2 - 1 do
      if s2 [c] <> ' ' then return False
end;

function StrLTPad (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Boolean;
var
  sLong, sShort : PChar;
  lLong, lShort, c, r : Integer;
  s1IsLonger : Boolean;
begin
  s1IsLonger := Length1 > Length2;
  if s1IsLonger
    then
      begin
        sLong  := s1;
        sShort := s2;
        lLong  := Length1;
        lShort := Length2
      end
    else
      begin
        sLong  := s2;
        sShort := s1;
        lLong  := Length2;
        lShort := Length1
      end;
  r := MemCmp (s1 [0], s2 [0], lShort);
  if (r <> 0) or (Length1 = Length2) then return r < 0;
  for c := lShort to lLong - 1 do
    if sLong [c] <> ' ' then
      if s1IsLonger
        then return sLong [c] < ' '
        else return sLong [c] > ' ';
  StrLTPad := False
end;

function StrIndex (s1 : PChar; Length1 : Integer; s2 : PChar; Length2 : Integer) : Integer;
var c : Integer;
begin
  if (Length2 < 0) or (Length1 < 0) then
    InternalError (907); { string length cannot be negative }
  if Length2 = 0 then return 1;
  if Length1 = 0 then return 0;
  if Length1 = 1 then return Ord ((Length2 = 1) and (s1 [0] = s2 [0]));
  if Length2 = 1 then
    begin
      for c := 1 to Length1 do
        if s1 [c - 1] = s2 [0] then return c;
      return 0
    end;
  for c := 1 to Length1 - Length2 + 1 do
    if (s1 [c - 1] = s2 [0]) and
       (s1 [c + Length2 - 2] = s2 [Length2 - 1]) and
       (MemCmp (s1 [c], s2 [1], Length2 - 2) = 0) then return c;
  StrIndex := 0
end;

function StrTrim (Src : PChar; SrcLength : Integer; Dest : PChar) : Integer;
var i : Integer;
begin
  i := SrcLength;
  while (i > 0) and (Src [i - 1] = ' ') do Dec (i);
  Move (Src [0], Dest [0], i);
  StrTrim := i
end;

function SubStr (Src : PChar; SrcLength, Position, Count : Integer; Dest : PChar; Truncate : Boolean) : Integer;
begin
  SubStr := 0;
  if Position <= 0 then
    if Truncate
      then Exit
      else RuntimeError (801); { Substring cannot start from positions less than 1 }
  if Position + Count - 1 > SrcLength then
    if Truncate
      then Count := SrcLength - Position + 1
      else RuntimeError (803); { Substring must terminate before end of string }
  if Count < 0 then
    if Truncate
      then Exit
      else RuntimeError (802); { Substring length cannot be negative }
  if Count = 0 then Exit;
  Move (Src [Position - 1], Dest [0], Count);
  SubStr := Count
end;

function VarAnyStringLength (var s : VarAnyString) : Integer;
begin
  with s do
(*@@fjf276*)(*$W-*)
    case StringType of
      AnyStringLong            : VarAnyStringLength := PLongLength^;
      AnyStringUndiscriminated : VarAnyStringLength := Length (PUndiscriminatedString^^);
      AnyStringShort           : VarAnyStringLength := PShortLength^;
      AnyStringFixed           : VarAnyStringLength := CurrentLength;
      AnyStringCString         : VarAnyStringLength := StrLen (CString (Chars));
      AnyStringObject          : VarAnyStringLength := PStringObject^.GetLength;
    end
end;
(*$W+*)

function VarAnyStringSetLength (var s : VarAnyString; NewLength : Integer) : Integer;
begin
  with s do
    begin
      if NewLength > Capacity then
        if Truncate
          then NewLength := Capacity
          else RuntimeError (806); { string too long }
      (*@@fjf276*)(*$W-*)
      case StringType of
        AnyStringLong            : PLongLength^ := NewLength;
        AnyStringUndiscriminated : begin
                                     if NewLength > PUndiscriminatedString^^.Capacity then
                                       begin
                                         var Temp : PString;
                                         Temp := PUndiscriminatedString^;
                                         New (PUndiscriminatedString^, (NewLength div UndiscriminatedStringSizeStep + 1) * UndiscriminatedStringSizeStep);
                                         Move (Temp^[1], PUndiscriminatedString^^[1], Length (Temp^));
                                         Dispose (Temp)
                                       end;
                                     GPC_PString (PUndiscriminatedString^)^.Length := NewLength
                                   end;
        AnyStringShort           : PShortLength^ := NewLength;
        AnyStringFixed           : begin
                                     var i : Integer;
                                     for i := NewLength + 1 to CurrentLength do Chars^[i] := ' ';
                                     CurrentLength := NewLength
                                   end;
        AnyStringCString         : Chars^[NewLength + 1] := #0;
        AnyStringObject          : PStringObject^.SetLength (NewLength);
      end
      (*$W+*)
    end;
  VarAnyStringSetLength := NewLength
end;

function StringTFDD_Read (var PrivateData; var Buffer; Size : SizeType) = Result : SizeType;
begin
  with ConstAnyString (PrivateData) do
    begin
      Result := Min (Size, Length);
      Move (Chars^, Buffer, Result);
      Inc (Chars, Result);
      Dec (Length, Result)
    end
end;

function StringTFDD_Write (var PrivateData; const Buffer; Size : SizeType) = Result : SizeType;
var CurLength : Integer;
begin
  with VarAnyString (PrivateData) do
    begin
      CurLength := VarAnyStringLength (VarAnyString (PrivateData));
      Result := Max (0, VarAnyStringSetLength (VarAnyString (PrivateData), CurLength + Size) - Size);
      Move (Buffer, Chars^[CurLength + 1], Result);
      if Truncate then Result := Size
    end
end;

procedure AnyStringTFDD_Reset (var f : AnyFile; var Buf : ConstAnyString);
begin
  AssignTFDD (f, (*@@*)TOpenProc(nil), StringTFDD_Read, TWriteFunc(nil), TFlushProc(nil), TCloseProc(nil), TDoneProc(nil), @Buf);
  Reset (f)
end;

procedure AnyStringTFDD_Rewrite (var f : AnyFile; var Buf : VarAnyString);
begin
  VarAnyStringSetLength (Buf, 0);
  AssignTFDD (f, (*@@*)TOpenProc(nil), TReadFunc(nil), StringTFDD_Write, TFlushProc(nil), TCloseProc(nil), TDoneProc(nil), @Buf);
  Rewrite (f)
end;

procedure StringTFDD_Reset (var f : AnyFile; var Buf : ConstAnyString; const s : String);
begin
  Buf.Length := Length (s);
  Buf.Chars := PChars (@s[1]);
  AnyStringTFDD_Reset (f, Buf)
end;

procedure StringTFDD_Rewrite (var f : AnyFile; var Buf : VarAnyString; var s : String);
begin
  Buf.Capacity := s.Capacity;
  Buf.Chars := PChars (@s[1]);
  Buf.Truncate := True; (**)
  Buf.StringType := AnyStringLong;
  Buf.PLongLength := @GPC_PString (@s)^.Length;
  AnyStringTFDD_Rewrite (f, Buf)
end;

{$define Length(s) s##_Length}
{$define Capacity(s) s##_Capacity}
{$define ConstAnyString(s) s : PChar; Length (s) : Integer}
{$define VarAnyString(s) s : PChar; Capacity (s), Length (s) : Integer}
{$define ASCONST(s) @s[1], length (s)}
{$define ASVAR(s)   @s[1], s.capacity, length (s)}

function Insert_F (ConstAnyString (s); VarAnyString (d);
                   Index : Integer; Truncate : Boolean) : Integer;
var Dest : PChar;
begin
  if (Index < 1) or (Index > Length (d) + 1) or (Length (s) <= 0) then
    Insert_F := Length (d)
  else
    begin
      if Length (s) + Length (d) > Capacity (d) then
        if Truncate then
          begin
            if Length (s) > Capacity (d) - Index + 1 then
              Length (s) := Capacity (d) - Index + 1;
            Length (d) := Capacity (d) - Length (s)
          end
        else RuntimeError (800); { string too long in `Insert' }
      Dest := d + Index - 1;
      MoveRight (Dest [0], Dest [Length (s)], Length (d) - Index + 1);
      MoveLeft (s [0], Dest [0], Length (s));
      Insert_F := Length (s) + Length (d)
    end
end;

function GetStringCapacity (const s : String) : Integer;
begin
  GetStringCapacity := s.Capacity
end;

procedure GPC_Insert (const Source : String; var Dest : String; Index : Integer; Truncate : Boolean);
begin
  {$W-}
  SetLength (Dest, Insert_F (ASCONST (Source), ASVAR (Dest), Index, Truncate))
  {$W+}
end;

function Delete_F (ConstAnyString (s); Index, Count : Integer) : Integer;
var Ofs : Integer;
begin
  if Index < 1 then
    begin
      Dec (Count, 1 - Index);
      Index := 1
    end;
  if (Count <= 0) or (Index > Length (s)) then
    Delete_F := Length (s)
  else if Index + Count > Length (s) then
    Delete_F := Index - 1
  else
    begin
      Ofs := Index - 1 + Count;
      MoveLeft (s [Ofs], s [Index - 1],  Length (s) - Ofs);
      Delete_F := Length (s) - Count
    end
end;

procedure GPC_Delete (var s : String; Index, Count : Integer);
begin
  SetLength (s, Delete_F (ASCONST (s), Index, Count))
end;

function  StringObject.GetCapacity : Integer;
begin
  GetCapacity := 0
end;

procedure StringObject.SetLength (NewLength : Integer);
begin
end;

function  StringObject.GetLength : Integer;
begin
  GetLength := 0
end;

function  StringObject.GetFirstChar : PChars;
begin
  GetFirstChar := nil
end;

end.
