hwexpr.pas

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

unit hwExpr;

{ TODO -oCharmer -c表达式解析与运算 : 重写Parser部分，以便于解析更复杂的表达式 }
{ 添加了DateTime类型，以及相关的类型转换DateTime()和Delphi内置的日期时间型函数
  中的21个。 }

interface

uses
        TypInfo,
        Classes,
        SysUtils;

type
        TExprType = (ttObject, ttString, ttDateTime, ttFloat, ttInteger,
                     ttEnumerated, ttBoolean);

        EExpression = class (Exception)
        end;

        IValue = interface (IUnknown)
            function AsBoolean: boolean;
            function AsFloat: double;
            function AsInteger: integer;
            function AsObject: TObject;
            function AsString: string;
            function AsDateTime: TDateTime;
            function CanReadAs(aType : TExprType): boolean;
            function ExprType: TExprType;
            function TestParameters: boolean;
            function TypeInfo: PTypeInfo;
            function ClassRef: TClass;
            function TypeName: string;
        end;
  
        TExpression = class (TInterfacedObject, IValue)
        Protected
            function TestParameters: boolean; Virtual;
        Public
            constructor Create;
            destructor Destroy; Override;
            function AsBoolean: boolean; Virtual;
            function AsFloat: double; Virtual;
            function AsInteger: integer; Virtual;
            function AsObject: TObject; Virtual;
            function AsString: string; Virtual;
            function AsDateTime: TDateTime; Virtual;
            function CanReadAs(aType : TExprType): boolean;
            function ExprType: TExprType; Virtual; Abstract;
            function TypeInfo: PTypeInfo; Virtual;
            function TypeName: string; Virtual;
            function ClassRef: TClass; Virtual;
        end;
  
        TStringLiteral = class (TExpression)
        Private
            FAsString: string;
        Public
            constructor Create(aAsString : string);
            function AsString: string; Override;
            function ExprType: TExprType; Override;
        end;
  
        TFloatLiteral = class (TExpression)
        Private
            FAsFloat: double;
        Public
            constructor Create(aAsFloat : double);
            function AsFloat: double; Override;
            function ExprType: TExprType; Override;
        end;
  
        TIntegerLiteral = class (TExpression)
        Private
            FAsInteger: integer;
        Public
            constructor Create(aAsInteger : integer);
            function AsInteger: integer; Override;
            function ExprType: TExprType; Override;
        end;
  
        TEnumeratedLiteral = class (TIntegerLiteral)
        Private
            Rtti: Pointer;
        Public
            constructor Create(aRtti : Pointer; aAsInteger : integer);
            constructor StrCreate(aRtti : Pointer; const aVal : string);
            function TypeInfo: PTypeInfo; Override;
        end;
  
        TBooleanLiteral = class (TExpression)
        Private
            FAsBoolean: boolean;
        Public
            constructor Create(aAsBoolean : boolean);
            function AsBoolean: boolean; Override;
            function ExprType: TExprType; Override;
        end;

        TDateTimeLiteral = class(TFloatLiteral)
        Public
            constructor Create(aDateTimeValue: TDateTime);
            function AsDateTime: TDateTime; Override;
            function ExprType: TExprType; override;
        end;

        TObjectRef = class (TExpression)
        Private
            FObject: TObject;
            FClassRef: TClass;
        Public
            constructor Create(aObject : TObject; aClassRef: TClass = nil);
            function AsObject: TObject; Override;
            function ExprType: TExprType; Override;
            function TypeInfo: PTypeInfo; Override;
            function ClassRef: TClass; override;
        end;

        { TPersistent对象及其子类的Published属性 }
        TObjectProperty = class(TExpression)
        Private
            Obj: TObject;
            PropInfo: PPropInfo;
            PropType: TExprType;
        Public
            constructor Create(aObj : IValue; const PropName : string);
            function AsBoolean: boolean; Override;
            function AsFloat: double; Override;
            function AsDateTime: TDateTime; Override;
            function AsInteger: integer; Override;
            function AsObject: TObject; Override;
            function AsString: string; Override;
            function ExprType: TExprType; Override;
            function TypeInfo: PTypeInfo; Override;
        end;

        TParameterList = class (TList)
        Private
            function GetAsBoolean(i : integer): boolean;
            function GetAsFloat(i : integer): double;
            function GetAsInteger(i : integer): integer;
            function GetAsObject(i : integer): TObject;
            function GetAsString(i : integer): string;
            function GetAsDateTime(i : Integer): TDateTime;
            function GetExprType(i : integer): TExprType;
            function GetParam(i : integer): IValue;
        Public
            destructor Destroy; Override;
            function AddExpression(e : IValue): integer;
            property AsBoolean[i: integer]: boolean Read GetAsBoolean;
            property AsFloat[i: integer]: double Read GetAsFloat;
            property AsInteger[i: integer]: integer Read GetAsInteger;
            property AsObject[i: integer]: TObject Read GetAsObject;
            property AsString[i: integer]: string Read GetAsString;
            property AsDateTime[i: Integer]: TDateTime read GetAsDateTime;
            property ExprType[i: integer]: TExprType Read GetExprType;
            property Param[i: integer]: IValue Read GetParam;
        end;
  
        TFunction = class (TExpression)
        Private
            FParameterList: TParameterList;
            function GetParam(n : integer): IValue;
        Protected
            property ParameterList: TParameterList read FParameterList write FParameterList;
        Public
            constructor Create(aParameterList : TParameterList);
            destructor Destroy; Override;
            function ParameterCount: integer;
            property Param[n: integer]: IValue Read GetParam;
        end;

        { 用来显示内置函数的东西 }
        TIntFuncList = class
        Private
            FIntFuncList: TList;
            function GetFuncName(Index: integer): String;
            function GetFuncSyntax(Index: integer): String;
            function GetFuncDescription(Index: Integer): String;
            function GetFuncList: TStrings;
            function GetCount: integer;
            function GetTypeCastFuncs: TStrings;
            function GetMathFuncs: TStrings;
            function GetStringFuncs: TStrings;
            function GetDateTimeFuncs: TStrings;
        Protected
            procedure AddFunc(const AFuncName, AFuncSyntax, ADescription: string);
        Public
            constructor Create;
            destructor Destroy; override;
            property Count: Integer read GetCount;
            property FuncName[Index: integer]: string read GetFuncName;
            property Syntax[Index: Integer]: String read GetFuncSyntax;
            property Description[Index: integer]: String read GetFuncDescription;
            property FuncList: TStrings read GetFuncList;
            property TypeCastFuncs: TStrings read GetTypeCastFuncs;
            property MathFuncs: TStrings read GetMathFuncs;
            property StringFuncs: TStrings read GetStringFuncs;
            property DateTimeFuncs: TStrings read GetDateTimeFuncs;
        end;
        
        { 外部定义的方法，用于执行由标识符和参数表指定的功能 }
