jparser.pas.svn-base

支持自定义语法高亮显示的编辑器控件

unit jparser;

interface
uses
  Classes, SysUtils, EasyParser;
type

  TElementScope = (sPrivate, sPublic, sGlobal, sExported, sEnum, sParam, sLocalVar, sField, sUnknown);

  TClassDefinitionType = (dtClass, dtEnum, dtFunction, dtSimpleType);

  TElementInfo = class
  private
    FLineNo   : integer;
    FName     : string;
    FInfoType : string;
    FScope    : TElementScope;
  private
    procedure Added;
    procedure Deleted;
  public
    destructor Destroy; override;
    function  GetParentList : TStrings; virtual;
    property LineNo : integer read FLineNo write FLineNo;
    property Name : string read FName write FName;
    property Scope : TElementScope read FScope write FScope;
    property InfoType : string read FInfoType write FInfoType;
  end;

  TConstantInfo = class(TElementInfo)
  private
    FValue : string;
  public
    function GetParentList : TStrings; override;
    property Value : string read FValue write FValue;
  end;

  TVariableInfo = class(TElementInfo)
  public
    function  GetParentList : TStrings; override;
  end;

  TFunctionInfo = class(TElementInfo)
  private
    FReturnType   : string;
    FParams       : TStrings;
    FLocalVars    : TStrings;
    FStartPos     : integer;
    FEndPos       : integer;
    procedure SetParams(Value : TStrings);
    procedure SetLocalVars(Value : TStrings);
  public
    constructor Create;
    destructor Destroy; override;
    function  ParamText : string;
    function GetParentList : TStrings; override;
    property StartPos : integer read FStartPos write FStartPos;
    property EndPos : integer read FEndPos write FEndPos;
    property ReturnType : string read FReturnType write FReturnType;
    property Params : TStrings read FParams write SetParams;
    property LocalVars : TStrings read FLocalVars write SetLocalVars;
  end;

  TUnitInfo = class
  private
    FVariables    : TStrings;
    FFunctions    : TStrings;
    FConstants    : TStrings;
    FParser       : TEasyEditorParser;
    function  NextValidToken : integer;
    function  NextValidTokenStr : string;
    procedure ProcessFunction(const s : string; SkipToEnd : boolean);
    procedure ProcessVariable(const s : string);
    function  GetLinePos : integer;
  public
    constructor Create;
    destructor Destroy; override;
    procedure  ParseStrings(AStrings : TStrings);
    procedure ReparseStrings(Strings : TStrings);
    function  AddFunction(const AName : string) : TFunctionInfo;
    function  AddConst(const AName : string; AOwner : TElementInfo) : TConstantInfo;
    function  AddVariable(const AName : string; AOwner : TElementInfo) : TVariableInfo;
    function AddParam(const AName : string; AOwner : TFunctionInfo) : TVariableInfo;
    function IndexOf(const s : string) : TElementInfo;
    property Variables : TStrings read FVariables;
    property Functions : TStrings read FFunctions;
    property Constants : TStrings read FConstants;
    property Parser : TEasyEditorParser read FParser write FParser;
  end;

function UnitInfo : TUnitInfo;

implementation
uses
  EasyUtils;
type
  TMParser = class(TEasyEditorParser);

var
  FUnitInfo : TUnitInfo = nil;
const
  tnone = 0;
  tstring = 1;
  tcomment = 2;
  tident = 3;
  tinteger = 4;
  tfloat = 5;
  tresword = 6;
  twhitespace = 9;

  sFuncStr = 'function';
  sVarStr = 'var';
  sGroupBegin = '{';
  sGroupEnd = '}';
  sLeftBracket = '(';
  sRightBracket = ')';

procedure ClearStrings(Strings : TStrings);
var
  i : integer;
begin
  with Strings do
  begin
    for i := Count - 1 downto 0 do
      Objects[i].Free;
    Clear;
  end;
end;

procedure FreeStrings(var Strings : TStrings);
begin
  ClearStrings(Strings);
  Strings.Free;
  Strings := nil;
end;

function UnitInfo : TUnitInfo;
begin
  if FUnitInfo = nil then
    FUnitInfo := TUnitInfo.Create;
  result := FUnitInfo;
end;

procedure TElementInfo.Added;
var
  List : TStrings;
