hwexprext.pas

用于Delphi程序中嵌入公式解析

            property FunctionName;
            property ResultType;
            property Description;
            property Syntax;
        end;

        { 预编译型用户函数算子 }
        TUserCompileFunction = class(TFunction)
        Private
            FUCFI: TUCFImplementation;
            procedure SetParams;
        Public
            constructor Create(const ucfi: TUCFImplementation; AParameterList: TParameterList);
            destructor Destroy; override;
            function AsBoolean: Boolean; override;
            function AsInteger: integer; override;
            function AsFloat: double; override;
            function AsString: string; override;
            function AsObject: TObject; override;
            //function CanReadAs(aType: TExprType): Boolean;
            function ExprType: TExprType; override;
            function TestParameters: Boolean; override;
        end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TExtExprFunction
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
constructor TUserEvalFunction.Create(const ATemplate: TExprTemplate; ParameterList: TParameterList);
begin
        if ATemplate = nil then
            raise EExpression.Create('没有指定函数模板，无法创建该函数执行体');

        inherited Create;
        Self.FTemplate := ATemplate;
        FPrivateParams := ParameterList;
        FValue := CreateExpression(ATemplate.Expression, Self.IDF);
end;

destructor TUserEvalFunction.Destroy;
begin
        FPrivateParams.Free;
        inherited Destroy;
end;


function TUserEvalFunction.IDF(Obj: IValue; const Identifier: string;
                               ParameterList: TParameterList): IValue;
var     i : Integer;
begin
        Result := nil;
        { 通过了测试的表达式函数中的符号都应该存在，符号检查一般都没有问题。 }
        if Identifier = FTemplate.FunctionName then
            raise EExpression.create('不支持递归调用！');

        { 首先检查是否是私有变量 }
        i := FTemplate.IsParam(Identifier);
        if i <> -1 then
        begin
            Result := FPrivateParams.Param[i];
            Exit;
        end
        else
            Result := FTemplate.IdentContextSet.ExtIdent(Obj, Identifier, ParameterList);
end;

function TUserEvalFunction.AsBoolean: Boolean;
begin
        if FTemplate.ResultType = ttBoolean then
            Result := FValue.AsBoolean
        else
            Result := Inherited AsBoolean;
end;

function TUserEvalFunction.AsFloat: Double;
begin
        if FTemplate.ResultType = ttFloat then
            Result := FValue.AsFloat
        else
            Result := Inherited AsFloat;
end;

function TUserEvalFunction.AsInteger: integer;
begin
        if FTemplate.ResultType = ttInteger then
            Result := FValue.AsInteger
        else
            Result := inherited AsInteger;
end;

function TUserEvalFunction.AsObject: TObject;
begin
        if FTemplate.ResultType = ttObject then
            Result := FValue.AsObject
        else
            raise EExpression.CreateFmt(Err_FuncCanntObject, [FTemplate.FunctionName]);
end;

function TUserEvalFunction.AsString: string;
begin
        if FTemplate.ResultType = ttString then
            Result := FValue.AsString
        else
            Result := inherited AsString;
end;

function TUserEvalFunction.ExprType: TExprType;
begin
        Result := FTemplate.ResultType;
end;

{ 检测参数是否有效，由Parser调用 }
function TUserEvalFunction.TestParameters: Boolean;
var     i : Integer;
begin
        Result := False;
        if (FPrivateParams = nil) and (FTemplate.ParamsCount <> 0) then Exit;

        if (FPrivateParams = nil) and (FTemplate.ParamsCount = 0) then
        begin
            Result := True;
            Exit;
        end;

        if FPrivateParams.Count <> FTemplate.ParamsCount then Exit;
        { 逐一检查参数类型是否与定义的一致 }
        for i := 0 to FTemplate.ParamsCount -1 do
        begin
            if not FPrivateParams.Param[i].CanReadAs(FTemplate.ParamsType[i]) then Exit
        end;

        Result := True;
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TExprTemplate
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
constructor TExprTemplate.Create(const AFuncName: string;
                                 const AResultType: TExprType;
                                 const DetailType: string = '');
begin
        inherited Create;
        SetFuncName(AFuncName);
        SetResultType(AResultType);
        FErrorString := TStringList.Create;
        FParamList := TList.Create;
        FUnknowSymbols := TStringList.Create;
        FNeedCheck := True;
        SetAdditionType(DetailType);
end;

destructor TExprTemplate.Destroy;
begin
        ClearParams;
        FParamList.Free;
        FErrorString.Free;
end;

function TExprTemplate.GetParamsCount: integer;
begin
        Result := FParamList.Count;
end;

function TExprTemplate.AddParam(const AParamName: string; const AParamType: TExprType): Integer;
var
        pparam: PParamRec;
