rm_jvinterpreter.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,771 行 · 第 1/5 页

    property RecordType: string read FRecordType;
  end;

type
  PJvInterpreterArrayRec = ^TJvInterpreterArrayRec;
  TJvInterpreterArrayRec = packed record
    Dimension: Integer; {number of dimensions}
    BeginPos: TJvInterpreterArrayValues; {starting range for all dimensions}
    EndPos: TJvInterpreterArrayValues; {ending range for all dimensions}
    ItemType: Integer; {array type}
    DT: IJvInterpreterDataType;
    ElementSize: Integer; {size of element in bytes}
    Size: Integer; {number of elements in array}
    Memory: Pointer; {pointer to memory representation of array}
  end;

  TJvInterpreterRecordDataType = class(TInterfacedObject, IJvInterpreterDataType)
  private
    FRecordDesc: TJvInterpreterRecord;
  public
    constructor Create(ARecordDesc: TJvInterpreterRecord);
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

  TJvInterpreterSimpleDataType = class(TInterfacedObject, IJvInterpreterDataType)
  private
    FTyp: TVarType;
  public
    constructor Create(ATyp: TVarType);
    procedure Init(var V: Variant);
    function GetTyp: Word;
  end;

  PMethod = ^TMethod;
  { interpreter function }
  TJvInterpreterSrcFun = class(TJvInterpreterIdentifier)
  private
    FunDesc: TJvInterpreterFunDesc;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  { external function }
  TJvInterpreterExtFun = class(TJvInterpreterSrcFun)
  private
    DllInstance: HINST;
    DllName: string;
    FunName: string;
    {or}
    FunIndex: Integer;
    function CallDll(Args: TJvInterpreterArgs): Variant;
  end;

  { function context - stack }
  PFunContext = ^TFunContext;
  TFunContext = record
    PrevFunContext: PFunContext;
    LocalVars: TJvInterpreterVarList;
    Fun: TJvInterpreterSrcFun;
  end;

  TJvInterpreterEventDesc = class(TJvInterpreterIdentifier)
  private
    EventClass: TJvInterpreterEventClass;
    Code: Pointer;
  end;
{$IFDEF COMPILER2}
  { TJvStringStream  - reduced implementation from Delphi 3 classes.pas }
  TJvStringStream = class(TStream)
  private
    FDataString: string;
    FPosition: Integer;
  protected
    procedure SetSize(NewSize: Longint);
  public
    constructor Create(const AString: string);
    function Read(var Buffer; Count: Longint): Longint; override;
    function Write(const Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
  end;
  PDouble = ^Double;
  PSmallInt = ^SmallInt;

{$ENDIF COMPILER2}
{$IFDEF COMPLIB_CLX}
type
  DWORD = Longint;
  PBool = PBoolean;
{$ENDIF COMPLIB_CLX}
{$IFDEF JvInterpreter_DEBUG}

var
  ObjCount: Integer = 0;
{$ENDIF}
{$IFDEF COMPILER6_UP}

var
  VariantRecordInstance: TJvRecordVariantType;
  VariantObjectInstance: TJvObjectVariantType;
  VariantClassInstance: TJvClassVariantType;
  VariantPointerInstance: TJvPointerVariantType;
  VariantSetInstance: TJvSetVariantType;
  VariantArrayInstance: TJvArrayVariantType;
{ TJvSimpleVariantType }

procedure TJvSimpleVariantType.Clear(var V: TVarData);
begin
  SimplisticClear(V);
end;

procedure TJvSimpleVariantType.Copy(var Dest: TVarData;
  const Source: TVarData; const Indirect: Boolean);
begin
  SimplisticCopy(Dest, Source, Indirect);
end;

function varRecord: TVarType;
begin
  Result := VariantRecordInstance.VarType
end;

function varObject: TVarType;
begin
  Result := VariantObjectInstance.VarType
end;

function varClass: TVarType;
begin
  Result := VariantClassInstance.VarType;
end;

function varPointer: TVarType;
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 AErrName, AErrName2: string);
begin
  inherited Create('');
  FErrCode := AErrCode;
  FErrPos := AErrPos;
  FErrName := AErrName;
  FErrName2 := AErrName2;
  { function LoadStr don't work sometimes :-( }
  Message := Format(LoadStr2(ErrCode), [ErrName, ErrName2]);
  FMessage1 := Message;
end;

procedure EJvInterpreterError.Assign(E: Exception);
begin
  Message := E.Message;
  if E is EJvInterpreterError then
  begin
    FErrCode := (E as EJvInterpreterError).FErrCode;
    FErrPos := (E as EJvInterpreterError).FErrPos;
    FErrName := (E as EJvInterpreterError).FErrName;
    FErrName2 := (E as EJvInterpreterError).FErrName2;
    FMessage1 := (E as EJvInterpreterError).FMessage1;
  end;
end;

procedure EJvInterpreterError.Clear;
begin
  FExceptionPos := False;
  FErrName := '';
  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(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(Identifier: string; Offset: Integer; Typ: Word): TJvInterpreterRecField;
begin
  Result.Identifier := Identifier;
  Result.Offset := Offset;
  Result.Typ := Typ;
end;

procedure NotImplemented(Message: string);
begin
  JvInterpreterErrorN(ieInternal, -1,
    Message + ' not implemented');
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:
      begin
        Result := SizeOf(Integer);
      end;
    varDouble:
      begin
        Result := SizeOf(Double);
      end;
    varByte:
      begin
        Result := SizeOf(Byte);
      end;
    varSmallInt:
      begin
        Result := SizeOf(varSmallInt);
      end;
    varDate:
      begin
        Result := SizeOf(Double);
      end;
    varEmpty:
      begin
        Result := SizeOf(TVarData);
      end
  else if ATyp = varObject then
    Result := SizeOf(Integer);
  end;
end;

function TypeName2VarTyp(TypeName: string): Word;
begin
  if Cmp(TypeName, 'integer') or Cmp(TypeName, 'longint') or Cmp(TypeName, 'dword') then
    Result := varInteger
  else if Cmp(TypeName, 'word') or Cmp(TypeName, 'smallint') then
    Result := varSmallInt
  else if Cmp(TypeName, 'byte') then
    Result := varByte
  else if Cmp(TypeName, 'wordbool') or Cmp(TypeName, 'boolean') or Cmp(TypeName, 'bool') then
    Result := varBoolean
  else if Cmp(TypeName, 'string') or Cmp(TypeName, 'PChar') or
    Cmp(TypeName, 'ANSIString') or Cmp(TypeName, 'ShortString') or
    Cmp(TypeName, 'char') then {+RWare}
    Result := varString
  else if Cmp(TypeName, 'double') then