begin
  if FName = '' then
    exit;
  Deleted;
  List := GetParentList;
  if List <> nil then
    List.AddObject(Name, Self);
end;

procedure TElementInfo.Deleted;
var
  List : TStrings;
  i    : integer;
begin
  if FName = '' then
    exit;
  List := GetParentList;
  if List <> nil then
    with List do
    begin
      i := IndexOf(FName);
      if i >= 0 then
        Delete(i);
    end;
end;

destructor TElementInfo.Destroy;
begin
  Deleted;
  inherited Destroy;
end;

function  TElementInfo.GetParentList : TStrings;
begin
  result := nil;
end;

function  TConstantInfo.GetParentList : TStrings;
begin
  if Scope in [sGlobal, sPrivate, sPublic, sExported] then
    result :=  UnitInfo.Constants
  else
    result := nil;
end;

function  TVariableInfo.GetParentList : TStrings;
begin
  if Scope in [sGlobal, sPrivate, sPublic, sExported] then
    result :=  UnitInfo.Variables
  else
    result := nil;
end;

procedure TFunctionInfo.SetParams(Value : TStrings);
begin
  FParams.Assign(Value);
end;


procedure TFunctionInfo.SetLocalVars(Value : TStrings);
begin
  FLocalVars.Assign(Value);
end;

constructor TFunctionInfo.Create;
begin
  inherited Create;
  FParams := TStringList.Create;
  FLocalVars := TStringList.Create;
end;

destructor TFunctionInfo.Destroy;
begin
  FreeStrings(FParams);
  FreeStrings(FLocalVars);
  inherited Destroy;
end;

function  TFunctionInfo.ParamText : string;
var
  i : integer;
begin
  result := '';
  for i := 0 to Params.Count - 1  do
    with TVariableInfo(Params.Objects[i]) do
    begin
      if result <> '' then
        result := result + ',';
//      result := result + FInfoType + ' ' + FName;
      if FInfoType <> '' then
        result := result + FInfoType + ' ' + FName
      else
        result := result + FName;
    end;
   result := '(' + result + ')';
end;


function  TFunctionInfo.GetParentList : TStrings;
begin
  result := UnitInfo.Functions
end;

constructor TUnitInfo.Create;
begin
  inherited Create;
  FVariables := CreateSortedStrings;
  FFunctions := CreateSortedStrings;
  FConstants := CreateSortedStrings;
end;

destructor TUnitInfo.Destroy;
begin
  FreeStrings(FVariables);
  FreeStrings(FFunctions);
  FreeStrings(FConstants);
  inherited Destroy;
end;


function TUnitInfo.IndexOf(const s : string) : TElementInfo;
var
  AInfo : TElementInfo;

  function _Check(Strings : TStrings) : boolean;
  var
    Index : integer;
  begin
    Index := Strings.IndexOf(s);
    result := Index >= 0;
    if result then
      AInfo := TElementInfo(Strings.Objects[Index]);
  end;


begin
  if _Check(FVariables) or _Check(FFunctions) or _Check(Constants) then
    result := AInfo
  else
    result := nil;
end;

function  TUnitInfo.AddFunction(const AName : string) : TFunctionInfo;
begin
  if AName = '' then
  begin
    result := nil;
    Exit;
  end;
  result := TFunctionInfo.Create;
  with result do
  begin
    Name := AName;
    Scope := sPublic;
    Added;
  end;
end;

function TUnitInfo.AddParam(const AName: string; AOwner: TFunctionInfo): TVariableInfo;
begin
  if (AName = '') or (AOwner = nil) or not (AOwner is TFunctionInfo) then
  begin
    result := nil;
    exit;
  end;
  result := TVariableInfo.Create;
  with result do
  begin
    Name := AName;
    Scope := sParam;
    AOwner.Params.AddObject(Name, result);
  end;
end;

function  TUnitInfo.AddVariable(const AName : string; AOwner : TElementInfo) : TVariableInfo;
begin
  if (AName = '')  then
  begin
    result := nil;
    exit;
  end;
  result := TVariableInfo.Create;
  with result do
  begin
    Name := AName;
    Scope := sPublic;
    if AOwner = nil then
      Added
    else
    if AOwner is TFunctionInfo then
    begin
      TFunctionInfo(AOwner).LocalVars.AddObject(Name, result);
      result.Scope := sLocalVar;
    end;
  end;
