rm_jvinterpreter_system.pas

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

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 exception.Create('Sorry. For one-dimensional arrays only.');
    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 exception.Create('Sorry. For one-dimensional arrays only.');
    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 exception.Create('Sorry. For one-dimensional arrays only.');
    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, [0], varEmpty);
    AddGet(TObject, 'ClassName', TObject_ClassName, 0, [0], varEmpty);
    AddGet(TObject, 'ClassNameIs', TObject_ClassNameIs, 1, [varEmpty], varEmpty);
    AddGet(TObject, 'ClassParent', TObject_ClassParent, 0, [0], varEmpty);
    AddGet(TObject, 'ClassInfo', TObject_ClassInfo, 0, [0], varEmpty);
    AddGet(TObject, 'InstanceSize', TObject_InstanceSize, 0, [0], varEmpty);
    AddGet(TObject, 'InheritsFrom', TObject_InheritsFrom, 1, [varEmpty], varEmpty);
    // AddGet(TObject, 'GetInterface', TObject_GetInterface, 3, [varEmpty, varEmpty, varEmpty], varEmpty);
    { TInterfacedObject }
{$IFDEF COMPILER3_UP}
    AddClass(cSystem, TInterfacedObject, 'TInterfacedObject');
    AddGet(TInterfacedObject, 'RefCount', TInterfacedObject_Read_RefCount, 0, [0], varEmpty);
{$ENDIF COMPILER3_UP}
    AddFunction(cSystem, 'Move', JvInterpreter_Move, 3, [varEmpty, varByRef, varEmpty], varEmpty);
    AddFunction(cSystem, 'ParamCount', JvInterpreter_ParamCount, 0, [0], varEmpty);
    AddFunction(cSystem, 'ParamStr', JvInterpreter_ParamStr, 1, [varEmpty], varEmpty);
    AddFunction(cSystem, 'Randomize', JvInterpreter_Randomize, 0, [0], 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 Stringfunctions
    AddFunction(cSystem, 'Delete', JvInterpreter_Delete, 3, [varByRef, varEmpty, varEmpty], varEmpty);
    AddFunction(cSystem, 'Insert', JvInterpreter_Insert, 3, [varEmpty, varByRef, varEmpty], varEmpty);
    // some mathfunctions
    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', integer(varEmpty));
    AddConst('cSystem', 'varSmallint', integer(varSmallint));
    AddConst('cSystem', 'varInteger', integer(varInteger));
    AddConst('cSystem', 'varSingle', integer(varSingle));
    AddConst('cSystem', 'varCurrency', integer(varCurrency));
    AddConst('cSystem', 'varDouble', integer(varDouble));
    AddConst('cSystem', 'varDate', integer(varDate));
    AddConst('cSystem', 'varOleStr', integer(varOleStr));
    AddConst('cSystem', 'varDispatch', integer(varDispatch));
    AddConst('cSystem', 'varError', integer(varError));
    AddConst('cSystem', 'varBoolean', integer(varBoolean));
    AddConst('cSystem', 'varVariant', integer(varVariant));
    AddConst('cSystem', 'varUnknown', integer(varUnknown));
    AddConst('cSystem', 'varByte', integer(varByte));
    AddConst('cSystem', 'varStrArg', integer(varStrArg));
    AddConst('cSystem', 'varSrting', integer(varString));
    AddConst('cSystem', 'varAny', integer(varAny));
    AddConst('cSystem', 'varTypeMask', integer(varTypeMask));
    AddConst('cSystem', 'varArray', integer(varArray));
    AddConst('cSystem', 'varByRef', integer(varByRef));
{$IFDEF COMPILER6_UP}
    AddConst('cSystem', 'varShortInt', integer(varShortInt));
    AddConst('cSystem', 'varWord', integer(varWord));
    AddConst('cSystem', 'varLongWord', integer(varLongWord));
    AddConst('cSystem', 'varInt64', integer(varInt64));
{$ENDIF COMPILER6_UP}
  end;
end;
end.