hwexprext.pas

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

        { 将Identifier和内置的参数表以及系统定义的外部符号表进行比较，若是不存
          在的符号，则添加到FUnknowSymbols表中，但同时假定该符号存在，以便于使
          表达式解析进行下去。 }
        { 检查参数 }
{ DONE -oCharmer -c表达式解析与运算 :
VirtualParams中检查参数时需要判断标识符是否是对象成员。对象成员不
可能在ExprContextSet中查找到。 }
        FoundSym := FindParam(Identifier, IdentType);
        if Not FoundSym then
        begin
            if FIdentContextSet <> nil then
            begin
                Result := FIdentContextSet.ExtIdent(Obj, Identifier, ParameterList);
                if Result = nil then
                begin
                    FUnknowSymbols.Add(Identifier);
                    //随便创建一个Literal
                    Result := TIntegerLiteral.Create(0);
                end;
            end;
        end
        else
        begin
                { 注意，这里创建的Literal仅用来使表达式能够执行下去，以便于测
                  试表达式是否正确，此外没有任何其他意义 }
                case IdentType of    //
                  ttObject    : Result := TObjectRef.Create(Self);              //将自身作为返回值
                  ttString    : Result := TStringLiteral.Create(Identifier);
                  ttFloat     : Result := TFloatLiteral.Create(5.5);
                  ttInteger   : Result := TIntegerLiteral.Create(1);
                  ttEnumerated: Result := TEnumeratedLiteral.Create(Typeinfo(TExprType), Integer(IdentType));
                  ttBoolean   : Result := TBooleanLiteral.Create(True);
                end;    // case
        end;
end;

procedure TExprTemplate.SaveToStream(AStream: TExprStream);
var     i: integer;
begin
        inherited SaveToStream(AStream);
        AStream.SaveString(Expression);
        AStream.SaveInteger(ParamsCount);
        if ParamsCount >0 then
        for i := 0 to ParamsCount -1 do
        begin
            AStream.SaveString(ParamsName[i]);
            AStream.SaveInteger(Integer(ParamsType[i]));
        end;
end;

procedure TExprTemplate.LoadFromStream(AStream: TExprStream);
var     i, iCount: integer;
        paraName: string;
        paraType: TExprType;
begin
        inherited LoadFromStream(AStream);
        FExpression := AStream.LoadString;
        iCount := AStream.LoadInteger;
        if iCount > 0 then
        for i := 0 to iCount -1 do
        begin
            paraName := AStream.LoadString;
            paraType := TExprType(AStream.LoadInteger);
            AddParam(paraName, paraType);
        end;