begin
        New(PParam);
        pparam^.ParamName := AParamName;
        pparam^.ParamType := AParamType;
        FParamList.Add(PParam);
        FNeedCheck := True;
        Result := FParamList.Count;
end;

function TExprTemplate.IsParam(const Identifier: string): integer;
var     i : Integer;
        pParam: PParamRec;
begin
        Result := -1;
        if Self.FParamList.Count > 0 then
        for i := 0 to FParamList.Count -1 do
        begin
            pparam := PParamRec(FParamList.Items[i]);
            if UpperCase(pparam^.ParamName) = UpperCase(Identifier) then
            begin
                Result := i;
                Exit;
            end;
        end;
end;

function TExprTemplate.GetParamsName(Index: integer): String;
begin
        if (Index < 0) or (Index > FParamList.Count -1 ) then
            raise EExpression.Create('索引超出范围');
        Result := PParamRec(FParamList.Items[Index])^.ParamName;
end;

function TExprTemplate.GetParamsType(Index: Integer): TExprType;
begin
        if (Index < 0) or (Index > FParamList.Count -1 ) then
            raise EExpression.Create('索引超出范围');
        Result := PParamRec(FParamList.Items[Index])^.ParamType;
end;

function TExprTemplate.UnknowSymbols: TStrings;
begin
        if FNeedCheck then CheckExpression;
        Result := FUnknowSymbols;
end;

function TExprTemplate.UnknowSymbolsCount: integer;
begin
        if FNeedCheck then CheckExpression;
        Result := FUnknowSymbols.Count;
end;

function TExprTemplate.CheckExpression: Boolean;
var     testValue: IValue;
begin
        Result := False;
        FErrorString.Clear;
        FUnknowSymbols.Clear;
        FNeedCheck := True;
        if Trim(FExpression) = '' then
        begin
            FErrorString.Add('没有设置表达式');
            Result := True;
            FNeedCheck := False;
            Exit;
        end;

        try
            testValue := CreateExpression(FExpression, VirtualParams);
            { 检查返回值类型是否与定义的一致 }
            if testVAlue.ExprType <> Self.ResultType then
            begin
                Result := False;
                FErrorString.Add('表达式返回结果与函数定义中的返回结果不一致');
                FNeedCheck := True;
            end
            else
                Result := True;
            { 检查结束 }
            if (FUnknowSymbols.Count = 0) then
                FNeedCheck := False
            else
                FErrorString.Add('表达式中含有未知符号');
        except
            on e : EExpression do
            begin
                FErrorString.Add('语法错误：' + e.Message);
            end;

            on e : Exception do
            begin
                FErrorString.Add('错误:' + e.Message);
            end;
        end;
end;

function TExprTemplate.ErrorMessage: String;
begin
        Result := FErrorString.Text;
end;

procedure TExprTemplate.DeleteParam(Index: integer);
begin
        if (Index >=0) and (Index < (FParamList.Count -1)) then
        begin
            dispose(FParamList.Items[Index]);
            FParamList.Delete(Index);
        end
        else
            raise EExpression.Create('索引值超出范围');
end;

procedure TExprTemplate.DeleteParam(const AParamName: String);
var     i : Integer;
        uName: string;
begin
        if FParamList.Count = 0 then Exit;
        uName := Uppercase(AParamName);
        for i := 0 to FParamList.Count -1 do
        begin
            if UpperCase(PParamRec(FParamList.Items[i])^.ParamName) = uName then
            begin
                DeleteParam(i);
                Exit;
            end;
        end;
end;

procedure TExprTemplate.ClearParams;
var     i : Integer;
begin
        if FParamList.Count = 0 then Exit;
        for i := FParamList.Count -1 Downto 0 do
        begin
            Dispose(FParamList.Items[i]);
            FParamList.Delete(i);
        end;        // while
end;

{ 进行表达式检查的时候，需要向表达式解释解析器不识别的符号，因此本函数可以获取
  未知的符号 }
function TExprTemplate.VirtualParams(Obj: IValue; const Identifier: string;
                                     ParameterList: TParameterList): IValue;
var     //i : Integer;
        IdentType: TExprType;
        FoundSym: Boolean;

        function FindParam(const Identifier: string; Var AExprType: TExprType): Boolean;
        var i : Integer;
        begin
            Result := False;
            if FParamList.Count =0 then Exit;
            for i := 0 to FParamList.Count -1 do
            begin
                if UpperCase(PParamRec(FParamList.Items[i])^.ParamName) = UpperCase(Identifier) then
                begin
                    Result := True;
                    AExprType := PParamRec(FParamList.Items[i])^.ParamType;
                    Exit;
                end;
            end;
        end;
begin
        Result := nil;
        FoundSym := False;
        { 首先检查是否出现了递归调用 }
        if Identifier = FFuncName then
            raise EExpression.Create('不支持递归调用');