unit DelFor;
uses SysUtils, OObjects;
interface
type
  TWordType = (wtLineFeed, wtSpaces, wtHalfComment, wtHalfStarComment,
    wtFullComment, wtString, wtErrorString, wtOperator, wtWord, wtNumber,
    wtNothing);
const
  ftNothing = 0;
  ftSpaceBefore = 1;
  ftSpaceAfter = 2;
  ftSpaceBoth = 3;
type
  TReservedType = (rtNothing, rtReserved, rtOper, rtDirective, rtIf, rtDo,
    rtWhile, rtVar, rtProcedure, rtAsm, rtTry, rtExcept, rtEnd, rtBegin, rtIfBegin,
    rtCase, rtOf, rtLineFeed, rtColon, rtSemiColon, rtThen, rtClass, rtProgram,
    rtRepeat, rtUntil, rtRecord, rtPrivate, rtElse, rtInterface, rtImplementation);
  TReservedFormat = (rfLowerCase, rfUpperCase, rfFirstUp, rfUnchanged);
  TReservedRec = record
    ReservedType: TReservedType;
    words: PChar;
  end;
const
  ngroups = 25;
type
  TReservedArray = array[0..ngroups - 1] of TReservedRec;
const
  ReservedArray: TReservedArray = (
    (ReservedType: rtOper; words:
    ',or,shl,xor,is,in,and,div,mod,shr,as,not,to,downto'),
    (ReservedType: rtOf; words: ',of'),
    (ReservedType: rtDirective; words: ',inline,exports,dispinterface'),
    (ReservedType: rtReserved; words: ',set,label,raise,array,file,nil,string,property,out,threadvar,goto,packed,inherited'),
    (ReservedType: rtProgram; words: ',library,uses,initialization,finalization,program,unit'),
    (ReservedType: rtInterface; words: ',interface'),
    (ReservedType: rtImplementation; words: ',implementation'),
    (ReservedType: rtVar; words: ',stringresource,const,var,type'),
    (ReservedType: rtAsm; words: ',asm'),
    (ReservedType: rtPrivate; words: ',private,protected,public,published'),
    (ReservedType: rtExcept; words: ',finally,except'),
    (ReservedType: rtClass; words: ',object,class'),
    (ReservedType: rtThen; words: ',then'),
    (ReservedType: rtBegin; words: ',begin'),
    (ReservedType: rtWhile; words: ',while,with,on,for'),
    (ReservedType: rtCase; words: ',case'),
    (ReservedType: rtProcedure; words: ',function,procedure,constructor,destructor'),
    (ReservedType: rtTry; words: ',try'),
    (ReservedType: rtIf; words: ',if'),
    (ReservedType: rtUntil; words: ',until'),
    (ReservedType: rtDo; words: ',do'),
    (ReservedType: rtRecord; words: ',record'),
    (ReservedType: rtRepeat; words: ',repeat'),
    (ReservedType: rtElse; words: ',else'),
    (ReservedType: rtEnd; words: ',end'));

type

  PPascalWord = ^TPascalWord;
  TPascalWord = object(TObject)
    constructor Create;
    function Expression: PChar; virtual;
    function WordType: TWordType; virtual;
    function space(Before: Boolean): Boolean; virtual;
    function ReservedType: TReservedType; virtual;
    procedure SetSpace(Before, State: Boolean); virtual;
    procedure SetReservedType(aReservedType: TReservedType); virtual;
    function GetEString(Dest: PChar): PChar; virtual;
  end;

  PLineFeed = ^TLineFeed;
  TLineFeed = object(TPascalWord)
    nSpaces: Integer;
    oldnSpaces: Integer;
    constructor Create(aOldnSpaces: Integer);
    procedure SetIndent(n: Integer);
    procedure IncIndent(n: Integer);
    function ReservedType: TReservedType; virtual;
    function GetEString(Dest: PChar): PChar; virtual;
  end;

  PExpression = ^TExpression;
  TExpression = object(TPascalWord)
    FExpression: PChar;
    FWordType: TWordType;
    FFormatType: byte;
    FReservedType: TReservedType;
    constructor Create(aType: TWordType; aExpression: PChar);
    procedure SetExpression(aExpression: PChar);
    procedure SetSpace(Before, State: Boolean); virtual;
    procedure SetReservedType(aReservedType: TReservedType); virtual;
    function space(Before: Boolean): Boolean; virtual;
    function GetEString(Dest: PChar): PChar; virtual;
    function Expression: PChar; virtual;
    function WordType: TWordType; virtual;
    function ReservedType: TReservedType; virtual;
    destructor done; virtual;
  end;

  TPascalParser = object(TObject)
    fileText: TCollection;
    parsedText: TCollection;
    spaceOperators: Boolean;
    spaceColons: Boolean;
    reservedFormat: TReservedFormat;
    changeIndent: Boolean;
    indentBegin: Boolean;
    SpacePerIndent: Integer;
    nIndent: Integer;
    constructor Create;
    procedure LoadFile(AFileName: PChar);
    procedure Parse;
    procedure CalcIndent;
    function ReadHalfComment(Dest, source: PChar; prevType: TWordType): TWordType;
    procedure CheckReserved(PascalWord: PPascalWord);
    function ReadWord(Dest, source: PChar): TWordType;
    function GetString(Dest: PChar; var I: Integer): PChar;
    procedure WriteToFile(AFileName: PChar);
    destructor Destroy;
  end;

