hwexpr.pas

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

                end;
            ttDateTime:
                case Operator of        //
                    opMult, opDivide, opPlus, opMinus:
                        Result:= ttDateTime ;
                    opEq..opGTE: Result := ttBoolean;
                else
                    NotAppropriate;
                end;        // case
            ttInteger:
                case Operator of
                    opNot, opMult, opDiv, opMod, opAnd, opShl, opShr, opPlus, opMinus,
                    opOr, opXor: Result    := ttInteger;
                    opExp, opDivide: Result:= ttFloat;
                    opEq..opGTE: Result    := ttBoolean;
                    else
                        NotAppropriate;
                end;
            ttBoolean:
                case Operator of
                    opNot, opAnd, opOr, opXor, opEq, opNEq: Result:= ttBoolean;
                    else
                        NotAppropriate;
                end;
            ttObject:
                case Operator of
                    opEq, opNEq: Result:= ttBoolean;
                    else
                        NotAppropriate;
                end;
        else
                NotAppropriate
        end
end;
{-----------------------------------------------------------------------------
     >>>>  IncompatibleTypes   <<<<  Begin
-----------------------------------------------------------------------------}
{ 返回类型没有定义，如此避免错误 }
function IncompatibleTypes(T1, T2 : TExprType): TExprType;
begin
        raise EExpression.CreateFmt('类型 %s 与 %s 不兼容',
            [NExprType[T1], NExprType[T2]])
end;

function CommonType( Op1Type, Op2Type : TExprType): TExprType;
begin
        if (Op1Type = ttObject) or (Op2Type = ttObject) then
        begin
            if Op1Type <> Op2Type then
                Result:= IncompatibleTypes(Op1Type, Op2Type)
            else
                Result:= ttObject
        end
        else
        begin
            if Op1Type < Op2Type then
                Result:= Op1Type
            else
                Result:= Op2Type
        end;
end;
{-----------------------------------------------------------------------------
     >>>>  Internal   <<<<  Begin
-----------------------------------------------------------------------------}
procedure Internal( Code : integer);
begin
        raise EExpression.CreateFmt('内部解析错误，位于 %d', [Code])
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TExpression
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
  
constructor TExpression.Create;
begin
        inherited Create;
        Inc(InstanceCount)
end;
{-----------------------------------------------------------------------------
     >>>>  TExpression.Destroy   <<<<  Begin
-----------------------------------------------------------------------------}
destructor TExpression.Destroy;
begin
        Dec(InstanceCount);
        inherited Destroy
end;

function TExpression.AsBoolean: boolean;
begin
        raise EExpression.CreateFmt('%s不能作为逻辑值',
            [NExprType[ExprType]])
end;

function TExpression.AsFloat: double;
begin
        case ExprType of
            ttInteger, ttEnumerated, ttBoolean: Result:= AsInteger;
            ttDateTime: Result := Double(AsDateTime);
        else
                raise EExpression.CreateFmt('%s不能作为浮点值',
                    [NExprType[ExprType]]);
        end
end;

function TExpression.AsInteger: integer;
begin
        case ExprType of
            ttBoolean: Result:= integer(AsBoolean);
        else
                raise EExpression.CreateFmt('%s不能作为整数值',
                    [NExprType[ExprType]]);
        end;
end;

function TExpression.AsDateTime: TDateTime;
begin
        case ExprType of        //
            ttInteger, ttEnumerated, ttBoolean, ttFloat:
                Result := TDateTime(AsFloat);
            ttString:
            begin
                try
                    Result := StrToDateTime(AsString);
                except
                    on e : Exception do
                        raise EExpression.CreateFmt('%s不能作为日期时间型',
                            [NExprType[ExprType]]);
                end;
            end;
        else
            raise EExpression.CreateFmt('%s不能作为日期时间型',
                [NExprType[ExprType]]);
        end;        // case
end;

function TExpression.AsObject: TObject;
begin
        raise EExpression.CreateFmt('%s不能作为对象',
            [NExprType[ExprType]])
end;