end;
{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TUCFImplementation
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
constructor TUCFImplementation.Create(const ATemplate: TExprTemplate);
var     i : Integer;
begin
        inherited Create;
        FPrivateParams := TList.Create;
        FIdentifierContextSet := ATemplate.IdentContextSet;
        FSyntax := ATemplate.GetSyntax;
        SetResultType(ATemplate.ResultType);
        SetFuncName(ATemplate.FunctionName);
        Description := ATemplate.Description;
        if ATemplate.ParamsCount > 0 then
        for i := 0 to ATemplate.ParamsCount -1 do
        begin
            case ATemplate.ParamsType[i] of        //
                ttObject  :
                    FPrivateParams.Add(TVarLiteral.Create(ATemplate.ParamsName[i], ttObject));

                ttString  :
                    FPrivateParams.Add(TVarLiteral.Create(ATemplate.ParamsName[i], ttString));

                ttFloat   :
                    FPrivateParams.Add(TVarLiteral.Create(ATemplate.ParamsName[i], ttFloat));

                ttInteger :
                    FPrivateParams.Add(TVarLiteral.Create(ATemplate.ParamsName[i], ttInteger));

                ttBoolean :
                    FPrivateParams.Add(TVarLiteral.Create(ATemplate.ParamsName[i], ttBoolean));
            end;        // case
        end;
        FExprValue := CreateExpression(ATemplate.Expression, IDF);
        FExprValue._AddRef;
end;

destructor TUCFImplementation.Destroy;
begin
        if FPrivateParams.Count > 0 then
        FExprValue._Release;
        { 不需要显式释放 }
        //for i := 0 to FPrivateParams.Count -1 do
        //begin
        //    TVarLiteral(FPrivateParams.Items[i]).Free;
        //end;
        FPrivateParams.Free;
        inherited Destroy;
end;

function TUCFImplementation.GetParamsCount: integer;
begin
        Result := FPrivateParams.Count;
end;

function TUCFImplementation.IDF(Obj: IValue; const Identifier: string;
                                ParameterList: TParameterList): IValue;

        function GetParam(const Identifier: string): TVarLiteral;
        var i : Integer;
        begin
            Result := nil;
            if FPrivateParams.Count = 0 then Exit;
            for i := 0 to FPrivateParams.Count -1 do
            begin
                Result := FPrivateParams.Items[i];
                if UpperCase(Result.SymbolName) = UpperCase(Identifier) then Exit;
            end;
            Result := nil;
        end;
begin
        Result := nil;
        { 首先检查是否是参数变量 }
        if (ParameterList = nil) or (ParameterList.Count = 0) then
        begin
            Result := GetParam(Identifier);
            if Result <> nil then Exit;
        end;
        { 继续检查全局Context表 }
        Result := FIdentifierContextSet.ExtIdent(Obj, Identifier, ParameterList);
end;

function TUCFImplementation.GetParamsName(Index: integer): string;
begin
        if (Index < 0) or (Index > FPrivateParams.Count -1) then
            raise EExpression.Create(Err_OutOfIndex);
        Result := TVarLiteral(FPrivateParams.Items[Index]).SymbolName;
end;

function TUCFImplementation.GetParamsType(Index: Integer): TExprType;
begin
        if (Index < 0) or (Index > FPrivateParams.Count -1) then
            raise EExpression.Create(Err_OutOfIndex);
        Result := TVarLiteral(FPrivateParams.Items[Index]).ExprType;
end;

function TUCFImplementation.GetSyntax: string;
begin
        Result := FSyntax;
end;

function TUCFImplementation.Param(Index: integer): TVarLiteral;
begin
        Result := FPrivateParams.Items[Index];
end;

procedure TUCFImplementation.SetParam(index: integer; Value: IValue);
var     param: TVarLiteral;
begin
        if (Index < 0) or (Index > ParamsCount -1)then
            raise EExpression.Create(Err_OutOfIndex);
        param := FPrivateParams.Items[Index];

        case ParamsType[Index] of
        ttBoolean: param.SetValue(Value.AsBoolean);
        ttInteger: param.SetValue(Value.AsInteger);
        ttFloat:   param.SetValue(Value.AsFloat);
        ttString:  Param.SetValue(Value.AsString);
        ttObject:  param.SetValue(Value.AsObject);
        end;
end;

function TUCFImplementation.AsBoolean: Boolean;
begin
        if ResultType = ttBoolean then
            Result := FExprValue.AsBoolean
        else
            Result := FExprValue.AsBoolean;
            //raise EExpression.Create(Err_OnlyBoolean);
end;

function TUCFImplementation.AsInteger: INteger;
begin
        if ResultType = ttInteger then
            Result := FExprValue.AsInteger
        else
            Result := FExprValue.AsInteger;
            //raise EExpression.Create(Err_OnlyInteger);
end;

function TUCFImplementation.AsFloat: double;
begin
        if ResultType = ttFloat then
            Result := FExprValue.AsFloat
        else
            Result := FExprValue.AsFloat;
            //raise EExpression.Create(Err_OnlyFloat);
end;

function TUCFImplementation.AsString: string;
begin
        if ResultType = ttString then
            Result := FExprValue.AsString
        else
            Result := FExprValue.AsString;
            //raise EExpression.Create(Err_OnlyString);
end;

function TUCFImplementation.AsObject: TObject;
begin
        if ResultType = ttObject then
            Result := FExprValue.AsObject
        else
            raise EExpression.Create('不能返回对象');
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TUserCompileFunction
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
constructor TUserCompileFunction.create(const ucfi: TUCFImplementation; AParameterList: TParameterList);
begin
        inherited Create(AParameterList);
        FUCFI := ucfi;
end;

destructor TUserCompileFunction.Destroy;
begin
        inherited Destroy;
end;

//function TUserCompileFunction.CanReadAs(aType: TExprType): Boolean;
//begin
//        Result := aType = FUCFI.ResultType;
//end;

function TUserCompileFunction.ExprType: TExprType;
begin
        Result := FUCFI.ResultType;
end;

function TUserCompileFunction.TestParameters: Boolean;
var     i : Integer;
begin
        Result := False;
        if (ParameterList = nil) then
            if FUCFI.ParamsCount = 0 then
            begin
                Result := True;
                Exit;
            end
            else Exit;

        if ParameterList.Count <> FUCFI.ParamsCount then Exit;

        for i := 0 to ParameterList.Count -1 do
        begin
            if not ParameterList.Param[i].CanReadAs(FUCFI.ParamsType[i]) then Exit;
        end;

        Result := True;
end;

procedure TUserCompileFunction.SetParams;
var i : Integer;
begin
        for i := 0 to FUCFI.ParamsCount -1 do
        begin
            FUCFI.SetParam(i, Self.Param[i]);
        end;
end;

function TUserCompileFunction.AsBoolean: Boolean;
begin
        if CanReadAs(ttBoolean) then
        begin
            SetParams;
            Result := FUCFI.AsBoolean;
        end
        else
            Result := inherited AsBoolean;
end;

function TUsercompilefunction.AsInteger: integer;
begin
        if CanReadAs(ttInteger) then
        begin
            SetParams;
            Result := FUCFI.AsInteger;
        end
        else
            Result := inherited AsInteger;
end;

function TUserCompileFunction.AsFloat: double;
begin
        if CanReadAs(ttFloat) then
        begin
            SetParams;
            Result := FUCFI.AsFloat;
        end
        else
            Result := inherited AsFloat;
end;

function TUserCompileFunction.AsString: string;
begin
        if CanReadAs(ttString) then
        begin
            SetParams;
            Result := FUCFI.AsString;
        end
        else
            Result := inherited AsString;
end;

function TUsercompileFunction.AsObject: TObject;