hwexprext.pas

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

unit hwExprExt;

{ 本单元是对表达式单元hwExpr的扩展 }
{ 目前对符号表的设计不甚完善。主要采用了GlobalContextSet的形式，应该添加私有符
  号表和定制符号表，便于更灵活地使用表达式 }
{ DONE -oCharmer -c表达式解析与运算 : 注意，所有传递参数的过程中，都没有比较对象类型参数的类是否一致。 }
{ DONE -oCharmer -c表达式解析与运算 :
现在有点糊涂了，有点搞不清楚如何在对象尚不存在的情况下
使用ClassType }
{ TODO -oCharmer -c表达式解析与运算 : 
需要添加：自定义表达式返回值若是对象的话，应规定选择其返回的类，或通过测试来
得到返回的类 }
{ TODO -oCharmer -c表达式解析与运算 :
在表达式模板中通过测试检查返回值类型是否和定义的相一致，若返回对象，检查对象
的类是否是注册类 }
interface
uses
        TypInfo,
        Classes,
        SysUtils,
        hwExpr,
        hwExprExtLiteral,
        Dialogs,
        { uRptUtils, }
        uExprUtils,
        hwStrHashMap;

const
        Err_FuncCanntInteger = '函数%s不能返回整数值';
        Err_FuncCanntFloat   = '函数%s不能返回浮点值';
        Err_FuncCanntBoolean = '函数%s不能返回逻辑值';
        Err_FuncCanntString  = '函数%s不能返回字符串';
        Err_FuncCanntObject  = '函数%s不能返回对象';
        Err_FuncCanntEnum    = '函数%s不能返回枚举值';
