rm_jvinterpreter_system.pas

这是一个功能强大

end;*)

{ function VarIsArray(const A: Variant): Boolean; }
procedure JvInterpreter_VarIsArray(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := VarIsArray(Args.Values[0]);
end;

{ function Ord(const A: Variant): Integer; }

procedure JvInterpreter_Ord(var Value: Variant; Args: TJvInterpreterArgs);
begin
  if VarType(Args.Values[0]) = varString then
    Value := Ord(VarToStr(Args.Values[0])[1])
  else
    Value := Integer(Args.Values[0]);
end;

{ function Chr(X: Byte): Char }

procedure JvInterpreter_Chr(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Chr(Byte(Args.Values[0]));
end;

{ function Abs(X); }

procedure JvInterpreter_Abs(var Value: Variant; Args: TJvInterpreterArgs);
begin
  if VarType(Args.Values[0]) = varInteger then
    Value := Abs(Integer(Args.Values[0]))
  else
    Value := Abs(Extended(Args.Values[0]));
end;

{ function Length(S): Integer; }

procedure JvInterpreter_Length(var Value: Variant; Args: TJvInterpreterArgs);
begin
  if VarIsArray(Args.Values[0]) then
  begin
    if VarArrayDimCount(Args.Values[0]) > 1 then
      raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);
    Value := VarArrayHighBound(Args.Values[0], 1)-VarArrayLowBound(Args.Values[0], 1);
  end
  else
  if TVarData(Args.Values[0]).vType = varArray then
    Value := JvInterpreterArrayLength(Args.Values[0])
  else
    Value := Length(Args.Values[0]);
end;

{ function Copy(S; Index, Count: Integer): String; }

procedure JvInterpreter_Copy(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Copy(Args.Values[0], Integer(Args.Values[1]), Integer(Args.Values[2]));
end;

{ function Round(Value: Extended): Int64; }

procedure JvInterpreter_Round(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Integer(Round(Args.Values[0]));
end;

{ function Trunc(Value: Extended): Int64; }

procedure JvInterpreter_Trunc(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Integer(Trunc(Args.Values[0]));
end;

{ function Pos(Substr: string; S: string): Integer; }

procedure JvInterpreter_Pos(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Pos(string(Args.Values[0]), string(Args.Values[1]));
end;

//+++pfh
{procedure Delete(var S: string; Index, Count: Integer);}

procedure JvInterpreter_Delete(var Value: Variant; Args: TJvInterpreterArgs);
var
  S: string;
begin
  S := Args.Values[0];
  Delete(S, Integer(Args.Values[1]), Integer(Args.Values[2]));
  Args.Values[0] := S;
  Value := S;
end;

{procedure Insert(Source: string; var S: string; Index: Integer);}

procedure JvInterpreter_Insert(var Value: Variant; Args: TJvInterpreterArgs);
var
  S: string;
begin
  S := Args.Values[1];
  Insert(string(Args.Values[0]), S, Integer(Args.Values[2]));
  Args.Values[1] := S;
  Value := S;
end;

{ function Sqr(X: Extended): Extended; }

procedure JvInterpreter_Sqr(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Sqr(Args.Values[0]);
end;

{ function Sqrt(X: Extended): Extended; }

procedure JvInterpreter_Sqrt(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Sqrt(Args.Values[0]);
end;

{ function Exp(X: Extended): Extended; }

procedure JvInterpreter_Exp(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Exp(Args.Values[0]);
end;

{ function Ln(X: Extended): Extended; }

procedure JvInterpreter_Ln(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Ln(Args.Values[0]);
end;

{ function Sin(X: Extended): Extended; }

procedure JvInterpreter_Sin(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Sin(Args.Values[0]);
end;

{ function Cos(X: Extended): Extended; }

procedure JvInterpreter_Cos(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := Cos(Args.Values[0]);
end;

{ function Tan(X: Extended): Extended; }

procedure JvInterpreter_Tan(var Value: Variant; Args: TJvInterpreterArgs);
begin
//(p3) Tan() is defined in Math.pas which isn't available in all Delphi SKU's
//  Tan(X) = Sin(X)/ Cos(X)
  Value := Sin(Args.Values[0]) / Cos(Args.Values[0]);
end;

{ function ArcTan(X: Extended): Extended; }

procedure JvInterpreter_ArcTan(var Value: Variant; Args: TJvInterpreterArgs);
begin
  Value := ArcTan(Args.Values[0]);
end;
//---pfh

{ procedure SetLength(var s: ShortString; newLength: Integer); }

procedure JvInterpreter_SetLength(var Value: Variant; Args: TJvInterpreterArgs);
begin
  if TVarData(Args.Values[0]).vType <> varArray then
    SetLength(string(TVarData(Args.Values[0]).vString), Integer(Args.Values[1]))
  else
    JvInterpreterArraySetLength(Args.Values[0], Integer(Args.Values[1]));
end;

{procedure High(var Value: Variant; Args: TJvInterpreterArgs);}

procedure JvInterpreter_High(var Value: Variant; Args: TJvInterpreterArgs);
begin
  if VarIsArray(Args.Values[0]) then
  begin
    if VarArrayDimCount(Args.Values[0]) > 1 then
      raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);
    Value := VarArrayLowBound(Args.Values[0], 1);
  end
  else
    Value := JvInterpreterArrayHigh(Args.Values[0]);
end;

{procedure Low(var Value: Variant; Args: TJvInterpreterArgs);}

procedure JvInterpreter_Low(var Value: Variant; Args: TJvInterpreterArgs);
begin
  if VarIsArray(Args.Values[0]) then
  begin
    if VarArrayDimCount(Args.Values[0]) > 1 then
      raise EJVCLException.CreateRes(@RsESorryForOneDimensionalArraysOnly);
    Value := VarArrayLowBound(Args.Values[0], 1);
  end
  else
    Value := JvInterpreterArrayLow(Args.Values[0]);
end;

{procedure DeleteFromArray(var Value: Variant; Args: TJvInterpreterArgs);}

procedure JvInterpreter_DeleteFromArray(var Value: Variant; Args: TJvInterpreterArgs);
begin
  JvInterpreterArrayElementDelete(Args.Values[0], Integer(Args.Values[1]));
end;

{procedure InsertIntoArray(var Value: Variant; Args: TJvInterpreterArgs);}

procedure JvInterpreter_InsertIntoArray(var Value: Variant; Args: TJvInterpreterArgs);
begin
  JvInterpreterArrayElementInsert(Args.Values[0], Integer(Args.Values[1]), Args.Values[2]);
end;

procedure RegisterJvInterpreterAdapter(JvInterpreterAdapter: TJvInterpreterAdapter);
const
  cSystem = 'System';
begin
  with JvInterpreterAdapter do
  begin
    { TObject }
    AddClass(cSystem, TObject, 'TObject');
    AddGet(TObject, 'ClassType', TObject_ClassType, 0, [varEmpty], varEmpty);
    AddGet(TObject, 'ClassName', TObject_ClassName, 0, [varEmpty], varEmpty);
    AddGet(TObject, 'ClassNameIs', TObject_ClassNameIs, 1, [varEmpty], varEmpty);
    AddGet(TObject, 'ClassParent', TObject_ClassParent, 0, [varEmpty], varEmpty);
    AddGet(TObject, 'ClassInfo', TObject_ClassInfo, 0, [varEmpty], varEmpty);
    AddGet(TObject, 'InstanceSize', TObject_InstanceSize, 0, [varEmpty], varEmpty);
    AddGet(TObject, 'InheritsFrom', TObject_InheritsFrom, 1, [varEmpty], varEmpty);
    // AddGet(TObject, 'GetInterface', TObject_GetInterface, 3, [varEmpty, varEmpty, varEmpty], varEmpty);
    { TInterfacedObject }
    AddClass(cSystem, TInterfacedObject, 'TInterfacedObject');
    AddGet(TInterfacedObject, 'RefCount', TInterfacedObject_Read_RefCount, 0, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Move', JvInterpreter_Move, 3, [varEmpty, varByRef, varEmpty], varEmpty);
    AddFunction(cSystem, 'ParamCount', JvInterpreter_ParamCount, 0, [varEmpty], varEmpty);
    AddFunction(cSystem, 'ParamStr', JvInterpreter_ParamStr, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Randomize', JvInterpreter_Randomize, 0, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Random', JvInterpreter_Random, 1, [varInteger], varEmpty);
    AddFunction(cSystem, 'UpCase', JvInterpreter_UpCase, 1, [varEmpty], varEmpty);
    { AddFunction(cSystem, 'WideCharToString', JvInterpreter_WideCharToString, 1, [varEmpty], varEmpty);
      AddFunction(cSystem, 'WideCharLenToString', JvInterpreter_WideCharLenToString, 2, [varEmpty, varEmpty], varEmpty);
      AddFunction(cSystem, 'WideCharToStrVar', JvInterpreter_WideCharToStrVar, 2, [varEmpty, varByRef], varEmpty);
      AddFunction(cSystem, 'WideCharLenToStrVar', JvInterpreter_WideCharLenToStrVar, 3, [varEmpty, varEmpty, varByRef], varEmpty);
      AddFunction(cSystem, 'StringToWideChar', JvInterpreter_StringToWideChar, 3, [varEmpty, varEmpty, varEmpty], varEmpty);
      AddFunction(cSystem, 'OleStrToString', JvInterpreter_OleStrToString, 1, [varEmpty], varEmpty);
      AddFunction(cSystem, 'OleStrToStrVar', JvInterpreter_OleStrToStrVar, 2, [varEmpty, varByRef], varEmpty);
      AddFunction(cSystem, 'StringToOleStr', JvInterpreter_StringToOleStr, 1, [varEmpty], varEmpty); }
    AddFunction(cSystem, 'VarType', JvInterpreter_VarType, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarAsType', JvInterpreter_VarAsType, 2, [varEmpty, varEmpty], varEmpty);
    AddFunction(cSystem, 'VarIsEmpty', JvInterpreter_VarIsEmpty, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarIsNull', JvInterpreter_VarIsNull, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarToStr', JvInterpreter_VarToStr, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarFromDateTime', JvInterpreter_VarFromDateTime, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarToDateTime', JvInterpreter_VarToDateTime, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarArrayCreate', JvInterpreter_VarArrayCreate, 2, [varEmpty, varEmpty], varEmpty);
    AddFunction(cSystem, 'VarArrayOf', JvInterpreter_VarArrayOf, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarArrayDimCount', JvInterpreter_VarArrayDimCount, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarArrayLowBound', JvInterpreter_VarArrayLowBound, 2, [varEmpty, varEmpty], varEmpty);
    AddFunction(cSystem, 'VarArrayHighBound', JvInterpreter_VarArrayHighBound, 2, [varEmpty, varEmpty], varEmpty);
    {AddFunction(cSystem, 'VarArrayLock', JvInterpreter_VarArrayLock, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarArrayUnlock', JvInterpreter_VarArrayUnlock, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'VarArrayRef', JvInterpreter_VarArrayRef, 1, [varEmpty], varEmpty);}
    AddFunction(cSystem, 'VarIsArray', JvInterpreter_VarIsArray, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'ord', JvInterpreter_Ord, 1, [varEmpty], varEmpty);

    AddFunction(cSystem, 'Chr', JvInterpreter_Chr, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Abs', JvInterpreter_Abs, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Length', JvInterpreter_Length, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Copy', JvInterpreter_Copy, 3, [varEmpty, varEmpty, varEmpty], varEmpty);
    AddFunction(cSystem, 'Round', JvInterpreter_Round, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Trunc', JvInterpreter_Trunc, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Pos', JvInterpreter_Pos, 2, [varEmpty, varEmpty], varEmpty);

    //+++pfh
    // some string functions
    AddFunction(cSystem, 'Delete', JvInterpreter_Delete, 3, [varByRef, varEmpty, varEmpty], varEmpty);
    AddFunction(cSystem, 'Insert', JvInterpreter_Insert, 3, [varEmpty, varByRef, varEmpty], varEmpty);
    // some math functions
    AddFunction(cSystem, 'Sqr', JvInterpreter_Sqr, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Sqrt', JvInterpreter_Sqrt, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Exp', JvInterpreter_Exp, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Ln', JvInterpreter_Ln, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Sin', JvInterpreter_Sin, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Cos', JvInterpreter_Cos, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Tan', JvInterpreter_Tan, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'ArcTan', JvInterpreter_ArcTan, 1, [varEmpty], varEmpty);
    //---pfh
    AddFunction(cSystem, 'SetLength', JvInterpreter_SetLength, 2, [varByRef or varString or varArray, varInteger], varEmpty);
    AddFunction(cSystem, 'High', JvInterpreter_High, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Low', JvInterpreter_Low, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'DeleteFromArray', JvInterpreter_DeleteFromArray, 2, [varEmpty, varEmpty], varEmpty);
    AddFunction(cSystem, 'InsertIntoArray', JvInterpreter_InsertIntoArray, 3, [varEmpty, varEmpty, varEmpty], varEmpty);
    //
    AddConst(cSystem, 'varEmpty', Ord(varEmpty));
    AddConst(cSystem, 'varSmallint', Ord(varSmallint));
    AddConst(cSystem, 'varInteger', Ord(varInteger));
    AddConst(cSystem, 'varSingle', Ord(varSingle));
    AddConst(cSystem, 'varCurrency', Ord(varCurrency));
    AddConst(cSystem, 'varDouble', Ord(varDouble));
    AddConst(cSystem, 'varDate', Ord(varDate));
    AddConst(cSystem, 'varOleStr', Ord(varOleStr));
    AddConst(cSystem, 'varDispatch', Ord(varDispatch));
    AddConst(cSystem, 'varError', Ord(varError));
    AddConst(cSystem, 'varBoolean', Ord(varBoolean));
    AddConst(cSystem, 'varVariant', Ord(varVariant));
    AddConst(cSystem, 'varUnknown', Ord(varUnknown));
    AddConst(cSystem, 'varByte', Ord(varByte));
    AddConst(cSystem, 'varStrArg', Ord(varStrArg));
    AddConst(cSystem, 'varSrting', Ord(varString));
    AddConst(cSystem, 'varAny', Ord(varAny));
    AddConst(cSystem, 'varTypeMask', Ord(varTypeMask));
    AddConst(cSystem, 'varArray', Ord(varArray));
    AddConst(cSystem, 'varByRef', Ord(varByRef));
    {$IFDEF COMPILER6_UP}
    AddConst(cSystem, 'varShortInt', Ord(varShortInt));
    AddConst(cSystem, 'varWord', Ord(varWord));
    AddConst(cSystem, 'varLongWord', Ord(varLongWord));
    AddConst(cSystem, 'varInt64', Ord(varInt64));
    {$ENDIF COMPILER6_UP}
  end;
end;

{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.