var
  Formatter: TPascalParser;
  InFile, outFile: string;
  Dest: array[0..250] of Char;

implementation

constructor TPascalParser.Create;
begin
  spaceOperators := True;
  spaceColons := True;
  reservedFormat := rfLowerCase;
  changeIndent := True;
  indentBegin := False;
  SpacePerIndent := 2;
  fileText {:=TCollection.Create)}.init(500, 500);
end;

procedure TPascalParser.LoadFile(AFileName: PChar);
var
  InFile: Text;
  buff: array[0..400] of Char;
  aWord: array[0..400] of Char;
  WordType: TWordType;
  PrevLine: PLineFeed;
begin
  assign(InFile, AFileName);
  reset(InFile);
  WordType := wtNothing;
  while not eof(InFile) do
  begin
    readln(InFile, buff);
    while buff[0] <> #0 do
    begin
      case WordType of
        wtHalfComment, wtHalfStarComment:
          WordType := ReadHalfComment(aWord, buff, WordType);
      else WordType := ReadWord(aWord, buff);
      end;
      if not (WordType = wtSpaces) then
        fileText.Insert(New(PExpression, Create(WordType, aWord)))
      else if PrevLine^.nSpaces = -1 then
      begin
        PrevLine^.nSpaces := StrLen(aWord);
        PrevLine^.oldnSpaces := StrLen(aWord);
      end;
    end;
    PrevLine := New(PLineFeed, Create(-1));
    fileText.Insert(PrevLine);
  end;
  Close(InFile);
end;

function TPascalParser.ReadWord(Dest, source: PChar): TWordType;
const
  operators = '+-*/=<>[].,():;{}@^';
  allOper = operators + ' {}''';
var
  Result: TWordType;
  P: PChar;
