jvinterpreter.pas

East make Tray Icon in delphi

begin
  Result := VariantPointerInstance.VarType;
end;

function varSet: TVarType;
begin
  Result := VariantSetInstance.VarType;
end;

function varArray: TVarType;
begin
  Result := VariantArrayInstance.VarType;
end;

{$ENDIF COMPILER6_UP}

//=== EJvInterpreterError ====================================================

function LoadStr2(const ResID: Integer): string;
var
  I: Integer;
begin
  for I := Low(JvInterpreterErrors) to High(JvInterpreterErrors) do
    if JvInterpreterErrors[I].ID = ResID then
    begin
      Result := JvInterpreterErrors[I].Description;
      Break;
    end;
end;

procedure JvInterpreterError(const AErrCode: Integer; const AErrPos: Integer);
begin
  raise EJvInterpreterError.Create(AErrCode, AErrPos, '', '');
end;

procedure JvInterpreterErrorN(const AErrCode: Integer; const AErrPos: Integer;
  const AErrName: string);
begin
  raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName, '');
end;

procedure JvInterpreterErrorN2(const AErrCode: Integer; const AErrPos: Integer;
  const AErrName1, AErrName2: string);
begin
  raise EJvInterpreterError.Create(AErrCode, AErrPos, AErrName1, AErrName2);
end;

constructor EJvInterpreterError.Create(const AErrCode: Integer;
  const AErrPos: Integer; const AErrName1, AErrName2: string);