//        TIdentifierFunction = function (const Identifier : string;
//            ParameterList : TParameterList): IValue of object;
        { 为了能够识别对象成员，将原TIdentifierFunction函数进行了修改，添加了一
          个Obj参数，用于向IDF提供对象以便于识别对象及其成员 }
        TIdentifierFunction = function(obj: IValue; const Identifier: string;
              ParameterList: TParameterList): IValue of Object;
              
        function CheckEnumeratedVal(Rtti : Pointer; const aVal : string): IValue;

        function CreateExpression( const S : string;
                IdentifierFunction : TIdentifierFunction): IValue;

        function FoldConstant( Value : IValue): IValue;

        { 测试使用Parser对象完成解析任务 }
var
        InstanceCount: integer = 0;
        ExprTypeName: array[TExprType] of string =('对象', '字符串', '日期时间',
                    '浮点值', '整数','枚举', '逻辑值');
        ExprIntFuncList: TIntFuncList;
implementation

uses
  Dialogs;

type
        TOperator = ( opNot,
            opExp,
            opMult, opDivide, opDiv, opMod, opAnd, opShl, opShr,
            opPlus, opMinus, opOr, opXor,
            opEq, opNEq, opLT, opGT, opLTE, opGTE);

        TOperators = set of TOperator;

        TUnaryOp = class (TExpression)
        Private
            Operand: IValue;
            OperandType: TExprType;
            Operator: TOperator;
        Public
            constructor Create(aOperator : TOperator; aOperand : IValue);
            function AsBoolean: boolean; Override;
            function AsFloat: double; Override;
            function AsInteger: integer; Override;
            function ExprType: TExprType; Override;
        end;
  
        TBinaryOp = class (TExpression)
        Private
            Operand1: IValue;
            Operand2: IValue;
            OperandType: TExprType;
            Operator: TOperator;
        Public
            constructor Create(aOperator : TOperator; aOperand1, aOperand2 : IValue);
            function AsBoolean: boolean; Override;
            function AsFloat: double; Override;
            function AsInteger: integer; Override;
            function AsString: string; Override;
            function AsDateTime: TDateTime; override;
            function ExprType: TExprType; Override;
        end;

        TRelationalOp = class (TExpression)
        Private
            Operand1: IValue;
            Operand2: IValue;
            OperandType: TExprType;
            Operator: TOperator;
        Public
            constructor Create(aOperator : TOperator; aOperand1, aOperand2 : IValue);
            function AsBoolean: boolean; Override;
            function AsFloat: double; Override;
            function AsInteger: integer; Override;
            function AsString: string; Override;
            function AsDateTime: TDateTime; Override;
            function ExprType: TExprType; Override;
        end;

