excelparser.pas

该程序把Excel公式分解为Token序列。

unit ExcelParser;

interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, contnrs, Strutils, RegExpr;
const
  TOK_TYPE_NOOP = 'noop';
  TOK_TYPE_OPERAND = 'operand';
  TOK_TYPE_FUNCTION = 'function';
  TOK_TYPE_SUBEXPR = 'subexpression';
  TOK_TYPE_ARGUMENT = 'argument';
  TOK_TYPE_OP_PRE = 'operator-prefix';
  TOK_TYPE_OP_IN = 'operator-infix';
  TOK_TYPE_OP_POST = 'operator-postfix';
  TOK_TYPE_WSPACE = 'white-space';
  TOK_TYPE_UNKNOWN = 'unknown';

  TOK_SUBTYPE_START = 'start';
  TOK_SUBTYPE_STOP = 'stop';

  TOK_SUBTYPE_TEXT = 'text';
  TOK_SUBTYPE_NUMBER = 'number';
  TOK_SUBTYPE_LOGICAL = 'logical';
  TOK_SUBTYPE_ERROR = 'error';
  TOK_SUBTYPE_RANGE = 'range';

  TOK_SUBTYPE_MATH = 'math';
  TOK_SUBTYPE_CONCAT = 'concatenate';
  TOK_SUBTYPE_INTERSECT = 'intersect';
  TOK_SUBTYPE_UNION = 'union';

type
  TToken = class
  private
    FValue, FType, FSubType: string;
    FPrior: integer;
  protected

  public
    procedure TokenCreate(Value, TokenType, SubType: string);
    function Copy: TToken;
    property Value: string read FValue write FValue;
    property TokenType: string read FType write FType;
    property SubType: string read FSubType write FSubType;
    property Prior: Integer read FPrior write FPrior;

  end;

  TTokens = class(TList)
  private
    FIndex: integer;
  protected

  public
    function addToken(value, Tokentype, subtype: string): TToken;
    procedure addref(token: TToken);
    procedure Reset;
    function BOF: boolean;
    function EOF: boolean;
    function MoveNext: boolean;
    function current: TToken;
    function Next: TToken;
    function previous: TToken;
    property Index: integer read findex write FIndex default -1;
    constructor Create;
    destructor Destroy; override;
  end;

  TTokenStack = class(TList)
  private

  protected

  public
    procedure Push(AToken: TToken);
    function pop: TToken;
    function token: TToken;
    function Value: string;
    function TokenType: string;
    function SubType: string;
  end;

function getTokens(formula: string): TTokens;


implementation

function IsNumeric(AString: string): boolean;
var
  r: Extended;
begin
  Result := True;
  if not TextToFloat(PChar(AString), r, fvExtended) then
    Result := false;
end;

{ TToken }

function TToken.Copy: TToken;
begin
  Result := TToken.Create;
  Result.TokenCreate(self.Value, self.TokenType, self.SubType);
end;

procedure TToken.TokenCreate(Value, TokenType, SubType: string);
begin
  FValue := Value;
  FType := TokenType;
  FSubType := SubType;

end;

{ TTokens }

function TTokens.addToken(value, Tokentype, subtype: string): TToken;
begin
  Result := TToken.Create;
  Result.TokenCreate(value, Tokentype, subtype);
  self.addref(Result);
end;

procedure TTokens.addref(token: TToken);
begin
  self.Add(token);
end;

function TTokens.BOF: boolean;
begin
  Result := Index <= 0;
end;

function TTokens.current: TToken;
begin
  Result := nil;
  if (self.index = -1) then Exit;
  Result := TToken(self.items[index]);
end;

function TTokens.Next: TToken;
begin
  Result := nil;
  if self.EOF then exit;
  result := TToken(self.items[self.index + 1]);
end;

function TTokens.previous: TToken;
begin
  Result := nil;
  if self.Index < 1 then exit;
  result := TToken(self.items[self.index - 1]);
end;

function TTokens.EOF: boolean;
begin
  Result := Index >= (self.Count - 1)
