unit unParser;

(**************************************************************************)
(*                                                                        *)
(* VCL Generator                       Copyright (c) 1998                 *)
(*                                                                        *)
(*                                     Morgan Martinet                    *)
(*                                     23 rue du 14 juillet               *)
(*                                     94270 le Kremlin-Bicetre           *)
(*                                     Phone (Work): 01 47 25 70 77       *)
(*                                     e-mail: mmm@imaginet.fr            *)
(*                                                                        *)
(**************************************************************************)
(* This source code is distributed with no WARRANTY, for no reason or use.*)
(* Everyone is allowed to use and change this code free for his own tasks *)
(* and projects, as long as this header and its copyright text is intact. *)
(* For changed versions of this code, which are public distributed the    *)
(* following additional conditions have to be fullfilled:                 *)
(* 1) The header has to contain a comment on the change and the author of *)
(*    it.                                                                 *)
(* 2) A copy of the changed source has to be sent to the above E-Mail     *)
(*    address or my then valid address, if this is possible to the        *)
(*    author.                                                             *)
(* The second condition has the target to maintain an up to date central  *)
(* version of the component. If this condition is not acceptable for      *)
(* confidential or legal reasons, everyone is free to derive a component  *)
(* or to generate a diff file to my or other original sources.            *)
(**************************************************************************)


interface
uses Classes, SysUtils;

type
  CharsSet = set of Char;

  TMyParser = class
    protected
      FText : String;
      FCurrentChar : PChar;
      FCurrentPos : Integer;
      FLength : Integer;
      FLine : Integer;
      FOffset : Integer;
      FParenthesisDepth : Integer;
      FBracketDepth : Integer;
      FParsingComment : Boolean;

      procedure SetText( const val : String );

    public
      procedure RaiseErr( const s : String );
      procedure RaiseErrFmt( const s : String; args : array of const );
      function  ReadChar : Char;
      function  PeekChar : Char;
      function  PeekPeekChar : Char;
      function  IsSeparator( val : Char ) : Boolean;
      function  IsWhite( val : Char ) : Boolean;
      function  ReadSymbol : String;
      function  PeekSymbol : String;
      function  PeekCharAfterSymbol : String;
      function  ReadConstant : String;
      function  ReadType : String;
      function  ReadExpr : String;
      function  ReadUntil( chars : CharsSet ) : String;
      procedure SkipWhite;
      procedure SkipEndOfLine;
      procedure SkipSemiColon;

      property Text : String read FText write SetText;
      property Line : Integer read FLine;
      property Offset : Integer read FOffset;
      property ParenthesisDepth : Integer read FParenthesisDepth write FParenthesisDepth;
      property BracketDepth : Integer read FBracketDepth write FBracketDepth;
  end;

implementation

procedure TMyParser.SetText( const val : String );
begin
  FLength := length(val);
  FText := val;
  //FText := Copy(val,1,FLength);
  FCurrentPos := 0;
  FCurrentChar := PChar(FText);
  FLine := 1;
  FOffset := 1;
end;

procedure TMyParser.RaiseErr( const s : String );
var
  tmp : String;
begin
  tmp := Format('At line %d, offset %d: ', [Line, Offset]);
  raise Exception.Create( tmp + s );
end;

procedure TMyParser.RaiseErrFmt( const s : String; args : array of const );
var
  tmp : String;
begin
  tmp := Format('At line %d, offset %d: ', [Line, Offset]);
  raise Exception.CreateFmt( tmp + s, args );
end;

function TMyParser.ReadChar : Char;
begin
  if FCurrentPos = FLength then
    raise Exception.Create( 'End of buffer reached' );
  Result := FCurrentChar^;
  if not FParsingComment then
    begin
      if Result = '(' then
        Inc(FParenthesisDepth)
      else if (Result = ')') and (FParenthesisDepth > 0) then
        Dec(FParenthesisDepth)
      else if Result = '[' then
        Inc(FBracketDepth)
      else if (Result = ']') and (FBracketDepth > 0) then
        Dec(FBracketDepth);
    end;
  Inc( FCurrentChar );
  Inc( FCurrentPos );
  Inc( FOffset );
  if Result = #13 then
    begin
      Inc(FLine);
      FOffset := 1;
    end;
end;

function TMyParser.PeekChar : Char;
begin
  if FCurrentPos = FLength then
    raise Exception.Create( 'End of buffer reached' );
  Result := FCurrentChar^;
end;

function  TMyParser.PeekPeekChar : Char;
begin
  if FCurrentPos+1 >= FLength then
    raise Exception.Create( 'End of buffer reached' );
  Result := (FCurrentChar+1)^;
end;