const
        MaxStringLength   = 255; { 最大字符串长度 }
        Digits            = ['0'..'9'];

        { 尝试添加对中文的支持。采用判断#127..#255的方式可能存在某些隐患。应当
          将字符串转换成WideString或UnicodeString，然后判断字符码是否在指定的
          字符集区域内，由此判断各个字符的实际内容。 }
        //PrimaryIdentChars = ['a'..'z', 'A'..'Z', '_'];
        PrimaryIdentChars = ['a'..'z', 'A'..'Z', '_', #127..#255];
        IdentChars        = PrimaryIdentChars + Digits;

        //表达式类型
        NExprType: array[TExprType] of string =
            ('Object', 'String', 'DateTime', 'Float', 'Integer',
             'Enumerated', 'Boolean');
        //操作符类型
        NOperator: array[TOperator] of string =
            ( 'opNot',
              'opExp',
              'opMult', 'opDivide', 'opDiv', 'opMod', 'opAnd', 'opShl', 'opShr',
              'opPlus', 'opMinus', 'opOr', 'opXor',
              'opEq', 'opNEq', 'opLT', 'opGT', 'opLTE', 'opGTE');

        UnaryOperators       = [opNot];
        ExpOperator          = [opExp];
        MultiplyingOperators = [opMult, opDivide, opDiv, opMod, opAnd, opShl, opShr];
        AddingOperators      = [opPlus, opMinus, opOr, opXor];
        RelationalOperators  = [opEq, opNEq, opLT, opGT, opLTE, opGTE];

        NBoolean: array[boolean] of string[5] = ('FALSE', 'TRUE');

{-----------------------------------------------------------------------------
     >>>>  ResultType   <<<<  Begin
-----------------------------------------------------------------------------}
function ResultType( Operator : TOperator; OperandType : TExprType): TExprType;
        procedure NotAppropriate;
        begin
            Result:= ttString;
            raise EExpression.CreateFmt( '算符 %s 与算子 %s 类型不兼容',
                [NOperator[Operator], NExprType[OperandType]])
        end;
begin
        case OperandType of
            ttString:
                case Operator of
                    opPlus: Result     := ttString;
                    opEq..opGTE: Result:= ttBoolean;
                    else
                        NotAppropriate;
                end;
            ttFloat:
                case Operator of
                    opExp, opMult, opDivide, opPlus, opMinus: Result:= ttFloat;
                    opEq..opGTE: Result                             := ttBoolean;
                    else
                        NotAppropriate;