end;

function  TUnitInfo.AddConst(const AName : string; AOwner : TELementInfo) : TConstantInfo;
begin
  if (AName = '') then
  begin
    result := nil;
    Exit;
  end;
  result := TConstantInfo.Create;
  with result do
  begin
    Name := AName;
    Scope := sPublic;
    if AOwner = nil then
      Added
    else
    if AOwner is TFunctionInfo then
    begin
      TFunctionInfo(AOwner).LocalVars.AddObject(Name, result);
      result.Scope := sLocalVar;
    end;
  end;
end;

procedure  TUnitInfo.ParseStrings(AStrings : TStrings);
var
  s : string;
begin
  if FParser = nil then
    Exit;
  with FParser do
  begin
    Strings := AStrings;
    Reset;
    while not EndOfSource do
    begin
      case NextValidToken of
        tresword :
        begin
          s := TokenString;
          if s = sFuncStr then
            ProcessFunction(NextValidTokenStr, true)
          else
          if (CompareText(s, sVarStr) = 0) then
            ProcessVariable(NextValidTokenStr);
        end;
      end;
    end;
    Strings := nil;
  end;
end;


procedure TUnitInfo.ReparseStrings(Strings : TStrings);
begin
  ClearStrings(FVariables);
  ClearStrings(FFunctions);
  ClearStrings(FConstants);
  if Strings <> nil then
    ParseStrings(Strings);
end;

function TUnitInfo.NextValidToken : integer;
begin
  repeat
    result := FParser.NextToken;
  until (result <> tComment) and (result <> tNone) and (result <> twhitespace);
end;

function  TUnitInfo.NextValidTokenStr : string;
begin
  NextValidToken;
  result := FParser.TokenString;
end;

procedure TUnitInfo.ProcessFunction(const s : string; SkipToEnd : boolean);
var
  i     : integer;
  Info  : TFunctionInfo;
  Count : integer;
  Temp  : string;

  procedure ParseParams(Info : TFunctionInfo);
  begin
    FParser.NextToken;
    Temp := FParser.TokenString;
    if Temp <> sLeftBracket then
      exit;
    with FParser do
      while not EndOfSource do
      begin
        i := NextToken;
        Temp := TokenString;
        if Temp = sRightBracket then
          exit;
        if (i <> tComment) and (i <> tNone) and (i <> twhitespace) then
          AddParam(Temp, Info);
      end;
  end;

  procedure ParseLocalVars(Info : TFunctionInfo);
  var
    VarAdded: boolean;
  begin
   VarAdded := false;
    with FParser do
      while not EndOfSource do
      begin
        i := NextToken;
        Temp := TokenString;
        if Temp = ',' then
          VarAdded := false;
        if Temp = ';' then
          exit;
        if (i <> tComment) and (i <> tNone) and (i <> twhitespace) then
          begin
            if VarAdded then
              exit;
            AddVariable(Temp, info);
            VarAdded := true;
          end;
      end;
  end;

begin
  Info := UnitInfo.AddFunction(s);
  if Info = nil then
    Exit;
  Info.LineNo := GetLinePos;
  ParseParams(Info);
  if SkipToEnd then
  begin
    Info.StartPos := GetLinePos;
//    ParseLocalVars(Info);
    Count := 0;
    with FParser do
      while not EndOfSource do
      begin
        NextToken;
        Temp := TokenString;
        if Temp = sVarStr then
          ParseLocalVars(Info);
        if Temp = sGroupBegin then
          Inc(Count)
        else
        if Temp = sGroupEnd then
        begin
          Dec(Count);
          if Count = 0 then
            Break;
        end;
      end;
    Info.EndPos := GetLinePos;
  end;  
end;

procedure TUnitInfo.ProcessVariable(const s : string);
var
  Info : TVariableInfo;
begin
  Info := UnitInfo.AddVariable(s, nil);
  if Info = nil then
    Exit;
  Info.LineNo := GetLinePos;
end;

function TUnitInfo.GetLinePos : integer;
begin
  result := TMParser(FParser).LineIndex;
end;

initialization

finalization
  FUnitInfo.Free;

end.