function  TMyParser.IsSeparator( val : Char ) : Boolean;
begin
  Result := val in [' ', #9, #10, #13, ';', ',', '=', '(', ')'];
end;

function  TMyParser.IsWhite( val : Char ) : Boolean;
begin
  Result := val in [' ', #9, #13, #10];
end;

function  TMyParser.ReadSymbol : String;
begin
  Result := '';
  while PeekChar in ['a'..'z', 'A'..'Z', '0'..'9', '_'] do
    Insert( ReadChar, Result, Length(Result)+1 );
  if Result = '' then
    RaiseErr( 'Could not read a symbol' );
end;

function  TMyParser.PeekSymbol : String;
var
  old : PChar;
  old_i : Integer;
  old_ParDepth : Integer;
  old_BraDepth : Integer;
begin
  old := FCurrentChar;
  old_i := FCurrentPos;
  old_ParDepth := FParenthesisDepth;
  old_BraDepth := FBracketDepth;
  try
    Result:= ReadSymbol;
  except
    Result := '';
  end;
  FCurrentChar := old;
  FCurrentPos := old_i;
  FParenthesisDepth := old_ParDepth;
  FBracketDepth := old_BraDepth;
end;

function  TMyParser.PeekCharAfterSymbol : String;
var
  old : PChar;
  old_i : Integer;
  old_ParDepth : Integer;
  old_BraDepth : Integer;
begin
  old := FCurrentChar;
  old_i := FCurrentPos;
  old_ParDepth := FParenthesisDepth;
  old_BraDepth := FBracketDepth;
  try
    Result:= ReadSymbol;
    SkipWhite;
    Result:= PeekChar;
  except
    Result := '';
  end;
  FCurrentChar := old;
  FCurrentPos := old_i;
  FParenthesisDepth := old_ParDepth;
  FBracketDepth := old_BraDepth;
end;

function  TMyParser.ReadConstant : String;
begin
  if PeekChar = '''' then
    begin
      Result := ReadChar;
      while PeekChar <> '''' do
        Insert( ReadChar, Result, Length(Result) );
      Insert( ReadChar, Result, Length(Result) );
    end
  else if PeekChar = '-' then
    begin
      Result := ReadChar;
      Result := Result + ReadSymbol;
    end
  else
    Result := ReadSymbol;
  SkipWhite;
end;

function  TMyParser.ReadType : String;
begin
  Result := ReadConstant;
  if PeekChar = '[' then
    begin
      ReadChar; // pass the '['
      SkipWhite;
      Result := Result + '[' + ReadExpr + ']';
      if ReadChar <> ']' then
        RaiseErr('no "]" matching a "["');
      SkipWhite;
    end
  else if (PeekChar = '.') and (PeekPeekChar = '.' ) then
    begin
      ReadChar; // pass the '.'
      ReadChar; // pass the '.'
      SkipWhite;
      Result := Result + '..' + ReadExpr;
      SkipWhite;
    end;
end;

function  TMyParser.ReadExpr : String;
var
  BraDepth : Integer;

  function IsEndOfExpr : Boolean;
  var
    c : Char;
  begin
    c := PeekChar;
    if (c = '.') and (PeekPeekChar = '.') then
      Result := True
    else if c in [',', ';'] then
      Result := True
    else if (c = ']') and (FBracketDepth = BraDepth ) then
      Result := True
    else
      Result := False;
  end;
begin
  Result := '';
  BraDepth := FBracketDepth;
  while not IsEndOfExpr do
    begin
      // Check if it's a string
      if PeekChar = '''' then
        begin
          repeat
            Insert( ReadChar, Result, Length(Result)+1 );
          until PeekChar = '''';
          Insert( ReadChar, Result, Length(Result)+1 );
        end
      else if PeekChar = '"' then
        begin
          repeat
            Insert( ReadChar, Result, Length(Result)+1 );
          until PeekChar = '"';
          Insert( ReadChar, Result, Length(Result)+1 );
        end
      else
        Insert( ReadChar, Result, Length(Result)+1 );
    end;
  SkipWhite;
  if Result = '' then
    RaiseErr( 'Could not read an expr' );
end;

function  TMyParser.ReadUntil( chars : CharsSet ) : String;
begin
  Result := '';
  while not (PeekChar in chars) do
    begin
      // Check if it's a string
      if PeekChar = '''' then
        begin
          repeat
            Insert( ReadChar, Result, Length(Result)+1 );
          until PeekChar = '''';
          Insert( ReadChar, Result, Length(Result)+1 );
        end
      else if PeekChar = '"' then
        begin
          repeat
            Insert( ReadChar, Result, Length(Result)+1 );
          until PeekChar = '"';
          Insert( ReadChar, Result, Length(Result)+1 );
        end
      else if PeekChar = '{' then
        begin
          repeat
            ReadChar;
          until PeekChar = '}';
          ReadChar;
        end
      else
        Insert( ReadChar, Result, Length(Result)+1 );
    end;
  SkipWhite;
end;

procedure TMyParser.SkipWhite;

  function IsStartOfComment : Boolean;
  begin
    if ((PeekChar = '(') and (PeekPeekChar = '*')) or
       ((PeekChar = '/') and (PeekPeekChar = '/')) or
       (PeekChar = '{') then
      Result := True
    else
      Result := False;
  end;

  procedure SkipComments;
  var
    c : Char;
  begin
    FParsingComment := True;
    try
      if (PeekChar = '/') and (PeekPeekChar = '/' ) then
        SkipEndOfLine
      else if PeekChar = '{' then
        begin
          while ReadChar <> '}' do
            ;
        end
      else if (PeekChar = '(') and (PeekPeekChar = '*') then
        begin
          ReadChar;
          ReadChar;
          repeat
            c := ReadChar;
          until (c = '*') and (PeekChar = ')');
          ReadChar;
        end;
    finally
      FParsingComment := False;
    end;
  end;
begin
  repeat
    while IsWhite( PeekChar ) do
      ReadChar;
    repeat
      SkipComments;
    until not IsStartOfComment;
  until not IsWhite(PeekChar);
end;

procedure TMyParser.SkipEndOfLine;
begin
  while PeekChar <> #13 do
    ReadChar;
  if PeekChar = #10 then
    ReadChar;
end;

procedure TMyParser.SkipSemiColon;
begin
  SkipWhite;
  if PeekChar <> ';' then
    RaiseErr('Could not read a semi-colon' );
  ReadChar;
  SkipWhite;
end;


end.