begin
  P := source;
  if P^ = ' ' then
  begin
    Result := wtSpaces;
    while (P^ = ' ') and (P^ <> #0) do inc(P);
    dec(P);
  end
  else if P^ = '{' then
  begin
    Result := wtHalfComment;
    while (P^ <> '}') and (P^ <> #0) do inc(P);
    if (P^ = '}') then Result := wtFullComment;
  end
  else if strLComp(P, '(*', 2) = 0 then
  begin
    Result := wtHalfStarComment;
    while (strLComp(P, '*)', 2) <> 0) and (P^ <> #0) do inc(P);
    if strLComp(P, '*)', 2) = 0 then Result := wtFullComment;
  end
  else if strLComp(P, '//', 2) = 0 then
  begin
    Result := wtFullComment;
    P := StrEnd(P);
  end
  else if P^ = '''' then
  begin
    Result := wtString;
    inc(P);
    while (P^ <> '''') and (P^ <> #0) do inc(P);
    if (P^ = #0) then Result := wtErrorString;
  end
  else if StrScan(operators, P^) <> nil then
  begin
    Result := wtOperator;
    if strLComp(P, '<=', 2) = 0 then inc(P);
    if strLComp(P, '>=', 2) = 0 then inc(P);
    if strLComp(P, '<>', 2) = 0 then inc(P);
    if strLComp(P, ':=', 2) = 0 then inc(P);
    if strLComp(P, '..', 2) = 0 then inc(P);
    if strLComp(P, '(.', 2) = 0 then inc(P);
    if strLComp(P, '.)', 2) = 0 then inc(P);
  end
  else if P^ in ['0'..'9', '$', '#'] then
  begin
    Result := wtNumber;
    while (P^ in ['0'..'9', '.', '$', '#']) and not (strLComp(P, '..', 2) = 0) do
      inc(P);
    if upCase(P^) = 'E' then
      if (P + 1)^ in ['0'..'9', '-'] then
      begin
        inc(P, 2);
        while (P^ in ['0'..'9']) do inc(P);
      end;
    dec(P);
  end
  else
  begin
    Result := wtWord;
    while (StrScan(allOper, P^) = nil) and (P^ <> #0) do
      inc(P);
    dec(P);
  end;
  strLCopy(Dest, source, P - source + 1);
  if (P^ = #0) then
    source^ := #0
  else
  begin
    if ((P + 1)^ = ' ') then inc(P);
    StrCopy(source, P + 1);
  end;
  ReadWord := Result;
end;

function TPascalParser.ReadHalfComment(Dest, source: PChar; prevType: TWordType): TWordType;
var
  P: PChar;
begin
  P := source;
  ReadHalfComment := prevType;
  if prevType = wtHalfComment then
  begin
    while (P^ <> '}') and (P^ <> #0) do inc(P);
    if (P^ = '}') then
    begin
      ReadHalfComment := wtFullComment;
      inc(P);
    end;
  end
  else
  begin
    while (strLComp(P, '*)', 2) <> 0) and (P^ <> #0) do inc(P);
    if strLComp(P, '*)', 2) = 0 then
    begin
      ReadHalfComment := wtFullComment;
      inc(P);
    end;
  end;
  strLCopy(Dest, source, P - source + 1);
  if P^ = #0 then
    source^ := #0
  else
  begin
    if ((P + 1)^ = ' ') then inc(P);
    StrCopy(source, P);
  end;
end;

procedure TPascalParser.CheckReserved(PascalWord: PPascalWord);
var
  P, P1, p2: PChar;
  l, I: Integer;
  buf: array[0..80] of Char;
begin
  PascalWord^.SetReservedType(rtNothing);
  P := strLower(StrCopy(buf, PascalWord^.Expression));
  l := StrLen(P);
  if P <> nil then
    for I := 0 to ngroups - 1 do
      with ReservedArray[I] do
      begin
        P1 := strPos(words, P);
        if P1 <> nil then
        begin
          p2 := P1 + l;
          if (p2^ in [#0, ',']) and ((P1 - 1)^ = ',') then
          begin
            PascalWord^.SetReservedType(ReservedType);
            Exit;
          end;
        end;
      end;
end;

procedure TPascalParser.Parse;
var
  P: PChar;
  PascalWord, next, prev: PPascalWord;
  I: Integer;
begin
  prev := nil;
  with fileText do
    for I := 0 to Count - 1 do
    begin
      PascalWord := PPascalWord(at(I));
      P := PascalWord^.Expression;
      PascalWord^.SetSpace(True, False);
      PascalWord^.SetSpace(False, False);
      if PascalWord^.WordType = wtWord then CheckReserved(PascalWord);
      if StrComp(P, ':') = 0 then PascalWord^.SetReservedType(rtColon);
      if StrComp(P, ';') = 0 then PascalWord^.SetReservedType(rtSemiColon);
      if spaceOperators and (PascalWord^.ReservedType in [rtOper, rtThen, rtOf]) then
      begin
        PascalWord^.SetSpace(True, True);
        PascalWord^.SetSpace(False, True);
      end;
      if (PascalWord^.ReservedType <> rtNothing) then
      begin
        case reservedFormat of
          rfUpperCase: strUpper(P);
          rfLowerCase: strLower(P);
          rfFirstUp:
            begin
              strLower(P);
              P^ := upCase(Char(P^));
            end;
        end;
      end;
      if PascalWord^.ReservedType in [rtDo] then
        PascalWord^.SetSpace(True, True);
      if PascalWord^.ReservedType in [rtIf, rtWhile] then
        PascalWord^.SetSpace(False, True);
  {append space after : , ;}
      if spaceColons and
        ((StrComp(P, ':') = 0) or (StrComp(P, ';') = 0) or
        (StrComp(P, ',') = 0)) then
        PascalWord^.SetSpace(False, True);

  {both sides spaces with = := < > - * + /}
      if spaceOperators and ((StrComp(P, '=') = 0) or (StrComp(P, ':=') = 0) or
        (StrComp(P, '-') = 0) or (StrComp(P, '+') = 0) or (StrComp(P, '/') = 0)
        or (StrComp(P, '*') = 0) or (P^ = '<') or (P^ = '>')) then
      begin
        PascalWord^.SetSpace(False, True);
        PascalWord^.SetSpace(True, True);
      end;

  {delimiter between 2 words (necesary)}
      if (prev <> nil) then
      begin
        if PascalWord^.space(True) and
          prev^.space(False) then prev^.SetSpace(False, False);
        if (prev^.WordType in [wtWord, wtNumber]) and
          (PascalWord^.WordType in [wtWord, wtNumber]) and not
          PascalWord^.space(True) and not prev^.space(False) then
          PascalWord^.SetSpace(True, True);
      end;
      prev := PascalWord;
    end;
  CalcIndent;
end;

procedure TPascalParser.CalcIndent;
type
  TRec = record
    RT: TReservedType;
    nInd: Integer;
  end;
var
  P: PChar;
  PrevLineFeed: PLineFeed;
  I: Integer;
  stack: array[0..100] of TRec;
  stackptr: Integer;
  rtype: TReservedType;
  PasWord: PPascalWord;
  wrapped, WrapIndent: Boolean;
  procIndent: Integer;
  interfacePart: Boolean;
  procedure Push(R: TReservedType; n, ninc: Integer);
  begin
    inc(stackptr);
    with stack[stackptr] do
    begin
      RT := R;
      nInd := n;
      nIndent := n + ninc;
    end;
  end;
  function GetStackTop: TReservedType;
  begin
    if stackptr >= 0 then
      GetStackTop := stack[stackptr].RT
    else
      GetStackTop := rtNothing;
  end;
  function Pop: TReservedType;
  begin
    if stackptr >= 0 then
    begin
      nIndent := stack[stackptr].nInd;
      Pop := stack[stackptr].RT;
      dec(stackptr);
    end
  end;