end;

function TTokens.MoveNext: boolean;
begin
  Result := false;
  if self.EOF then Exit;
  Index := Index + 1;
  Result := True;
end;

procedure TTokens.Reset;
begin
  self.Index := -1;
end;

destructor TTokens.Destroy;
begin
  Reset;
  while not Eof do
  begin
    current.Free;
    MoveNext;
  end;
  inherited;
end;

constructor TTokens.Create;
begin
  inherited;
  Index := -1;
end;

{ TTokenStack }

function TTokenStack.pop: TToken;
begin
  Result := nil;
  if self.Count < 1 then Exit;

  Result := TToken.Create;
  Result.TokenCreate('', TToken(items[count - 1]).TokenType, TOK_SUBTYPE_STOP);
  self.Delete(count - 1);
end;

procedure TTokenStack.Push(AToken: TToken);
begin
  self.Add(AToken);
end;

function TTokenStack.token: TToken;
begin
  Result := nil;
  if self.Count < 1 then Exit;
  Result := TToken(items[Count - 1]);
end;

function TTokenStack.TokenType: string;
var
  Atoken: TToken;
begin
  Atoken := self.token;
  Result := '';
  if self.token = nil then exit;
  Result := AToken.TokenType;
end;

function TTokenStack.Value: string;
begin
  Result := '';
  if self.token = nil then exit;
  Result := token.Value;
end;


function TTokenStack.SubType: string;
begin
  Result := '';
  if self.token = nil then exit;
  Result := token.SubType;
end;

function getTokens(formula: string): TTokens;
  function currentChar(Offset: integer): string;
  begin
    Result := midstr(formula, offset, 1);
  end;

  function doubleChar(Offset: integer): string;
  begin
    Result := midstr(formula, offset, 2);
  end;

  function nextChar(Offset: integer): string;
  begin
    Result := midstr(formula, offset + 1, 1);
  end;

  function EOF(Offset: integer): boolean;
  begin
    Result := Offset > length(formula);
  end;

var
  Token: string;
  AToken: TToken;
  Tokens: TTokens;
  TokenStack: TTokenStack;
  Offset: integer;
  inString, inPath, inRange, inError: boolean;
  tokens2: TTokens;
  tempf: Extended;
begin
  tokens := TTokens.Create;
  tokenStack := TTokenStack.Create;

  offset := 1;
  token := '';
  inString := false;
  inPath := false;
  inRange := false;
  inError := false;

  //去掉空格和等于号
  formula := trim(formula); //去掉空格
  if length(formula) > 0 then //去掉等于（=) 号
    if leftStr(formula, 1) = '=' then formula := RightStr(formula, length(formula) - 1);


  while not Eof(Offset) do
  begin
    // double-quoted strings
    // embeds are doubled
    // end marks token
    if inString then {if inString}
    begin
      if CurrentChar(Offset) = '"' then
      begin
        if NextChar(Offset) = '"' then
        begin
          token := token + '"';
          offset := offset + 1;
        end else
        begin
          inString := false;
          tokens.addToken(token, TOK_TYPE_OPERAND, TOK_SUBTYPE_TEXT);
          token := '';
        end;
      end else token := token + currentChar(Offset);
      offSet := Offset + 1;
      CONTINUE;
    end; {if inString}

    // single-quoted strings (links)
    // embeds are double
    // end does not mark a token
    if inPath then begin
      if (currentChar(offset) = '''') then begin
        if (nextChar(offset) = '''') then begin
          token := token + '''';
          offset := offset + 1;
        end else begin
          inPath := false;
        end;
      end else begin
        token := token + currentChar(offset);
      end;
      offset := offset + 1;
      CONTINUE;
    end;

    // bracked strings (range offset or linked workbook name)
    // no embeds (changed to "()" by Excel)
    // end does not mark a token
    if (inRange) then begin
      if (currentChar(offset) = ']') then begin
        inRange := false;
      end;
      token := token + currentChar(offset);
      offset := offset + 1;