hwexprext.pas

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

begin
        if CanReadAs(ttObject) then
        begin
            SetParams;
            Result := FUCFI.AsObject;
        end
        else
            Result := inherited AsObject;
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TExprContext
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
constructor TExprContext.Create(AOwner: TAbstractContextSet; const HashSize: Cardinal);
begin
        inherited Create;
        FOwnerSet := AOwner;
        FHashMap := TStringHashMap.Create(CaseInsensitiveTraits, HashSize);
end;

destructor TExprContext.Destroy;
begin
        FHashMap.Clear;
        FHashMap.Free;
        inherited Destroy;
end;

procedure TExprContext.AddHashNode(const AName: string; P : Pointer);
begin
        FHashMap.Add(AName, P);
end;

function TExprContext.GetCount: Integer;
begin
        Result := FHashMap.Count;
end;

function TExprContext.GetItem(Index: Cardinal): Pointer;
begin
        Result := FHashMap.Items[Index];
end;

function TExprContext.GetItemName(Index: Cardinal): String;
begin
        Result := FHashMap.ItemsName[Index];
end;

function TExprContext.GetData(const AName: string): Pointer;
begin
        Result := FHashMap.Data[AName];
end;

procedure TExprContext.SetData(const AName: string; var P: Pointer);
begin
        FHashMap.Data[AName] := P;
end;

function TExprContext.Remove(const AName: string): Pointer;
begin
        Result := FHashMap.Remove(AName);
end;

function TExprContext.Has(const AName: string): Boolean;
begin
        Result := FHashMap.Has(AName);
end;

function TExprContext.Find(const AName: string; var P): Boolean;
begin
        Result := FHashMap.Find(AName, P);
        //Result := FHashMap.fi
end;

function TExprContext.FindData(const P; var s: string): Boolean;
begin
        Result := FHashMap.FindData(p,s);
end;

procedure TExprContext.RemoveData(Data: Pointer);
begin
        FHashMap.RemoveData(Data);
end;

procedure TExprContext.Clear;
begin
        FHashMap.Clear;
end;

procedure TExprContext.ClearPointers;
begin
        FHashMap.Iterate(nil, Iterate_Dispose);
end;

procedure TExprContext.ClearObjects;
begin
        FHashMap.Iterate(nil, Iterate_FreeObjects);
end;