function TExpression.AsString: string;
var     vdt: double;
begin
        case ExprType of
            ttObject: Result    := AsObject.ClassName;
            ttFloat: Result     := FloatToStr(AsFloat);
            ttInteger: Result   := IntToStr(AsInteger);
            { 逻辑值是否应该根据某一设定返回字符串？如“真”“假”“是”“否”? }
            ttEnumerated: Result:= GetEnumName(TypeInfo, AsInteger);
            ttBoolean: Result   := NBoolean[AsBoolean];
            ttDateTime:
            begin
                vdt := AsDateTime;
                if trunc(vdt) = 0 then
                    Result := TimeToStr(vdt)
                else
                    Result  := DateTimeToStr(vdt);
            end;
        else
            EExpression.CreateFmt('%s不能作为字符串',
                [NExprType[ExprType]]);
        end
end;

function TExpression.CanReadAs(aType : TExprType): boolean;
var
        et: TExprType;
begin
        et:= ExprType;
        if (et = ttObject) or
            (aType = ttObject) then
            Result:= aType = et
        else
            Result:= aType <= et
end;

function TExpression.TestParameters: boolean;
begin
        Result:= True
end;

function TExpression.TypeInfo: PTypeInfo;
begin
        case ExprType of
            ttString: Result := System.TypeInfo(string);
            ttFloat: Result  := System.TypeInfo(double);
            ttInteger: Result:= System.TypeInfo(integer);
            ttBoolean: Result:= System.TypeInfo(boolean);
        else
                raise EExpression.CreateFmt('无法为 %s 提供类型信息（TypeInfo）', [ClassName])
        end
end;

function TExpression.TypeName: string;
begin
        Result:= TypeInfo^.Name
end;

function TExpression.ClassRef: TClass;
begin
        if ExprType = ttObject then
            Result := AsObject.ClassType
        else Result := nil;
end;
{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TStringLiteral
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
  
constructor TStringLiteral.Create(aAsString : string);
begin
        inherited Create;
        FAsString:= aAsString
end;

function TStringLiteral.AsString: string;
begin
        Result:= FAsString
end;

function TStringLiteral.ExprType: TExprType;
begin
        Result:= ttString
end;


{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TFloatLiteral
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
  
constructor TFloatLiteral.Create(aAsFloat : double);
begin
        inherited Create;
        FAsFloat:= aAsFloat
end;

function TFloatLiteral.AsFloat: double;
begin
        Result:= FAsFloat
end;

function TFloatLiteral.ExprType: TExprType;
begin
        Result:= ttFloat
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TIntegerLiteral
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
  
constructor TIntegerLiteral.Create(aAsInteger : integer);
begin
        inherited Create;
        FAsInteger:= aAsInteger
end;

function TIntegerLiteral.AsInteger: integer;
begin
        Result:= FAsInteger
end;

function TIntegerLiteral.ExprType: TExprType;
begin
        Result:= ttInteger
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TBooleanLiteral
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
  
constructor TBooleanLiteral.Create(aAsBoolean : boolean);
begin
        inherited Create;
        FAsBoolean:= aAsBoolean
end;

function TBooleanLiteral.AsBoolean: boolean;
begin
        Result:= FAsBoolean
end;

function TBooleanLiteral.ExprType: TExprType;
begin
        Result:= ttBoolean
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TEnumeratedLiteral
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
  
constructor TEnumeratedLiteral.Create(aRtti : Pointer; aAsInteger : integer);
begin
        inherited Create(aAsInteger);
        Rtti:= aRtti
end;

constructor TEnumeratedLiteral.StrCreate(aRtti : Pointer; const aVal : string);
var
        i: integer;
begin
        i:= GetEnumValue(PTypeInfo(aRtti), aVal);
        if i = -1 then
            raise EExpression.CreateFmt('%s 不是有效的枚举类型 %s 值',
                [aVal, PTypeInfo(aRtti)^.Name]);
        Create(aRtti, i)
end;

function TEnumeratedLiteral.TypeInfo: PTypeInfo;
begin
        Result:= Rtti
end;

function CheckEnumeratedVal(Rtti : Pointer; const aVal : string): IValue;
begin
        try
            Result:= TEnumeratedLiteral.StrCreate(Rtti, aVal)
            except
                on EExpression do
                    Result:= NIL