type
        TAbstractContextSet = class;
        TExprContextSet = class;
        
        TAbstractExtFunction = class
        Private
            FFuncName: string;
            FResultType: TExprType;
            { 附加的类型名，当类型为对象或枚举时，用于记录类名或枚举名 }
            FAdditionType: String;
            FDescription: String;
            procedure SetFuncName(const AName: string); virtual;
            procedure SetResultType(const AType: TExprType); virtual;
            procedure SetAdditionType(const ATypeName: string);
            function GetParamsCount: integer; virtual; abstract;
            function GetParamsName(Index: integer): string; virtual; abstract;
            function GetParamsType(Index: integer): TExprType; virtual; abstract;
            function GetSyntax: string; virtual;
            function GetTypeName: string;
        Protected
            procedure SaveToStream(AStream: TExprStream); virtual;
            procedure LoadFromStream(AStream: TExprStream); virtual;
        Public
            property ParamsName[Index: integer]: String read GetParamsName;
            property ParamsType[Index: integer]: TExprType read GetParamsType;
        Published
            property ParamsCount: integer read GetParamsCount;
            property FunctionName: string read FFuncName;
            property Description: string read FDescription write FDescription;
            property ResultType: TExprType read FResultType;
            property TypeName: string read GetTypeName;
            property Syntax: string read GetSyntax;
        end;

        { 公式模板************************************************ }
        { 公式模板用于记录用户定义的函数，它包含该函数的表达式及参
          数表。还具有对用户书写的表达式进行语法检查的功能。
          当该公式被引用时，UserFuncContext将根据该公式的模板信息
          创建公式对象供引用者使用。这就是说，该公式不是预编译的，
          而是解释运行的。如果要实现预编译，要重新考虑IValue节点的
          赋值方式。预编译方式事先创建算符、算子节点树，随后向各算
          子赋值就可以进行计算了，预编译方式要快一些。
          参见
                TUserEvalFunction,
                TUserCompileFunction,
                TUCFImplementation (User Compile Function Implamentation)
        }
        TExprTemplate = class(TAbstractExtFunction)
        Private
            FExpression: String; //公式字符串
            FParamList: TList;
            FErrorString: TStrings;   //检查出的错误信息
            FUnknowSymbols: TStrings;
            FNeedCheck: Boolean;
            FIdentContextSet: TAbstractContextSet; //全局ContextSet
            function GetParamsCount: integer; override;
            function GetParamsName(Index: Integer): String; override;
            function GetParamsType(Index: Integer): TExprType; override;
            //function GetSyntax: string; override;
            { 虚拟参数方法，有两个目的：
              1、检查表达式是否有语法错误；
              2、获取未知的符号表 }
            function VirtualParams(Obj: IValue; const Identifier: string;
                ParameterList: TParameterList): IValue;
        Protected
            procedure SaveToStream(AStream: TExprStream); override;
            procedure LoadFromStream(AStream: TExprStream); override;
        Public
            constructor Create(const AFuncName: string;
                               const AResultType: TExprType;
                               const DetailType: String = '');
            destructor Destroy; override;
            { 添加一个参数 }
            function AddParam(const AParamName: string; const AParamType: TExprType): integer;
            function UnknowSymbols: TStrings;
            function UnknowSymbolsCount: integer;
            { 察看标识符是否是参数，若不是返回值为-1，是则返回参数的序号 }
            function IsParam(const Identifier: string): integer;
            procedure DeleteParam(Index: integer); overload;
            procedure DeleteParam(const AParamName: String); overload;
            procedure ClearParams;
            { 检查表达式 }
            function CheckExpression: Boolean;
            function ErrorMessage: string;
            property ParamsName;
            property ParamsType;
        Published
            property FunctionName;
            property ResultType;
            property ParamsCount;
            property Description;
            property Syntax;
            property Expression: string read FExpression write FExpression;
            property IdentContextSet: TAbstractContextSet read FIdentContextSet write FIdentContextSet;
        end;

        { ******************************************************* }
        { 外部定义的函数，用于执行由标识符和参数表指定的功能
          例：定义了如下函数，假定有三个整型参数，返回值是字符串
              function MyFunc(ParameterList: TParameterList): IValue;
              var x,y,z: integer;
              begin
                x := ParameterList.Param[0].AsInteger;
                y := ParameterList.Param[1].AsInteger;
                z := ParameterList.Param[2].AsInteger;
                Result := TStringLiteral.Create(IntToStr(X + Y ^ Z));
              end;
          然后添加到ExtFunctionContext中：
              AddFunc('MyFunc', ttString, [ttInteger, ttInteger, ttInteger]);
          AddFunc的三个参数为函数名、返回值类型、各个参数类型。
        }
        TExtFuncImplementation = function(ParameterList: TParameterList): IValue;

        { 扩展函数定义 }
        TExtFunctionDeclare = class(TAbstractExtFunction)
        Private
            FParams: TList;
            FExtFuncAddr: TExtFuncImplementation;
            function GetParamsCount: integer; override;
            function GetParamsType(Index: integer): TExprType; override;
            function GetParamsName(Index: integer): string; override;
        Public
            constructor Create(const AFuncName: string;
                               const AResultType: TExprType;
                               DefineParams: array of TExprType;
                               ExtFunc: TExtFuncImplementation;
                               const ADescription: String); overload;
            constructor Create(const AFuncName: string;
                               const ParamNames: array of string;
                               const ParamTypes: array of TExprType;
                               const AResultType: TExprType;
                               ExtFunc: TExtFuncImplementation;
                               const ADescription: String); overload;
            destructor Destroy; override;
            property FuncAddress: TExtFuncImplementation read FExtFuncAddr;
            property ParamsType;
            property ParamsName;
        Published
            property FunctionName;
            property ResultType;
            property ParamsCount;
            property Description;
            property Syntax;
        end;

        { 上下文相关表，为提高查询性能，使用了Hash表 }
        TExprContext = class
        Private
            FOwnerSet: TAbstractContextSet;
            FHashMap: TStringHashMap;
            function GetCount: Integer;
            function GetItem(Index: Cardinal):Pointer;
            function GetItemName(Index: Cardinal): String;
            function GetData(const AName: string): Pointer;
            procedure SetData(const AName: string; var P : Pointer);
            procedure AddHashNode(const AName: string; P : Pointer);
        protected
            function FindData(const p{: Pointer}; var s: string): Boolean;
            procedure Delete(Index: Cardinal); overload;virtual;abstract;
            procedure Delete(const AName: string); overload;virtual;abstract;
            procedure ClearPointers;
            procedure ClearObjects;
            function Remove(const AName: String): Pointer; virtual;
            procedure RemoveData(Data: Pointer); virtual;
            property Items[Index: Cardinal]: Pointer read GetItem;
            property ItemsName[Index: Cardinal]: string read GetItemName;
            property Data[const AName: string]: Pointer read GetData write SetData;
        Public
            constructor Create(AOwner: TAbstractContextSet; const HashSize: Cardinal);
            destructor  Destroy; override;
            //function Add() 不用类型的Context表有不同的add方法，此处不定义
            { 对于Delete方法，不同的Context的处理可能不同，有些需要释放指针或
              对象，故此处设为Abstract }
            function Has(const AName: string): Boolean;
            function Find(const AName: string; var P): Boolean;
            procedure Clear; virtual;
            property Owner: TAbstractContextSet read FOwnerSet;
        Published
            property Count: Integer read GetCount;
        end;

        { ---------------------------------------------------------------------
          Class : TEnumerationContext
          可使用的枚举类型表。目前对枚举和类类型的应用还不充分，需要进一步扩展。
          一个可用的方式是通过TTypeKind代替TExprType，用TypeInfo和TypeData来返
          回实际的类型信息，如此可方便地扩充数据类型、检查数据范围。
          -------------------------------------------------------------------- }        
        TEnumerationContext = class(TExprContext)
        Private
            function GetItem(Index: Cardinal): PTypeInfo;
        Protected
            procedure Delete(Index: Cardinal); overload; override;
            procedure Delete(const AName: string); overload; override;
        Public
            constructor Create(AOwner: TAbstractContextSet);
            destructor Destroy; override;
            procedure Add(TypeInfo: PTypeInfo);
            { 是否是注册过的枚举类型的项？ }
            function IsEnumItem(const Identifier: String): Boolean;
            { 给项名，获得该项的枚举类型信息 }
            function ItemType(const Identifier: String): PTypeInfo;
            { 给项名，获得该项的枚举类型名 }
            function ItemTypeName(const Identifier: String): string;
            { 获得类型的子项表 }
            function GetEnumItems(const EnumTypeName: string; var EnumItems: TStrings): Boolean;
            { 返回TEnumeratedLiteral }
            function GetIValue(const Identifier: string): IValue;
            property Items[Index: Cardinal]: PTypeInfo read GetItem;
            property ItemsName;
        Published
            property Count;
        end;
        { ---------------------------------------------------------------------
          Class : TConstantContext
          常量Context
          -------------------------------------------------------------------- }
        TConstantContext = class(TExprContext)
        Private
            function GetItem(Index: Cardinal): IValue;
            function GetData(const AName: string): IValue;
            function CheckIdentifier(const Ident: string): Boolean;
        Protected
            procedure SaveToStream(AStream: TExprStream);
            procedure LoadFromStream(AStream: TExprStream);
        Public
            constructor Create(AOwner: TAbstractContextSet);
            destructor Destroy; override;
            function Add(const Ident: string; Value: Integer): IValue; overload;
            function Add(const Ident: string; Value: Boolean): IValue; overload;
            function Add(const Ident: string; Value: Double): IValue; overload;
            function Add(const Ident: string; Value: String): IValue; overload;
            procedure Delete(Index: Cardinal); overload; override;
            procedure Delete(const AName: string); overload; override;
            procedure Clear; override;
            property Items[Index: Cardinal]: IValue read GetItem;
            property ItemsName;
            property ItemsByName[const AName: string]: IValue read GetData;
        end;

        { 扩展对象访问方法，用于执行对象非Published方法和属性的访问。为每一个
          类需要访问的方法和属性编写一个TExtObjectAccessFunc函数，通过对该函
          数的调用进行访问 }
        TExtObjectAccessFunc = function(Obj: IValue; ParamList: TParameterList): IValue;
        TExtMemberType = (mtProperty, mtMethod);
        TExtMemberVisibleType = (mvPublished, mvPublic);

        PMemberInfo = ^TMemberInfo;
        TMemberInfo = record
            OwnerClass : string;
            MemberName : string;
            DataType   : TExprType;
            MemberType : TExtMemberType;
            VisibleType: TExtMemberVisibleType;
            AccessProc : TExtObjectAccessFunc;
            Params     : TList;
            ClassRef   : TClass; //当成员是对象的时候，设置成员的类类型
        end;

        { ---------------------------------------------------------------------
          Class : TObjectMemberLiteral
          用于对对象成员的访问。对于对象的Published属性，由ObjectProperty提供
          访问，而其他成员如方法和非Published属性，以及不是TPersistent子类的
          对象的成员，由本对象提供访问。
          -------------------------------------------------------------------- }
        TObjectMemberLiteral = class(TFunction)
        Private
            FMemberInfo: PMemberInfo;
            FObject: IValue;
        Public
            constructor Create(Obj: IValue; const MemberInfo: PMemberInfo; PassParams: 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 ExprType: TExprType; override;
            function TestParameters: Boolean; override;
            function ClassRef: TClass; override;
        end;
        { ---------------------------------------------------------------------
          Class : TClassElementsContext
          类成员Context，用于通过专门提供的函数访问对象成员
          -------------------------------------------------------------------- }
        TClassMemberContext = class(TExprContext)
        Private
            FOwnerClassType: TClass;
            function GetClassName: string;
            function GetItem(Index: Cardinal): PMemberInfo;
            function GetMember(const AName: string): PMemberInfo;
            function GetMemberSyntax(const AMemberName: String): string;
        Protected
            procedure Delete(Index: Cardinal); overload; override;
            procedure Delete(const AName: string); overload; override;
        Public
            constructor Create(AOwner: TAbstractContextSet; const ClassRef: TClass);
            destructor Destroy; override;
            procedure AddMember(const MemberName: string;
                                const aType: TExprType;
                                const aMemberType: TExtMemberType;
                                const aVisibleType: TExtMemberVisibleType;
                                const aParamsName: array of string;
                                const aParams: array of TExprType;
                                const AccessProc: TExtObjectAccessFunc;
                                const ClassRef: TClass = nil);