begin
  inherited Create('');
  FErrCode := AErrCode;
  FErrPos := AErrPos;
  FErrName1 := AErrName1;
  FErrName2 := AErrName2;
  { function LoadStr don't work sometimes :-( }
  Message := Format(LoadStr2(ErrCode), [ErrName1, ErrName2]);
  FErrMessage := Message;
end;

procedure EJvInterpreterError.Assign(E: Exception);
begin
  Message := E.Message;
  if E is EJvInterpreterError then
  begin
    FErrCode := (E as EJvInterpreterError).ErrCode;
    FErrPos := (E as EJvInterpreterError).ErrPos;
    FErrName1 := (E as EJvInterpreterError).ErrName1;
    FErrName2 := (E as EJvInterpreterError).ErrName2;
    FErrMessage := (E as EJvInterpreterError).ErrMessage;
  end;
end;

procedure EJvInterpreterError.Clear;
begin
  FExceptionPos := False;
  FErrName1 := '';
  FErrName2 := '';
  FErrPos := -1;
  FErrLine := -1;
  FErrUnitName := '';
end;

function V2O(const V: Variant): TObject;
begin
  Result := TVarData(V).VPointer;
end;

function O2V(O: TObject): Variant;
begin
  TVarData(Result).VType := varObject;
  TVarData(Result).VPointer := O;
end;

function V2C(const V: Variant): TClass;
begin
  Result := TVarData(V).VPointer;
end;

function C2V(C: TClass): Variant;
begin
  TVarData(Result).VType := varClass;
  TVarData(Result).VPointer := C;
end;

function V2P(const V: Variant): Pointer;
begin
  Result := TVarData(V).VPointer;
end;

function P2V(P: Pointer): Variant;
begin
  TVarData(Result).VType := varPointer;
  TVarData(Result).VPointer := P;
end;

function R2V(const ARecordType: string; ARec: Pointer): Variant;
begin
  TVarData(Result).VPointer := TJvInterpreterRecHolder.Create(ARecordType, ARec);
  TVarData(Result).VType := varRecord;
end;

function V2R(const V: Variant): Pointer;
begin
  if (TVarData(V).VType <> varRecord) or
    not (TObject(TVarData(V).VPointer) is TJvInterpreterRecHolder) then
    JvInterpreterError(ieROCRequired, -1);
  Result := TJvInterpreterRecHolder(TVarData(V).VPointer).Rec;
end;

function P2R(const P: Pointer): Pointer;
begin
  if not (TObject(P) is TJvInterpreterRecHolder) then
    JvInterpreterError(ieROCRequired, -1);
  Result := TJvInterpreterRecHolder(P).Rec;
end;

function S2V(const I: Integer): Variant;
begin
  Result := I;
  TVarData(Result).VType := varSet;
end;

function V2S(V: Variant): Integer;
var
  I: Integer;
begin
  if (TVarData(V).VType and System.varArray) = 0 then
    Result := TVarData(V).VInteger
  else
  begin
    { JvInterpreter thinks about all function parameters, started
      with '[' symbol that they are open arrays;
      but it may be set constant, so we must convert it now }
    Result := 0;
    for I := VarArrayLowBound(V, 1) to VarArrayHighBound(V, 1) do
      Result := Result or 1 shl Integer(V[I]);
  end;
end;

function RFD(const Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField;
begin
  Result.Identifier := Identifier;
  Result.Offset := Offset;
  Result.Typ := Typ;
end;

procedure NotImplemented(const Msg: string);
begin
  JvInterpreterErrorN(ieInternal, -1, Msg + RsENotImplemented);
end;

//RWare: added check for "char", otherwise function with ref variable
//of type char causes AV, like KeyPress event handler

function Typ2Size(ATyp: Word): Integer;
begin
  Result := 0;
  case ATyp of
    varInteger:
      Result := SizeOf(Integer);
    varDouble:
      Result := SizeOf(Double);
    varByte:
      Result := SizeOf(Byte);
    varSmallint:
      Result := SizeOf(Smallint);
    varDate:
      Result := SizeOf(Double);
    varEmpty:
      Result := SizeOf(TVarData);
  else
    if ATyp = varObject then
      Result := SizeOf(Integer);
  end;
end;

function TypeName2VarTyp(const TypeName: string): Word;
begin
  // (rom) reimplemented for speed
  // (rom) LongBool added (untested)
  Result := varEmpty;
  if TypeName <> '' then
  begin
    case TypeName[1] of
      'A', 'a':
        if Cmp(TypeName, 'AnsiString') then
          Result := varString;
      'B', 'b':
        if Cmp(TypeName, 'boolean') or Cmp(TypeName, 'bool') then
          Result := varBoolean
        else
        if Cmp(TypeName, 'byte') then
          Result := varByte;
      'C', 'c':
        if Cmp(TypeName, 'char') then {+RWare}
          Result := varString;
      'D', 'd':
        if Cmp(TypeName, 'dword') then
          Result := varInteger
        else
        if Cmp(TypeName, 'double') then
          Result := varDouble;
      'I', 'i':
        if Cmp(TypeName, 'integer') then
          Result := varInteger;
      'L', 'l':
        if Cmp(TypeName, 'longint') then
          Result := varInteger
        else
        if Cmp(TypeName, 'longbool') then
          Result := varBoolean;
      'P', 'p':
        if Cmp(TypeName, 'PChar') then
          Result := varString;
      'S', 's':
        if Cmp(TypeName, 'string') or Cmp(TypeName, 'ShortString') then
          Result := varString
        else
        if Cmp(TypeName, 'smallint') then
          Result := varSmallint;
      'T', 't':
        if Cmp(TypeName, 'TObject') then
          Result := varObject
        else
        if Cmp(TypeName, 'tdatetime') then
          Result := varDate;
      'W', 'w':
        if Cmp(TypeName, 'word') then
          Result := varSmallint
        else
        if Cmp(TypeName, 'wordbool') then
          Result := varBoolean;
    end;
  end;
end;

procedure ClearList(List: TList);
var
  I: Integer;
begin
  if Assigned(List) then
  begin
    for I := 0 to List.Count - 1 do
      TObject(List[I]).Free;
    List.Clear;
  end;
end;

procedure ClearMethodList(List: TList);
var
  I: Integer;
begin
  for I := 0 to List.Count - 1 do
    Dispose(PMethod(List[I]));
  List.Clear;
end;

// (rom) JvUtil added to uses and functions deleted

function Cmp(const S1, S2: string): Boolean;
begin
  {$IFDEF VCL}
  // Direct call to CompareString is faster than AnsiCompareText.
  Result := (Length(S1) = Length(S2)) and
    (CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, PChar(S1),
    -1, PChar(S2), -1) = 2);
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  Result := AnsiCompareText(S1, S2) = 0;
  {$ENDIF VisualCLX}
end;

{************* Some code from RAStream unit **************}

procedure StringSaveToStream(Stream: TStream; const S: string);
var
  L: Integer;
  P: PChar;
begin
  L := Length(S);
  Stream.WriteBuffer(L, SizeOf(L));
  P := PChar(S);
  Stream.WriteBuffer(P^, L);
end;

function StringLoadFromStream(Stream: TStream): string;
var
  L: Integer;
  P: PChar;
begin
  Stream.ReadBuffer(L, SizeOf(L));
  SetLength(Result, L);
  P := PChar(Result);
  Stream.ReadBuffer(P^, L);
end;

procedure IntSaveToStream(Stream: TStream; AInt: Integer);
begin
  Stream.WriteBuffer(AInt, SizeOf(AInt));
end;

function IntLoadFromStream(Stream: TStream): Integer;
begin
  Stream.ReadBuffer(Result, SizeOf(Result));
end;

procedure WordSaveToStream(Stream: TStream; AWord: Word);
begin
  Stream.WriteBuffer(AWord, SizeOf(AWord));
end;

function WordLoadFromStream(Stream: TStream): Word;
begin
  Stream.ReadBuffer(Result, SizeOf(Result));
end;

procedure ExtendedSaveToStream(Stream: TStream; AExt: Extended);
begin
  Stream.WriteBuffer(AExt, SizeOf(AExt));
end;

function ExtendedLoadFromStream(Stream: