imp_pascal.pas

来自「Delphi脚本控件」· PAS 代码 · 共 666 行 · 第 1/2 页

////////////////////////////////////////////////////////////////////////////
// PAXScript Importing
// Author: Alexander Baranovsky ([e-mail])
// ========================================================================
// Copyright (c) Alexander Baranovsky, 2003-2005. All rights reserved.
// Code Version: 3.0
// ========================================================================
// Unit: IMP_Pascal.pas
// ========================================================================
////////////////////////////////////////////////////////////////////////////

{$I PaxScript.def}
unit IMP_Pascal;
interface
uses
{$IFDEF VARIANTS}
  Variants,
{$ENDIF}
  SysUtils,
  Classes,
  Math,
  BASE_SYS,
  BASE_CLASS,
  BASE_EXTERN,
  BASE_SCRIPTER,
  PaxScripter;

implementation

procedure _ArcCos(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := ArcCos(Params[0].PValue^);
end;

procedure _ArcTan(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := ArcTan(Params[0].PValue^);
end;

procedure _ArcTan2(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := ArcTan2(Params[0].PValue^, Params[1].PValue^);
end;

procedure _ArcSin(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := ArcSin(Params[0].PValue^);
end;

procedure _Cos(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := Cos(Params[0].PValue^);
end;

procedure _Tan(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := Tan(Params[0].PValue^);
end;

procedure _Sin(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := Sin(Params[0].PValue^);
end;

procedure _sinh(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := Sinh(Params[0].PValue^);
end;

procedure _tanh(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := Tanh(Params[0].PValue^);
end;

procedure _cosh(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := Cosh(Params[0].PValue^);
end;

function _Round(X: Extended): Int64;
begin
  result := Round(X);
end;

function _Int(X: Extended): Extended;
begin
  result := Int(X);
end;

function _Chr(X: Byte): Char;
begin
  result := Chr(X);
end;

procedure _Ord(MethodBody: TPAXMethodBody);
var
  V: Variant;
  S: String;
begin
  with MethodBody do
  begin
    V := Params[0].PValue^;
    if IsString(V) then
    begin
      S := toString(V);
      result.PValue^ := ord(S[1])
    end
    else
      result.PValue^ := toInteger(V);
  end;
end;

function _Abs(const X: Variant): Variant;
begin
  result := Abs(X);
end;

function _Exp(const X: Variant): Variant;
begin
  result := Exp(X);
end;

function _Ln(const X: Variant): Variant;
begin
  result := Ln(X);
end;

procedure _Sqr(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.PValue^ := sqr(Params[0].PValue^);
end;

function _Random(Range: Integer): Integer;
begin
  result := Random(Range);
end;

function _Trunc(X: Variant): integer;
begin
   result := trunc(X);
end;

procedure _Inc(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
  begin
    if ParamCount = 1 then
      Params[0].AsVariant := Params[0].AsVariant + 1
    else
      Params[0].AsVariant := Params[0].AsVariant + Params[1].AsVariant;
  end;
end;

procedure _Dec(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
  begin
    if ParamCount = 1 then
      Params[0].AsVariant := Params[0].AsVariant - 1
    else
      Params[0].AsVariant := Params[0].AsVariant - Params[1].AsVariant;
  end;
end;

procedure _Pos(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.AsInteger := Pos(Params[0].AsString, Params[1].AsString);
end;

procedure _Copy(MethodBody: TPAXMethodBody);
begin
  with MethodBody do
    result.AsString := Copy(Params[0].AsString, Params[1].AsInteger, Params[2].AsInteger);
end;

procedure _Delete(MethodBody: TPAXMethodBody);
var
  S: String;
begin
  with MethodBody do
  begin
    S := Params[0].AsString;
    Delete(S, Params[1].AsInteger, Params[2].AsInteger);
    Params[0].AsString := S;
  end;
end;

procedure _Insert(MethodBody: TPAXMethodBody);
var
  S: String;
begin
  with MethodBody do
  begin
    S := Params[1].AsString;
    Insert(Params[0].AsString, S, Params[2].AsInteger);
    Params[1].AsString := S;
  end;
end;

type
  TFileKind = (fkText, fkFile);

  TFileWrapper = class
    T: TextFile;
    F: File;
    FileKind: TFileKind;
    constructor Create(FileKind: TFileKind);
  end;

  TextFile = class
  end;

function GetFileWrapper(const V: Variant): TFileWrapper;
var
  SO: TPAXScriptObject;
begin
  if not IsObject(V) then
    raise Exception.Create('Incompatible types');
  SO := VariantToScriptObject(V);
  if SO.ClassRec.Name <> 'TFileWrapper' then
    raise Exception.Create('Incompatible types');
  result := TFileWrapper(SO.Instance);
end;

function GetTextFileWrapper(const V: Variant): TFileWrapper;
var
  SO: TPAXScriptObject;
begin
  result := nil;
  if not IsObject(V) then
    Exit;
  SO := VariantToScriptObject(V);
  if SO.ClassRec.Name <> 'TFileWrapper' then
    Exit;
  result := TFileWrapper(SO.Instance);
  if result.FileKind <> fkText then
    result := nil;
end;

constructor TFileWrapper.Create(FileKind: TFileKind);
begin
  inherited Create;
  Self.FileKind := FileKind;
end;

procedure _AssignFile(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
  V: Variant;
  FileKind: TFileKind;
  SO: TPAXScriptObject;
begin
  with MethodBody do
  begin
    V := Params[0].AsVariant;
    if IsObject(V) then
    begin
      SO := VariantToScriptObject(V);
      if SO.ClassRec.Name = 'TextFile' then
        FileKind := fkText
      else if SO.ClassRec.Name = 'File' then
        FileKind := fkFile
      else
        raise Exception.Create('Incompatible types');
      TPAXBaseScripter(Scripter).ScriptObjectList.RemoveObject(SO);
    end
    else
      FileKind := fkText;

    FW := TFileWrapper.Create(FileKind);
    Assign(FW.T, Params[1].AsString);
    Params[0].AsVariant := ScriptObjectToVariant(DelphiInstanceToScriptObject(FW, Scripter));
  end;
end;

procedure _Eoln(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    if FW.FileKind = fkText then
      Result.AsVariant := Eoln(FW.T)
    else
      raise Exception.Create('Incompatible types');
  end;
end;

procedure _SeekEoln(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    if FW.FileKind = fkText then
      Result.AsVariant := SeekEoln(FW.T)
    else
      raise Exception.Create('Incompatible types');
  end;
end;

procedure _Eof(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin
  with MethodBody do
  begin
    FW := GetFileWrapper(Params[0].AsVariant);
    if FW.FileKind = fkText then
      Result.AsVariant := Eof(FW.T)
    else
      raise Exception.Create('Incompatible types');
  end;
end;

procedure _SeekEof(MethodBody: TPAXMethodBody);
var
  FW: TFileWrapper;
begin