{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TEnumerationContext
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
constructor TEnumerationContext.Create(AOwner: TAbstractContextSet);
begin
        inherited Create(AOwner, 2047);
end;

destructor TEnumerationContext.Destroy;
begin
        Clear;
        inherited Destroy;
end;

procedure TEnumerationContext.Add(TypeInfo: PTypeInfo);
begin
        if TypeInfo = nil then
            raise EExpression.Create('空指针！不能注册这个类型');

        if TypeInfo.Kind <> tkEnumeration then
            raise EExpression.CreateFmt('%s不是枚举类型',[TypeInfo^.Name])
        else
        begin
            if Self.Owner.Has(TypeInfo^.Name) then
                raise EExpression.CreateFmt('%s已经存在', [TypeInfo^.Name])
            else AddHashNode(TypeInfo^.Name, TypeInfo);
        end;
end;

function TEnumerationContext.GetItem(Index: Cardinal): PTypeInfo;
begin
        Result := PTypeInfo(inherited GetItem(Index));
end;

function TEnumerationContext.IsEnumItem(const Identifier: String): Boolean;
var     i : Cardinal;
begin
        Result := False;
        if Count = 0 then Exit;
        for i := 0 to Count -1 do
        begin
            Result := (GetEnumValue(Items[i], Identifier) <> -1);
            if Result then Exit;
        end;
        Result := False;
end;

{ 给出子项的名，返回子项的类型 }
function TEnumerationContext.ItemType(const Identifier: string): PTypeInfo;
var     i : Integer;
begin
        if Count = 0 then
        begin
            Result := nil;
            Exit;
        end;
        for i := 0 to Count -1 do
        begin
            Result := Items[i];
            if GetEnumValue(Result, Identifier) <> -1 then Exit;
        end;
        Result := nil;
end;

function TEnumerationContext.ItemTypeName(const Identifier: string): string;
var     pti: PTypeInfo;
begin
        Result := '';
        pti := ItemType(Identifier);
        if pti = nil then Exit;
        Result := pti^.Name;
end;

function TEnumerationContext.GetEnumItems(const EnumTypeName: string; var EnumItems: TStrings): Boolean;
var     i : LongInt;
        ptd: PTypeData;
        pti: PTypeInfo;
begin
        if not has(EnumTypeName) then Exit;
        if EnumItems = nil then EnumItems := TStringList.Create
        else EnumItems.Clear;
        
        pti := Data[EnumTypeName];
        ptd := GetTypeData(pti);
        for i := ptd^.MinValue to ptd^.MaxValue do
        begin
            EnumItems.Add(GetEnumName(pti, i));
        end;
        Result := True;
end;

function TEnumerationContext.GetIValue(const Identifier: string): IValue;
begin
        if IsEnumItem(Identifier) then
        begin
            Result := TEnumeratedLiteral.StrCreate(ItemType(Identifier), Identifier);
        end
        else Result := nil;
end;

{ 本Context不需要Delete方法 }
procedure TEnumerationContext.Delete(Index: Cardinal);
begin
end;

procedure TEnumerationContext.Delete(const AName: string);
begin
end;
{ ============================================================================
  >>>>   Class Implementation Begin                                       <<<<
  >>>>   Class Name  : TConstantContext
  >>>>   Description :
  >>>>   Create Date :
  ---------------------------------------------------------------------------- }
constructor TConstantContext.Create(AOwner: TAbstractContextSet);
begin
        inherited Create(AOwner, 1023);
end;

destructor TConstantContext.Destroy;
begin
        Clear;
        inherited Destroy;
end;

function TConstantContext.GetItem(Index: Cardinal): IValue;
begin
        Result := IValue(inherited GetItem(Index));
end;

function TConstantContext.GetData(const AName: string): IValue;
begin
        Result := IValue(inherited GetData(AName));
end;

function TConstantContext.CheckIdentifier(const Ident: string):Boolean;
begin
        if Trim(Ident) = '' then
            raise EExpression.Create('常量名不能为空！');

        //下面的函数在uRptUtils单元中
        //if not IsValidName(Ident) then
        //    raise EExpression.Create('常量名不合法！')

        { 检查是否有重复的名字 }
        if Has(Ident) then
            raise EExpression.Create('常量' + Ident + '已经存在！');
        Result := True;
end;
{ TODO -oCharmer -c表达式解析与运算 :
常数表添加常数的函数有问题。当常量名检查不合格之后的处理不恰当 }
function TConstantContext.Add(const Ident: string;Value: Integer): IValue;
begin
        Result := nil;
        { 检查Ident }
        if CheckIdentifier(Ident) then
        begin
            Result := TIntegerLiteral.Create(Value);
            AddHashNode(Ident, Pointer(Result));
            Result._AddRef;
        end;
end;

function TConstantContext.Add(const Ident: string; Value: Boolean): IValue;
begin
        Result := nil;
        if CheckIdentifier(Ident) then
        begin
            Result := TBooleanLiteral.Create(Value);
            AddHashNode(Ident, Pointer(Result));
            Result._AddRef;
        end;
end;

function TConstantContext.Add(const Ident: string; Value: Double): IValue;
begin
        Result := nil;
        if CheckIdentifier(Ident) then
        begin
            Result := TFloatLiteral.Create(Value);
            AddHashNode(Ident, Pointer(Result));
            Result._AddRef;
        end;
end;

function TConstantContext.Add(const Ident: string; Value: string): IValue;
begin
        Result := nil;
        if CheckIdentifier(Ident) then
        begin
            Result := TStringLiteral.Create(Value);
            AddHashNode(Ident, Pointer(Result));
            Result._AddRef;
        end;
end;

{ 对于管理IValue对象的Context集合来说，IValue对象可以自我释放，不必显式释放它。
  不过这意味着只要有人引用它，那么这些常数节点在从Context表中删除之后仍然可能
  存在。 }
procedure TConstantContext.Clear;
var     i : Integer;
begin
        if Count = 0 then Exit;
        for i := 0 to Count -1 do
        begin
            Items[i]._Release;
        end;
        inherited Clear;
end;

procedure TConstantContext.Delete(Index: Cardinal);
begin
        IValue(Remove(ItemsName[Index]))._Release;
end;

procedure TConstantContext.Delete(const AName: string);
begin
        IValue(Remove(AName))._Release;
end;

procedure TConstantContext.SaveToStream(AStream: TExprStream);
var     i : Integer;
        cName: String;
        cValue: IValue;
begin
        AStream.SaveInteger(Count);

        if Count = 0 then Exit;
        for i := 0 to Count -1 do
        begin
            cName := ItemsName[i];
            cValue := Items[i];