disqlite3functions.pas

来自「DELPHI 访问SQLITE3 数据库的VCL控件」· PAS 代码 · 共 689 行 · 第 1/2 页

{-------------------------------------------------------------------------------
 
 Copyright (c) 1999-2007 Ralf Junker, The Delphi Inspiration
 Internet: http://www.yunqa.de/delphi/
 E-Mail:   [e-mail]

-------------------------------------------------------------------------------}

unit DISQLite3Functions;

{$I DI.inc}
{$I DISQLite3.inc}

{$IFDEF DISQLite3_Personal}
!!! This unit requires functionality unavailable in DISQLite3 Personal. !!!
!!! To compile, download DISQLite3 Pro from www.yunqa.de/delphi/        !!!
{$ENDIF DISQLite3_Personal}

interface

uses
  SysUtils,
  DISQLite3Api;

procedure sqlite3_create_math_functions(const ADBHandle: TDISQLite3DatabaseHandle);

procedure sqlite3_function_acos(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_asin(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_atan(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_atan2(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_ceiling(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_cos(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_cot(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_degrees(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_exp(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_floor(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_ln(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_logN(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_log2(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_log10(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_mod(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_pi(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_pow(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_radians(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_sign(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_sin(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_sqrt(Context: Pointer; nArgs: Integer; Args: PPointerArray);

procedure sqlite3_function_tan(Context: Pointer; nArgs: Integer; Args: PPointerArray);

implementation

uses
  SysConst;

const
  PI = 3.1415926535897932384626433832795;

function ACos(x: Double): Double; assembler;
asm
  FLD     X
  FLD     ST(0)
  FMUL    ST(0), ST
  FLD1
  FSUBRP  ST(1), ST
  FSQRT
  FXCH
  FPATAN
  FWAIT
end;

function ASin(x: Double): Double; assembler;
asm
  FLD     X
  FLD     ST(0)
  FMUL    ST(0), ST
  FLD1
  FSUBRP  ST(1), ST
  FSQRT
  FPATAN
  FWAIT
end;

function ATan(x: Double): Double; assembler;
asm
  FLD     X
  FLD1
  FPATAN
  FWAIT
end;

function ATan2(y, x: Double): Double; assembler;
asm
  FLD     Y
  FLD     X
  FPATAN
  FWAIT
end;

function ceil(const x: Double): Int64;
begin
  Result := Int64(Trunc(x));
  if Frac(x) > 0 then
    Inc(Result);
end;

function cos(x: Double): Double; assembler;
asm
  FLD     X
  FCOS
  FWAIT
end;

function Cot(x: Double): Double; assembler;
asm
  FLD     X
  FPTAN
  FDIVRP
  FWAIT
end;

function Floor(const x: Double): Int64;
begin
  Result := Int64(Trunc(x));
  if Frac(x) < 0 then
    Dec(Result);
end;

function log10(x: Double): Double; assembler;
asm
  FLDLG2
  FLD     X
  FYL2X
  FWAIT
end;

function Log2(x: Double): Double; assembler;
asm
  FLD1
  FLD     X
  FYL2X
  FWAIT
end;

function LogN(Base, x: Double): Double; assembler;
asm
  FLD1
  FLD     X
  FYL2X
  FLD1
  FLD     Base
  FYL2X
  FDIV
  FWAIT
end;

function ModDouble(const x, y: Double): Double;
var
  z: Double;
begin
  Result := x / y;
  z := Trunc(Result);
  if Frac(Result) < 0.0 then
    z := z - 1;
  Result := x - y * z;
end;

function Power(const Base, Exponent: Double): Double;
begin
  if (Exponent = 0.0) or (Base = 1.0) then
    Result := 1
  else
    if Base = 0.0 then
      begin
        if Exponent > 0.0 then
          Result := 0.0
        else
          raise EOverflow.Create(SOverflow);
      end
    else
      if Base > 0.0 then
        Result := exp(Exponent * Ln(Base))
      else
        if Frac(Exponent) = 0.0 then
          begin
            Result := exp(Exponent * Ln(Abs(Base)));
            if Abs(Round(ModDouble(Exponent, 2))) = 1 then
              Result := -Result;
          end
        else
          raise EInvalidOp.Create(SInvalidOp);
end;

function Sin(x: Double): Double; assembler;
asm
  FLD     X
  FSIN
  FWAIT
end;

function Tan(x: Double): Double; assembler;
asm
  FLD     X
  FPTAN
  FSTP    ST(0)
  FWAIT
end;

const
  WRONG_ARGUMENT_TYPE = 'Wrong argument type';

procedure sqlite3_result_argument_error(const Context: Pointer);
begin
  sqlite3_result_error(Context, WRONG_ARGUMENT_TYPE, Length(WRONG_ARGUMENT_TYPE));
end;

procedure sqlite3_function_acos(Context: Pointer; nArgs: Integer; Args: PPointerArray);
var
  p: Pointer;
  v: Double;
begin
  p := Args[0];
  case sqlite3_value_type(p) of
    SQLITE_INTEGER, SQLITE_FLOAT:
      begin
        v := sqlite3_value_double(p);
        if (v < -1.0) or (v > 1.0) then
          sqlite3_result_null(Context)
        else
          sqlite3_result_double(Context, ACos(v));
      end;
    else
      sqlite3_result_argument_error(Context);
  end;
end;

procedure sqlite3_function_asin(Context: Pointer; nArgs: Integer; Args: PPointerArray);
var
  p: Pointer;
  v: Double;
begin
  p := Args[0];
  case sqlite3_value_type(p) of
    SQLITE_INTEGER, SQLITE_FLOAT:
      begin
        v := sqlite3_value_double(p);
        if (v < -1.0) or (v > 1.0) then
          sqlite3_result_null(Context)
        else
          sqlite3_result_double(Context, ASin(v));
      end;
    else
      sqlite3_result_argument_error(Context);
  end;
end;

procedure sqlite3_function_atan(Context: Pointer; nArgs: Integer; Args: PPointerArray);
var
  p: Pointer;
begin
  p := Args[0];
  case sqlite3_value_type(p) of
    SQLITE_INTEGER, SQLITE_FLOAT:
      begin
        sqlite3_result_double(Context, ATan(sqlite3_value_double(p)));
      end;
    else
      sqlite3_result_argument_error(Context);
  end;
end;

procedure sqlite3_function_atan2(Context: Pointer; nArgs: Integer; Args: PPointerArray);
var
  p1, p2: Pointer;
begin
  p1 := Args[0];
  case sqlite3_value_type(p1) of
    SQLITE_INTEGER, SQLITE_FLOAT:
      begin
        p2 := Args[1];
        case sqlite3_value_type(p2) of
          SQLITE_INTEGER, SQLITE_FLOAT:
            begin
              sqlite3_result_double(Context, ATan2(sqlite3_value_double(p1), sqlite3_value_double(p2)));
              Exit;
            end;
        end;
      end;
  end;
  sqlite3_result_argument_error(Context);
end;

procedure sqlite3_function_ceiling(Context: Pointer; nArgs: Integer; Args: PPointerArray);
var
  p: Pointer;
begin
  p := Args[0];
  case sqlite3_value_type(p) of
    SQLITE_INTEGER, SQLITE_FLOAT:
      sqlite3_result_int64(Context, ceil(sqlite3_value_double(p)));
    else
      sqlite3_result_argument_error(Context);
  end;
end;

procedure sqlite3_function_cos(Context: Pointer; nArgs: Integer; Args: PPointerArray);
var
  p: Pointer;
begin
  p := Args[0];
  case sqlite3_value_type(p) of
    SQLITE_INTEGER, SQLITE_FLOAT:
      sqlite3_result_double(Context, cos(sqlite3_value_double(p)));
    else
      sqlite3_result_argument_error(Context);
  end;
end;

procedure sqlite3_function_cot(Context: Pointer; nArgs: Integer; Args: PPointerArray);
var
  p: Pointer;
begin
  p := Args[0];
  case sqlite3_value_type(p) of
    SQLITE_INTEGER, SQLITE_FLOAT: