mirror of
https://github.com/ulfgebhardt/delphi_plotter.git
synced 2025-12-12 23:35:54 +00:00
1678 lines
44 KiB
ObjectPascal
1678 lines
44 KiB
ObjectPascal
(*
|
|
// Information / License ///////////////////////////////////////////////////////
|
|
|
|
Originally written in March 2005 by tyberis (aka delfiphan)
|
|
Original version can be downloaded here:
|
|
http://www.tyberis.com/download/tyParser.pas
|
|
|
|
* This unit can be copied/used/modified without permission by the author.
|
|
Credits appreciated but not required (give credit to "tyberis")
|
|
* Code comes with no warranties whatsoever.
|
|
* Do not alter/remove/separate this information/license from the unit!
|
|
|
|
Version 1.2.2
|
|
|
|
////////////////////////////////////////////////////////////////////////////////
|
|
*)
|
|
|
|
{
|
|
- Description ------------------------------------------------------------------
|
|
|
|
What it does / How it works:
|
|
tyParser is a parser for mathematical expressions. It can be used to evaluate
|
|
string expressions like "x + 1/2".
|
|
The parser takes a mathematical expression as a string and creates a bytecode.
|
|
This bytecode can be evaluated very efficiently. To further highten the speed
|
|
of the evaluation, the bytecode can be compiled to machine code.
|
|
|
|
Performance:
|
|
The tyParser compiler will create an (almost autonomous) function which can be
|
|
run like a regular delphi function. This guarantees top performance!
|
|
|
|
Safety/Usage:
|
|
For easy and safe usage, see examples 1-3. The interface wrapper will take care
|
|
of all problems that might arise when using the parser/compiler directly but
|
|
will introduce some overhead.
|
|
If you need top performance you can use the parser or compiler directly. Please
|
|
note that the functions generated directly by the compiler are potentially
|
|
unsafe when used incorrectly.
|
|
1. Make sure that you always pass the correct number of arguments with the
|
|
correct type.
|
|
2. Make sure that you free all functions that you create (using FreeFunc).
|
|
See examples 4-7 to find out how to use the parser/compiler directly.
|
|
|
|
- Examples A - using the interface wrapper (safe but with additional overhead) -
|
|
uses ..., tyParser;
|
|
|
|
Var
|
|
sinc: IExpr1V;
|
|
sinexp: IExpr2V;
|
|
Sum_abc: IExprR;
|
|
Args: array[0..2] of Extended;
|
|
Result: Extended;
|
|
begin
|
|
// EXAMPLE 1
|
|
sinc := compileStr1V('sin(x)/x');
|
|
Result := sinc.Eval(1.0);
|
|
|
|
// EXAMPLE 2
|
|
sinexp := compileStr2V('sin(x)*exp(y)');
|
|
Result := sinexp.Eval(2.0, 3.0);
|
|
|
|
// EXAMPLE 3
|
|
Sum_abc := compileStrR('a+b+c',['a','b','c']);
|
|
Args[0] := 1.0; // a = 1.0
|
|
Args[1] := 2.0; // b = 2.0
|
|
Args[2] := 3.0; // c = 3.0
|
|
Result := Sum_abc.Eval(Args)
|
|
|
|
// All functions are freed automatically when out of scope
|
|
end;
|
|
|
|
- Examples B - direct usage, top performance but potentially unsafe ------------
|
|
uses ..., tyParser;
|
|
|
|
Var
|
|
SinC : ExprFunc1V; // Function(const x : Extended): Extended;
|
|
SinExp : ExprFunc2V; // Function(const x,y : Extended): Extended;
|
|
Sum_abc: ExprFuncR; // Function(var Args): Extended;
|
|
Expr : Expression;
|
|
Result : Extended;
|
|
Args: array[0..2] of Extended;
|
|
begin
|
|
// Examples with compiling
|
|
// -----------------------
|
|
|
|
// EXAMPLE 4 -- 1 Variable Example (pass by value)
|
|
// -----------------------------------------------
|
|
SinC := CompileExpr(ParseExpr('sin(x)/x',['x']),tyPass1V); // parse and compile expression
|
|
Result := SinC(1.0); // evaluate the Expression
|
|
FreeFunc(@SinC); // Free Function
|
|
ShowMessage('Result = '+floattostr(Result));
|
|
|
|
// EXAMPLE 5 -- 2 Variables Example (pass by value)
|
|
// ------------------------------------------------
|
|
SinExp := CompileExpr(ParseExpr('sin(x)*exp(y)',['x','y']),tyPass2V); // parse and compile expression
|
|
Result := SinExp(2.0,3.0); // evaluate the Expression
|
|
FreeFunc(@SinExp); // Free Function
|
|
ShowMessage('Result = '+floattostr(Result));
|
|
|
|
// EXAMPLE 6 -- 3 Variables Example (pass by reference)
|
|
// ----------------------------------------------------
|
|
Sum_abc := CompileExpr(ParseExpr('a+b+c',['a','b','c'])); // parse and compile expression
|
|
Args[0] := 1.0; // a = 1.0
|
|
Args[1] := 2.0; // b = 2.0
|
|
Args[2] := 3.0; // c = 3.0
|
|
Result := Sum_abc(Args); // evaluate the Expression
|
|
FreeFunc(@Sum_abc); // Free Function
|
|
ShowMessage('Result = '+floattostr(Result));
|
|
|
|
// EXAMPLE 7 -- Evaluate without compiling (evaluate from bytecode)
|
|
// ----------------------------------------------------------------
|
|
Expr := ParseExpr('sin(x*2*pi/maxX)*cos(y*2*pi/maxY)/2+0.5',['x','y','maxX','maxY']);
|
|
if Expr.Error then
|
|
begin
|
|
ShowMessage('Syntax error!');
|
|
exit;
|
|
end;
|
|
Result := EvalExpr(Expr,[2,3,200,100]); // x=2, y=3, maxX=200, maxY=100
|
|
end;
|
|
|
|
- List of internal functions ---------------------------------------------------
|
|
abs,sin,cos,tan,cot,arcsin,arccos,arctan,arccot,ln,log,lb,exp,sqrt,sqr,round,
|
|
trunc,frac,heaviside,sign
|
|
|
|
- Constants --------------------------------------------------------------------
|
|
pi,e
|
|
|
|
- Operators --------------------------------------------------------------------
|
|
+,-,/,*,^
|
|
|
|
Note: x^y^z = x^(y^z)
|
|
}
|
|
|
|
{$define ErrCode} // Generate detailed syntax error messages? (ErrCode, ErrPos)
|
|
// Disable for faster compilation (10%-20% faster)
|
|
{$define MultDefaultOp} // Multiplication as default operator? (Allow expressions like "2x")
|
|
|
|
{$booleval off}
|
|
{$warnings off}
|
|
{$ifdef VER170}
|
|
{$inline auto}
|
|
{$endif}
|
|
|
|
unit parser;
|
|
|
|
interface
|
|
|
|
uses
|
|
Math, SysUtils;
|
|
|
|
Type
|
|
{$ifdef ErrCode}
|
|
parseErrEnum =
|
|
(parseErr_NoErr,parseErr_OpenBracket,parseErr_UnknownVariableOrConstant,
|
|
parseErr_InvalidNumber,parseErr_NumberVarFuncOrBracketExpected,
|
|
parseErr_OperatorExpected,parseErr_UnknownFunction);
|
|
|
|
parseErrInfo = record
|
|
ErrPos: Integer;
|
|
ErrCode: parseErrEnum;
|
|
end;
|
|
{$endif}
|
|
|
|
Expression = record
|
|
Bytecode: array[0..255] of Byte;
|
|
Consts: array of Extended;
|
|
{$ifdef ErrCode}
|
|
ErrInfo: parseErrInfo;
|
|
{$endif}
|
|
Error: Boolean;
|
|
end;
|
|
|
|
tyPassType = (tyPassRef,tyPass1V,tyPass2V);
|
|
|
|
ExprFuncR = function(var Args): Extended;
|
|
ExprFunc1V = function(const x: Extended): Extended;
|
|
ExprFunc2V = function(const x,y: Extended): Extended;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// - Interface wrapper ---------------------------------------------------------
|
|
// -----------------------------------------------------------------------------
|
|
type
|
|
IExpr = interface
|
|
function compiled: Boolean;
|
|
{$ifdef ErrCode}
|
|
function getErrInfo: parseErrInfo;
|
|
function getErrStr: String;
|
|
{$endif}
|
|
end;
|
|
|
|
IExpr1V = interface(IExpr)
|
|
function Eval(const x: Extended): Extended;
|
|
end;
|
|
|
|
IExpr2V = interface(IExpr)
|
|
function Eval(const x,y: Extended): Extended;
|
|
end;
|
|
|
|
IExprR = interface(IExpr)
|
|
function Eval(var Args: array of Extended): Extended;
|
|
end;
|
|
|
|
function compileStr1V(const Formula: String): IExpr1V; overload;
|
|
function compileStr2V(const Formula: String): IExpr2V; overload;
|
|
function compileStr1V(const Formula: String; const Vars: array of Const): IExpr1V; overload;
|
|
function compileStr2V(const Formula: String; const Vars: array of Const): IExpr2V; overload;
|
|
function compileStrR(const Formula: String; const Vars: array of Const): IExprR;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// - Parser and compiler -------------------------------------------------------
|
|
// -----------------------------------------------------------------------------
|
|
|
|
function ParseExpr(const S: String): Expression; overload;
|
|
function ParseExpr(const S: String; const Variables: array of const): Expression; overload;
|
|
function EvalExpr(const ByteCode: Expression): Extended; overload;
|
|
function EvalExpr(const ByteCode: Expression; const Variables: array of const): Extended; overload;
|
|
|
|
function CompileExpr(const Bytecode: Expression; PT: tyPassType = tyPassRef): Pointer;
|
|
procedure FreeFunc(E: Pointer);
|
|
|
|
{$ifdef ErrCode}
|
|
function FormatError(const ErrInfo: parseErrInfo): String;
|
|
{$endif}
|
|
|
|
implementation
|
|
|
|
uses windows;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// - Interface wrapper ---------------------------------------------------------
|
|
// -----------------------------------------------------------------------------
|
|
const
|
|
evalExStr = 'Cannot evaluate expression due to a syntax error.';
|
|
|
|
type
|
|
TExprFunction = class(TInterfacedObject)
|
|
{$ifdef ErrCode}
|
|
private
|
|
FErrInfo: parseErrInfo;
|
|
public
|
|
function getErrInfo: parseErrInfo;
|
|
function getErrStr: String;
|
|
{$endif}
|
|
end;
|
|
|
|
TExprFunction1V = class (TExprFunction,IExpr1V)
|
|
public
|
|
constructor Create(const S: String); overload;
|
|
constructor Create(const S: String; const Vars: array of Const); overload;
|
|
destructor Destroy; override;
|
|
function Eval(const x: Extended): Extended;
|
|
private
|
|
FFunc: ExprFunc1V;
|
|
function compiled: Boolean;
|
|
end;
|
|
|
|
TExprFunction2V = class (TExprFunction,IExpr2V)
|
|
public
|
|
constructor Create(const S: String); overload;
|
|
constructor Create(const S: String; const Vars: array of Const); overload;
|
|
destructor Destroy; override;
|
|
function Eval(const x,y: Extended): Extended;
|
|
private
|
|
FFunc: ExprFunc2V;
|
|
function compiled: Boolean;
|
|
end;
|
|
|
|
TExprFunctionR = class (TExprFunction,IExprR)
|
|
public
|
|
constructor Create(const S: String; const Vars: array of Const);
|
|
destructor Destroy; override;
|
|
function Eval(var Args: array of Extended): Extended;
|
|
private
|
|
FFunc: ExprFuncR;
|
|
FArgCount: Integer;
|
|
function compiled: Boolean;
|
|
end;
|
|
|
|
{$ifdef ErrCode}
|
|
function TExprFunction.getErrInfo: parseErrInfo;
|
|
begin
|
|
Result := FErrInfo;
|
|
end;
|
|
|
|
function TExprFunction.getErrStr: String;
|
|
begin
|
|
Result := FormatError(FErrInfo);
|
|
end;
|
|
{$endif}
|
|
|
|
constructor TExprFunction1V.Create(const S: String);
|
|
Var
|
|
Expr: Expression;
|
|
begin
|
|
Expr := ParseExpr(S,['x']);
|
|
if not Expr.Error then
|
|
FFunc := CompileExpr(Expr,tyPass1V)
|
|
{$ifdef ErrCode}
|
|
else
|
|
FErrInfo := Expr.ErrInfo;
|
|
{$endif}
|
|
end;
|
|
|
|
function TExprFunction1V.compiled: Boolean;
|
|
begin
|
|
Result := @FFunc <> nil;
|
|
end;
|
|
|
|
constructor TExprFunction1V.Create(const S: String; const Vars: array of Const);
|
|
Var
|
|
Expr: Expression;
|
|
begin
|
|
if length(Vars) <> 1 then
|
|
raise EInvalidArgument.Create('Wrong variable count: One variable expected.');
|
|
Expr := ParseExpr(S,Vars);
|
|
if not Expr.Error then
|
|
FFunc := CompileExpr(Expr,tyPass1V)
|
|
{$ifdef ErrCode}
|
|
else
|
|
FErrInfo := Expr.ErrInfo;
|
|
{$endif}
|
|
end;
|
|
|
|
destructor TExprFunction1V.Destroy;
|
|
begin
|
|
if @FFunc <> nil then
|
|
FreeFunc(@FFunc);
|
|
inherited;
|
|
end;
|
|
|
|
function TExprFunction1V.Eval(const x: Extended): Extended;
|
|
begin
|
|
if @FFunc = nil then
|
|
raise Exception.Create(evalExStr);
|
|
Result := FFunc(x);
|
|
end;
|
|
|
|
constructor TExprFunction2V.Create(const S: String);
|
|
Var
|
|
Expr: Expression;
|
|
begin
|
|
Expr := ParseExpr(S,['x','y']);
|
|
if not Expr.Error then
|
|
FFunc := CompileExpr(Expr,tyPass2V)
|
|
{$ifdef ErrCode}
|
|
else
|
|
FErrInfo := Expr.ErrInfo;
|
|
{$endif}
|
|
end;
|
|
|
|
function TExprFunction2V.compiled: Boolean;
|
|
begin
|
|
Result := @FFunc <> nil;
|
|
end;
|
|
|
|
constructor TExprFunction2V.Create(const S: String; const Vars: array of Const);
|
|
Var
|
|
Expr: Expression;
|
|
begin
|
|
if length(Vars) <> 2 then
|
|
raise EInvalidArgument.Create('Wrong variables count: Two variables expected.');
|
|
Expr := ParseExpr(S,Vars);
|
|
if not Expr.Error then
|
|
FFunc := CompileExpr(Expr,tyPass2V)
|
|
{$ifdef ErrCode}
|
|
else
|
|
FErrInfo := Expr.ErrInfo;
|
|
{$endif}
|
|
end;
|
|
|
|
destructor TExprFunction2V.Destroy;
|
|
begin
|
|
if @FFunc <> nil then
|
|
FreeFunc(@FFunc);
|
|
inherited;
|
|
end;
|
|
|
|
function TExprFunction2V.Eval(const x,y: Extended): Extended;
|
|
begin
|
|
if @FFunc = nil then
|
|
raise Exception.Create(evalExStr);
|
|
Result := FFunc(x,y);
|
|
end;
|
|
|
|
function TExprFunctionR.compiled: Boolean;
|
|
begin
|
|
Result := @FFunc <> nil;
|
|
end;
|
|
|
|
constructor TExprFunctionR.Create(const S: String; const Vars: array of Const);
|
|
Var
|
|
Expr: Expression;
|
|
begin
|
|
FArgCount := length(Vars);
|
|
Expr := ParseExpr(S,Vars);
|
|
if not Expr.Error then
|
|
FFunc := CompileExpr(Expr)
|
|
{$ifdef ErrCode}
|
|
else
|
|
FErrInfo := Expr.ErrInfo;
|
|
{$endif}
|
|
end;
|
|
|
|
destructor TExprFunctionR.Destroy;
|
|
begin
|
|
if @FFunc <> nil then
|
|
FreeFunc(@FFunc);
|
|
inherited;
|
|
end;
|
|
|
|
function TExprFunctionR.Eval(var Args: array of Extended): Extended;
|
|
begin
|
|
if @FFunc = nil then
|
|
raise Exception.Create(evalExStr);
|
|
if length(Args) <> FArgCount then
|
|
raise EInvalidArgument.Create(Format('Wrong argument count: %d argument(s) expected.',[FArgCount]));
|
|
Result := FFunc(args[0]);
|
|
end;
|
|
|
|
function compileStr1V(const Formula: String): IExpr1V;
|
|
begin
|
|
Result := TExprFunction1V.Create(Formula);
|
|
end;
|
|
|
|
function compileStr2V(const Formula: String): IExpr2V;
|
|
begin
|
|
Result := TExprFunction2V.Create(Formula);
|
|
end;
|
|
|
|
function compileStr1V(const Formula: String; const Vars: array of Const): IExpr1V;
|
|
begin
|
|
Result := TExprFunction1V.Create(Formula, Vars);
|
|
end;
|
|
|
|
function compileStr2V(const Formula: String; const Vars: array of Const): IExpr2V;
|
|
begin
|
|
Result := TExprFunction2V.Create(Formula, Vars);
|
|
end;
|
|
|
|
function compileStrR(const Formula: String; const Vars: array of Const): IExprR;
|
|
begin
|
|
Result := TExprFunctionR.Create(Formula, Vars);
|
|
end;
|
|
|
|
// -----------------------------------------------------------------------------
|
|
// - Parser and compiler -------------------------------------------------------
|
|
// -----------------------------------------------------------------------------
|
|
|
|
Type
|
|
EFuncs = (_sin,_cos,_tan,_cot,_arcsin,_arccos,_arctan,_arccot,_ln,_lb,_log,
|
|
_exp,_sqrt,_sqr,_sign,_abs,_frac,_round,_trunc,_heaviside,_invalid);
|
|
EConst = (_pi,_e,_one,_zero);
|
|
EOpCodes = (OpEnd,OpVar,OpConst,OpIConst,OpAdd,OpSub,OpMul,OpDiv,OpHoch,OpNeg,
|
|
OpFunc);
|
|
|
|
function getLastErrorMsg: String;
|
|
var
|
|
buf: array[0..MAX_PATH] of Char;
|
|
begin
|
|
ZeroMemory(@buf,sizeof(buf));
|
|
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError, 0, buf, sizeof(buf), nil);
|
|
Result := Buf;
|
|
end;
|
|
|
|
Function ParseExpr(const S: String): Expression;
|
|
begin
|
|
Result := parseExpr(S, []);
|
|
end;
|
|
|
|
{$ifdef ErrCode}
|
|
Function FormatError(const ErrInfo: parseErrInfo): String;
|
|
const
|
|
ErrPrefix = 'Error on char %d: ';
|
|
begin
|
|
with ErrInfo do
|
|
Case ErrCode of
|
|
parseErr_OperatorExpected:
|
|
Result := Format(ErrPrefix+'Operator expected',[ErrPos]);
|
|
parseErr_UnknownVariableOrConstant:
|
|
Result := Format(ErrPrefix+'Unknown variable or constant',[ErrPos]);
|
|
parseErr_UnknownFunction:
|
|
Result := Format(ErrPrefix+'Unknown function',[ErrPos]);
|
|
parseErr_InvalidNumber:
|
|
Result := Format(ErrPrefix+'Invalid number',[ErrPos]);
|
|
parseErr_NumberVarFuncOrBracketExpected:
|
|
Result := Format(ErrPrefix+'Number, variable, constant, function or parenthesis expected',[ErrPos]);
|
|
parseErr_OpenBracket:
|
|
Result := Format(ErrPrefix+'")" or operator expected',[ErrPos])
|
|
else
|
|
Result := 'ParseExpr: Unknown syntax error';
|
|
end;
|
|
end;
|
|
{$endif}
|
|
|
|
Function ParseExpr(const S: String; const Variables: array of const): Expression;
|
|
type
|
|
OutputType = record
|
|
Length: Integer;
|
|
Wert: Extended;
|
|
end;
|
|
Var
|
|
CodePos: Integer;
|
|
globalResult: Expression;
|
|
ConstCount: Integer;
|
|
{$ifdef ErrCode}
|
|
ErrorStrPos: PChar;
|
|
{$endif}
|
|
Type
|
|
cTyp = (cPlusMinus,cMultDiv,cPower,cOpenPar,cClosePar,cUndefined,cDot,cExp);
|
|
|
|
function parseWholeNum(SubExpr: PChar; var Output: OutputType): Boolean; forward;
|
|
function parseVarFunc(SubExpr: PChar; var ExprLen: Integer): Boolean; forward;
|
|
function parseFactor(SubExpr: PChar; var ExprLen: Integer): Boolean; forward;
|
|
function parseParExpr(SubExpr: PChar; var ExprLen: Integer): Boolean; forward;
|
|
function parseMultiplication(SubExpr: PChar; var ExprLen: Integer): Boolean; forward;
|
|
function parseAddition(SubExpr: PChar; var ExprLen: Integer): Boolean; forward;
|
|
function parseRealnum(SubExpr: PChar; var ExprLen : Integer): Boolean; forward;
|
|
|
|
function SkipWhiteSpace(var SubExpr: PChar): Integer;
|
|
begin
|
|
Result := 0;
|
|
while (SubExpr^<>#0) and (SubExpr^=' ') do
|
|
begin
|
|
inc(SubExpr);
|
|
inc(Result);
|
|
end;
|
|
end;
|
|
|
|
const
|
|
parseInvalidTypeStr = 'ParseExpr: Invalid variable type';
|
|
|
|
function getVarNo(const aVarName: Char): Integer;
|
|
var
|
|
I: Integer;
|
|
VarName: Char;
|
|
begin
|
|
for I := 0 to High(Variables) do
|
|
begin
|
|
with Variables[I] do
|
|
case VType of
|
|
vtString,
|
|
vtPChar,
|
|
vtAnsiString:;
|
|
vtChar: VarName := VChar
|
|
else
|
|
raise EInvalidArgument.Create(parseInvalidTypeStr);
|
|
end;
|
|
if VarName = aVarName then
|
|
begin
|
|
Result := I;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function getLongVarNo(const aVarName: String): Integer;
|
|
var
|
|
I: Integer;
|
|
VarName: String;
|
|
begin
|
|
for I := 0 to High(Variables) do
|
|
begin
|
|
with Variables[I] do
|
|
case VType of
|
|
vtChar:;
|
|
vtString: VarName := VString^;
|
|
vtPChar: VarName := VPChar;
|
|
vtAnsiString: VarName := string(VAnsiString)
|
|
else
|
|
raise EInvalidArgument.Create(parseInvalidTypeStr);
|
|
end;
|
|
if VarName = aVarName then
|
|
begin
|
|
Result := I;
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function parseChrType(SubExpr: PChar; Typ: cTyp; var Operation: Char; var ExprLen: Integer): Boolean;
|
|
Var
|
|
sTyp: cTyp;
|
|
begin
|
|
ExprLen := SkipWhiteSpace(SubExpr)+1;
|
|
sTyp := cUndefined;
|
|
if SubExpr^ <> #0 then
|
|
case SubExpr^ of
|
|
'^': sTyp := cPower;
|
|
'.',',': sTyp := cDot;
|
|
'+','-': sTyp := cPlusMinus;
|
|
'*','/': sTyp := cMultDiv;
|
|
'(': sTyp := cOpenPar;
|
|
')': sTyp := cClosePar;
|
|
'e','E': sTyp := cExp;
|
|
end;
|
|
if sTyp = Typ then
|
|
begin
|
|
Operation := SubExpr^;
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
function parseAlphaNum(SubExpr: PChar; var Output: Char): Boolean;
|
|
begin
|
|
if SubExpr^ = #0 then
|
|
begin
|
|
result := False;
|
|
exit;
|
|
end;
|
|
Case SubExpr^ of
|
|
'0'..'9','A'..'Z','a'..'z':
|
|
begin
|
|
Output := SubExpr^;
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
function parseWholeNum(SubExpr: PChar; var Output: OutputType): Boolean;
|
|
Var
|
|
Count: Integer;
|
|
C: Char;
|
|
begin
|
|
Output.Wert := 0;
|
|
Count := 0;
|
|
if SubExpr^ <> #0 then
|
|
begin
|
|
C := SubExpr^;
|
|
while (C>='0')and(C<='9') do
|
|
begin
|
|
inc(Count);
|
|
Output.Wert := Output.Wert*10 + (ord(SubExpr^)-ord('0'));
|
|
inc(SubExpr);
|
|
if SubExpr^ = #0 then break;
|
|
C := SubExpr^;
|
|
end;
|
|
Output.Length := Count;
|
|
end;
|
|
Result := Count > 0;
|
|
end;
|
|
|
|
function getFunNo(const S: String): EFuncs;
|
|
begin
|
|
Result := _invalid;
|
|
Case S[1] of
|
|
'a': if S = 'abs' then
|
|
Result := _abs else
|
|
if S = 'arcsin' then
|
|
Result := _arcsin else
|
|
if S = 'arccos' then
|
|
Result := _arccos else
|
|
if S = 'arctan' then
|
|
Result := _arctan else
|
|
if S = 'arccot' then
|
|
Result := _arccot;
|
|
'c': if S = 'cos' then
|
|
Result := _cos else
|
|
if S = 'cot' then
|
|
Result := _cot;
|
|
'e': if S = 'exp' then
|
|
Result := _exp;
|
|
'f': if S = 'frac' then
|
|
Result := _frac;
|
|
'h': if S = 'heaviside' then
|
|
Result := _heaviside;
|
|
'r': if S = 'round' then
|
|
Result := _round;
|
|
's': if S = 'sin' then
|
|
Result := _sin else
|
|
if S = 'sqrt' then
|
|
Result := _sqrt else
|
|
if S = 'sqr' then
|
|
Result := _sqr else
|
|
if S = 'sign' then
|
|
Result := _sign;
|
|
'l': if S = 'ln' then
|
|
Result := _ln else
|
|
if S = 'log' then
|
|
Result := _log else
|
|
if S = 'lb' then
|
|
Result := _lb;
|
|
't': if S = 'tan' then
|
|
Result := _tan else
|
|
if S = 'trunc' then
|
|
Result := _trunc;
|
|
end;
|
|
end;
|
|
|
|
function parseVarFunc(SubExpr: PChar; var ExprLen: Integer): Boolean;
|
|
Var
|
|
C: Char;
|
|
St: String;
|
|
Klammer: Integer;
|
|
Temp: Integer;
|
|
{$ifdef ErrCode}
|
|
oldSubExpr: PChar;
|
|
{$endif}
|
|
begin
|
|
St := '';
|
|
while parseAlphaNum(SubExpr, C) do
|
|
begin
|
|
St := St + C;
|
|
inc(SubExpr);
|
|
end;
|
|
if St <> '' then
|
|
begin
|
|
{$ifdef ErrCode}
|
|
oldSubExpr := SubExpr;
|
|
{$endif}
|
|
ExprLen := length(St)+SkipWhiteSpace(SubExpr);
|
|
if SubExpr^ = '(' then
|
|
begin
|
|
Temp := Byte(getFunNo(St));
|
|
if EFuncs(Temp) <> _invalid then
|
|
begin
|
|
if parseParExpr(SubExpr, Klammer) then
|
|
begin
|
|
inc(ExprLen, Klammer);
|
|
globalResult.Bytecode[CodePos] := Byte(OpFunc); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Temp; inc(CodePos);
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
end else
|
|
begin
|
|
{$ifdef ErrCode}
|
|
Result := False;
|
|
if globalResult.ErrInfo.ErrCode = parseErr_NoErr then
|
|
begin
|
|
globalResult.ErrInfo.ErrCode := parseErr_UnknownFunction;
|
|
ErrorStrPos := oldSubExpr;
|
|
end;
|
|
exit;
|
|
{$endif}
|
|
end;
|
|
end else
|
|
begin
|
|
if length(St) = 1 then
|
|
begin
|
|
Temp := getVarNo(St[1]);
|
|
if Temp >= 0 then
|
|
begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpVar); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Temp; inc(CodePos);
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end else
|
|
if St[1] = 'e' then
|
|
begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Byte(_e); inc(CodePos);
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
end else
|
|
begin
|
|
Temp := getLongVarNo(St);
|
|
if Temp >= 0 then
|
|
begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpVar); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Temp; inc(CodePos);
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end else
|
|
if St = 'pi' then
|
|
begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Byte(_pi); inc(CodePos);
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
Result := False;
|
|
{$ifdef ErrCode}
|
|
if globalResult.ErrInfo.ErrCode = parseErr_NoErr then
|
|
begin
|
|
globalResult.ErrInfo.ErrCode := parseErr_UnknownVariableOrConstant;
|
|
ErrorStrPos := oldSubExpr;
|
|
end;
|
|
{$endif}
|
|
end;
|
|
|
|
function parseRealNum(SubExpr: PChar; var ExprLen: Integer): Boolean;
|
|
Var
|
|
GanzZahl, NachKomma, Exp: OutputType;
|
|
Value: Extended;
|
|
ignore, Vorzeichen: Char;
|
|
Index, Chr: Integer;
|
|
AlreadyExists, Success: Boolean;
|
|
begin
|
|
Result := False;
|
|
try
|
|
if parseWholeNum(SubExpr, GanzZahl) then
|
|
begin
|
|
inc(SubExpr, GanzZahl.Length);
|
|
if parseChrType(SubExpr, cDot,ignore, Chr) then
|
|
begin
|
|
if Chr <> 1 then
|
|
exit;
|
|
inc(SubExpr, Chr);
|
|
if parseWholeNum(SubExpr, NachKomma) then
|
|
begin
|
|
inc(SubExpr, NachKomma.Length);
|
|
ExprLen := GanzZahl.Length + Chr + NachKomma.Length;
|
|
Value := GanzZahl.Wert + NachKomma.Wert / Power(10, NachKomma.Length);
|
|
end else
|
|
exit;
|
|
end else
|
|
begin
|
|
Value := GanzZahl.Wert;
|
|
ExprLen := GanzZahl.Length;
|
|
end;
|
|
if parseChrType(SubExpr, cExp,ignore, Chr) then
|
|
begin
|
|
if Chr <> 1 then
|
|
exit;
|
|
inc(SubExpr, Chr);
|
|
inc(ExprLen, Chr);
|
|
if parseChrType(SubExpr, cPlusMinus,Vorzeichen, Chr) then
|
|
begin
|
|
if Chr <> 1 then
|
|
exit;
|
|
inc(SubExpr, Chr);
|
|
inc(ExprLen, Chr);
|
|
end else
|
|
Vorzeichen := '+'; // Standardvorzeichen
|
|
if parseWholeNum(SubExpr, Exp) then
|
|
begin
|
|
inc(ExprLen, Exp.Length);
|
|
if Vorzeichen = '-' then
|
|
Exp.Wert := -Exp.Wert;
|
|
Value := Value*Power(10,Exp.Wert);
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
end else
|
|
begin
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
end;
|
|
finally
|
|
if result then
|
|
begin
|
|
Success := False;
|
|
if Frac(Value)=0 then
|
|
begin
|
|
Case Trunc(Value) of
|
|
0: begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Byte(_zero); inc(CodePos);
|
|
Success := True;
|
|
end;
|
|
1: begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpIConst); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Byte(_one); inc(CodePos);
|
|
Success := True;
|
|
end;
|
|
end;
|
|
end;
|
|
if not Success then
|
|
begin
|
|
AlreadyExists := False;
|
|
For Index := 0 to ConstCount-1 do // look for duplicate constant
|
|
if Value = globalResult.Consts[Index] then
|
|
begin
|
|
AlreadyExists := True;
|
|
break;
|
|
end;
|
|
if not AlreadyExists then
|
|
begin
|
|
Index := ConstCount;
|
|
inc(ConstCount);
|
|
SetLength(globalResult.Consts, Index+1);
|
|
globalResult.Consts[Index] := Value;
|
|
end;
|
|
globalResult.Bytecode[CodePos] := Byte(OpConst); inc(CodePos);
|
|
globalResult.Bytecode[CodePos] := Index; inc(CodePos);
|
|
end;
|
|
end else
|
|
begin // if result = false
|
|
{$ifdef ErrCode}
|
|
if globalResult.ErrInfo.ErrCode = parseErr_NoErr then
|
|
begin
|
|
globalResult.ErrInfo.ErrCode := parseErr_InvalidNumber;
|
|
ErrorStrPos := SubExpr;
|
|
end;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function parseParExpr(SubExpr: Pchar; var ExprLen: Integer): Boolean;
|
|
var
|
|
ignore: Char;
|
|
Ausdruck, Chr1, Chr2: Integer;
|
|
begin
|
|
if parseChrType(SubExpr, cOpenPar, ignore, Chr1) then
|
|
begin
|
|
inc(SubExpr, Chr1);
|
|
if parseAddition(SubExpr, Ausdruck) then
|
|
begin
|
|
inc(SubExpr, Ausdruck);
|
|
if parseChrType(SubExpr, cClosePar, ignore, Chr2) then
|
|
begin
|
|
ExprLen := Chr1 + Ausdruck + Chr2;
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end else
|
|
begin
|
|
{$ifdef ErrCode}
|
|
if globalResult.ErrInfo.ErrCode = parseErr_NoErr then
|
|
begin
|
|
globalResult.ErrInfo.ErrCode := parseErr_OpenBracket;
|
|
ErrorStrPos := SubExpr;
|
|
end;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
function parseSem(SubExpr: PChar; var ExprLen: Integer): Boolean;
|
|
Var Spaces: Integer;
|
|
begin
|
|
Spaces := SkipWhiteSpace(SubExpr);
|
|
if SubExpr^ = #0 then
|
|
begin
|
|
Result := False;
|
|
{$ifdef ErrCode}
|
|
if globalResult.ErrInfo.ErrCode = parseErr_NoErr then
|
|
begin
|
|
globalResult.ErrInfo.ErrCode := parseErr_NumberVarFuncOrBracketExpected;
|
|
ErrorStrPos := SubExpr;
|
|
end;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
case SubExpr^ of
|
|
'0'..'9' : Result := parseRealnum(SubExpr, ExprLen);
|
|
'a'..'z','A'..'Z' : Result := parseVarFunc(SubExpr, ExprLen);
|
|
'(': Result := parseParExpr(SubExpr, ExprLen) else
|
|
begin
|
|
Result := False;
|
|
{$ifdef ErrCode}
|
|
if globalResult.ErrInfo.ErrCode = parseErr_NoErr then
|
|
begin
|
|
globalResult.ErrInfo.ErrCode := parseErr_NumberVarFuncOrBracketExpected;
|
|
ErrorStrPos := SubExpr;
|
|
end;
|
|
{$endif}
|
|
end;
|
|
end;
|
|
inc(ExprLen, Spaces);
|
|
end;
|
|
|
|
function parseFactor(SubExpr: PChar; var ExprLen: Integer): Boolean;
|
|
Var
|
|
Exponent, Chr: Integer;
|
|
Operation: Char;
|
|
begin
|
|
if parseChrType(SubExpr, cPlusMinus, Operation, Chr) then // Vorzeichen?
|
|
if parseFactor(SubExpr+Chr, Exponent) then
|
|
begin
|
|
ExprLen := Chr + Exponent;
|
|
Case Operation of
|
|
'-': begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpNeg); inc(CodePos);
|
|
end;
|
|
'+': begin
|
|
end;
|
|
end;
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
if parseSem(SubExpr, Exponent) then
|
|
begin
|
|
inc(SubExpr, Exponent);
|
|
if parseChrType(SubExpr, cPower, Operation, Chr) then
|
|
begin
|
|
inc(SubExpr, Chr);
|
|
if parseFactor(SubExpr, ExprLen) then
|
|
begin
|
|
ExprLen := Exponent + Chr + ExprLen;
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
globalResult.Bytecode[CodePos] := Byte(OpHoch); inc(CodePos);
|
|
exit;
|
|
end;
|
|
end else
|
|
begin
|
|
ExprLen := Exponent;
|
|
Result := True;
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
{$endif}
|
|
exit;
|
|
end;
|
|
end;
|
|
Result := False;
|
|
end;
|
|
|
|
function parseMultiplication(SubExpr: PChar; var ExprLen: Integer): Boolean;
|
|
var
|
|
Faktor, Chr: Integer;
|
|
Operation: Char;
|
|
Pending: Boolean;
|
|
Count: Integer;
|
|
begin
|
|
ExprLen := 0;
|
|
Count := 0;
|
|
Pending := False;
|
|
while parseFactor(SubExpr, Faktor) do
|
|
begin
|
|
Pending := False;
|
|
inc(ExprLen, Faktor);
|
|
inc(SubExpr, Faktor);
|
|
if Count > 0 then
|
|
Case Operation of
|
|
'*': begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpMul); inc(CodePos);
|
|
end;
|
|
'/': begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpDiv); inc(CodePos);
|
|
end;
|
|
end;
|
|
inc(Count);
|
|
{$ifdef MultDefaultOp}
|
|
Inc(ExprLen, SkipWhiteSpace(SubExpr));
|
|
Case SubExpr^ of
|
|
#0: break;
|
|
'+','-': break;
|
|
end;
|
|
{$endif}
|
|
if parseChrType(SubExpr, cMultDiv, Operation, Chr) then
|
|
begin
|
|
Pending := True;
|
|
inc(SubExpr, Chr);
|
|
inc(ExprLen, Chr);
|
|
end else
|
|
{$ifdef MultDefaultOp}
|
|
Operation := '*';
|
|
{$else}
|
|
break;
|
|
{$endif}
|
|
end;
|
|
Result := (Count>=1) and not Pending;
|
|
end;
|
|
|
|
function parseAddition(SubExpr: PChar; var ExprLen: Integer): Boolean;
|
|
var
|
|
Term: Integer;
|
|
Operation: Char;
|
|
Pending: Boolean;
|
|
Count, Chr: Integer;
|
|
begin
|
|
ExprLen := 0;
|
|
Count := 0;
|
|
Pending := False;
|
|
while parseMultiplication(SubExpr, Term) do
|
|
begin
|
|
Pending := False;
|
|
inc(ExprLen, Term);
|
|
inc(SubExpr, Term);
|
|
if Count > 0 then
|
|
Case Operation of
|
|
'+': begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpAdd); inc(CodePos);
|
|
end;
|
|
'-': begin
|
|
globalResult.Bytecode[CodePos] := Byte(OpSub); inc(CodePos);
|
|
end;
|
|
end;
|
|
inc(Count);
|
|
if parseChrType(SubExpr, cPlusMinus, Operation, Chr) then
|
|
begin
|
|
Pending := True;
|
|
inc(SubExpr, Chr);
|
|
inc(ExprLen, Chr);
|
|
end else break;
|
|
end;
|
|
Result := (Count>=1) and not Pending;
|
|
inc(ExprLen, SkipWhiteSpace(SubExpr));
|
|
end;
|
|
Var
|
|
ExprLen: Integer;
|
|
begin
|
|
CodePos := 0;
|
|
ConstCount := 0;
|
|
globalResult.Consts := nil;
|
|
ZeroMemory(@globalResult, SizeOf(globalResult));
|
|
{$ifdef ErrCode}
|
|
globalResult.ErrInfo.ErrCode := parseErr_NoErr;
|
|
globalResult.ErrInfo.ErrPos := -1;
|
|
ErrorStrPos := nil;
|
|
{$endif}
|
|
globalResult.Error := not (parseAddition(PChar(S), ExprLen) and
|
|
(ExprLen = length(S)));
|
|
{$ifdef ErrCode}
|
|
with globalResult do
|
|
if Error then
|
|
if (ErrInfo.ErrCode = parseErr_NoErr) and (ExprLen <> length(S)) then
|
|
begin
|
|
ErrInfo.ErrCode := parseErr_OperatorExpected;
|
|
ErrInfo.ErrPos := ExprLen;
|
|
end else
|
|
if ErrorStrPos <> nil then
|
|
ErrInfo.ErrPos := ErrorStrPos-PChar(S)
|
|
else
|
|
ErrInfo.ErrPos := 0;
|
|
{$endif}
|
|
globalResult.Bytecode[CodePos] := Byte(OpEnd); inc(CodePos);
|
|
Result := globalResult;
|
|
end;
|
|
|
|
function EvalExpr(const Bytecode: Expression): Extended;
|
|
begin
|
|
Result := evalExpr(Bytecode, []);
|
|
end;
|
|
|
|
function EvalExpr(const Bytecode: Expression; const Variables: array of const): Extended;
|
|
Type
|
|
PExtended = ^Extended;
|
|
Var
|
|
Stack: array[0..31] of Extended; // No check for overflow
|
|
_SP: PExtended; // Stack Pointer
|
|
_IP: Integer; // Instruction Pointer
|
|
Temp: Extended;
|
|
Befehl: EOpCodes;
|
|
begin
|
|
if Bytecode.Error then
|
|
begin
|
|
Result := NaN;
|
|
exit;
|
|
end;
|
|
_IP := 0;
|
|
_SP := @Stack[0];
|
|
Befehl := EOpCodes(ByteCode.Bytecode[0]);
|
|
while Befehl <> OpEnd do
|
|
begin
|
|
inc(_IP);
|
|
Case Befehl of
|
|
OpVar:
|
|
begin
|
|
if Bytecode.Bytecode[_IP] > High(Variables) then
|
|
raise EInvalidArgument.Create('EvalExpr: Not enough arguments.');
|
|
with Variables[Bytecode.Bytecode[_IP]] do
|
|
case VType of
|
|
vtExtended: _SP^ := VExtended^;
|
|
vtInteger: _SP^ := VInteger;
|
|
vtInt64: _SP^ := VInt64^ else
|
|
raise EInvalidArgument.Create('EvalExpr: Invalid argument format.');
|
|
end;
|
|
inc(_SP);
|
|
inc(_IP);
|
|
end;
|
|
OpConst:
|
|
begin
|
|
_SP^ := ByteCode.Consts[ByteCode.Bytecode[_IP]];
|
|
inc(_SP);
|
|
inc(_IP);
|
|
end;
|
|
OpIConst:
|
|
begin
|
|
Case EConst(ByteCode.Bytecode[_IP]) of
|
|
_pi : _SP^ := pi;
|
|
_e : _SP^ := exp(1);
|
|
_one : _SP^ := 1;
|
|
_zero: _SP^ := 0;
|
|
end;
|
|
inc(_SP);
|
|
inc(_IP);
|
|
end;
|
|
OpAdd:
|
|
begin
|
|
dec(_SP);
|
|
Temp := _SP^;
|
|
dec(_SP);
|
|
_SP^ := _SP^ + Temp;
|
|
inc(_SP);
|
|
end;
|
|
OpSub:
|
|
begin
|
|
dec(_SP);
|
|
Temp := _SP^;
|
|
dec(_SP);
|
|
_SP^ := _SP^ - Temp;
|
|
inc(_SP);
|
|
end;
|
|
OpMul:
|
|
begin
|
|
dec(_SP);
|
|
Temp := _SP^;
|
|
dec(_SP);
|
|
_SP^ := _SP^ * Temp;
|
|
inc(_SP);
|
|
end;
|
|
OpDiv:
|
|
begin
|
|
dec(_SP);
|
|
Temp := _SP^;
|
|
dec(_SP);
|
|
_SP^ := _SP^ / temp;
|
|
inc(_SP);
|
|
end;
|
|
OpHoch:
|
|
begin
|
|
dec(_SP);
|
|
Temp := _SP^;
|
|
dec(_SP);
|
|
_SP^ := Power(_SP^,Temp);
|
|
inc(_SP);
|
|
end;
|
|
OpNeg:
|
|
begin
|
|
dec(_SP);
|
|
_SP^ := -_SP^;
|
|
inc(_SP);
|
|
end;
|
|
OpFunc:
|
|
begin
|
|
dec(_SP);
|
|
Case EFuncs(ByteCode.Bytecode[_IP]) of
|
|
_abs : _SP^ := abs(_SP^);
|
|
_frac : _SP^ := frac(_SP^);
|
|
_sin : _SP^ := sin(_SP^);
|
|
_cos : _SP^ := cos(_SP^);
|
|
_tan : _SP^ := tan(_SP^);
|
|
_sign : _SP^ := sign(_SP^);
|
|
_cot : _SP^ := cot(_SP^);
|
|
_arcsin : _SP^ := arcsin(_SP^);
|
|
_arccos : _SP^ := arccos(_SP^);
|
|
_arctan : _SP^ := arctan(_SP^);
|
|
_arccot : _SP^ := arccot(_SP^);
|
|
_ln : _SP^ := ln(_SP^);
|
|
_log : _SP^ := ln(_SP^)/ln(10);
|
|
_lb : _SP^ := ln(_SP^)/ln(2);
|
|
_exp : _SP^ := exp(_SP^);
|
|
_sqrt : _SP^ := sqrt(_SP^);
|
|
_sqr : _sP^ := sqr(_SP^);
|
|
_round : _SP^ := round(_SP^);
|
|
_trunc : _SP^ := trunc(_SP^);
|
|
_heaviside: if _SP^ >= 0 then _SP^ := 1 else _SP^ := 0;
|
|
end;
|
|
inc(_SP);
|
|
inc(_IP);
|
|
end;
|
|
end;
|
|
Befehl := EOpCodes(ByteCode.Bytecode[_IP]);
|
|
end;
|
|
dec(_SP);
|
|
Result := _SP^;
|
|
end;
|
|
|
|
Procedure XPower;
|
|
Var
|
|
Base, Exponent: Extended;
|
|
Result: Extended absolute Base;
|
|
Begin
|
|
asm
|
|
push eax
|
|
fstp tbyte ptr [Exponent]
|
|
fstp tbyte ptr [Base]
|
|
end;
|
|
if (Frac(Exponent) = 0.0) and (Abs(Exponent) <= MaxInt) then
|
|
begin
|
|
Result := IntPower(Base, Integer(Trunc(Exponent)));
|
|
asm
|
|
fld tbyte ptr [Result];
|
|
end;
|
|
end else
|
|
asm // exp(Exponent*ln(Base))
|
|
fldln2
|
|
fld tbyte ptr [Base]
|
|
fyl2x
|
|
fld tbyte ptr [Exponent]
|
|
fmulp st(1), st
|
|
fldl2e
|
|
fmulp st(1), st
|
|
fld st(0)
|
|
frndint
|
|
fsub st(1), st
|
|
fxch st(1)
|
|
f2xm1
|
|
fld1
|
|
faddp st(1), st
|
|
fscale
|
|
fstp st(1)
|
|
end;
|
|
asm
|
|
pop eax
|
|
end;
|
|
end;
|
|
|
|
Const
|
|
Epilogue: array[0..1] of Byte = ($9b,$c3);
|
|
EpilogueBy1Value: array[0..2] of Byte = ($c2,$0c,$00);
|
|
EpilogueBy2Values: array[0..2] of Byte = ($c2,$18,$00);
|
|
{ pass by reference }
|
|
fld8: array[0..1] of Byte = ($db,$68);
|
|
fld16: array[0..1] of Byte = ($db,$a8);
|
|
fldIndex0: array[0..1] of Byte = ($db,$28);
|
|
{ pass by value }
|
|
fldIndex0By1Value: array[0..3] of Byte = ($db,$6c,$24,$04);
|
|
|
|
fldIndex0By2Values: array[0..3] of Byte = ($db,$6c,$24,$10);
|
|
fldIndex1By2Values: array[0..3] of Byte = ($db,$6c,$24,$04);
|
|
|
|
fldAddr: array[0..1] of Byte = ($db,$2d);
|
|
fmulp: array[0..1] of Byte = ($de,$c9);
|
|
fdivp: array[0..1] of Byte = ($de,$f9);
|
|
faddp: array[0..1] of Byte = ($de,$c1);
|
|
fsubp: array[0..1] of Byte = ($de,$e9);
|
|
fldpi: array[0..1] of Byte = ($d9,$eb);
|
|
fsin: array[0..1] of Byte = ($d9,$fe);
|
|
fcos: array[0..1] of Byte = ($d9,$ff);
|
|
fabs: array[0..1] of byte = ($d9,$e1);
|
|
fatan: array[0..3] of Byte = ($d9,$e8,$d9,$f3);
|
|
ftan: array[0..3] of Byte = ($d9,$f2,$dd,$d8);
|
|
fcot: array[0..3] of Byte = ($d9,$f2,$de,$f1);
|
|
facot: array[0..5] of Byte = ($d9,$e8,$d9,$c9,$d9,$f3);
|
|
fsqrt: array[0..1] of Byte = ($d9,$fa);
|
|
fsqr: array[0..3] of Byte = ($d9,$c0,$de,$c9);
|
|
flog: array[0..9] of Byte = ($d9,$e8,$d9,$c9,$d9,$f1,$d9,$e9,$de,$f9);
|
|
fln: array[0..9] of Byte = ($d9,$e8,$d9,$c9,$d9,$f1,$d9,$ea,$de,$f9);
|
|
flb: array[0..5] of Byte = ($d9,$e8,$d9,$c9,$d9,$f1);
|
|
fxchg: array[0..1] of Byte = ($d9,$c9);
|
|
fchs: array[0..1] of Byte = ($d9,$e0);
|
|
fld1: array[0..1] of Byte = ($d9,$e8);
|
|
fld0: array[0..1] of Byte = ($d9,$ee);
|
|
fexp : array[0..21] of Byte =
|
|
($9,$ea,$de,$c9,$d9,$c0,$d9,$fc,$dc,$e9,$d9,$c9,$d9,$f0,$d9,$e8,$de,$c1,$d9,
|
|
$fd,$dd,$d9);
|
|
fheaviside: array[0..19] of Byte =
|
|
($d9,$ee,$d8,$d9,$9b,$df,$e0,$9e,$76,$06,$dd,$d8,$d9,$ee,$eb,$04,$dd,$d8,$d9,
|
|
$e8);
|
|
fround: array[0..12] of Byte =
|
|
($83,$ec,$08,$df,$3C,$24,$9b,$df,$2c,$24,$83,$c4,$08);
|
|
farcsin: array[0..11] of Byte =
|
|
($d9,$c0,$d8,$c8,$d9,$e8,$de,$e1,$d9,$fa,$d9,$f3);
|
|
farccos: array[0..13] of Byte =
|
|
($d9,$c0,$d8,$c8,$d9,$e8,$de,$e1,$d9,$fa,$d9,$c9,$d9,$f3);
|
|
ftrunc: array[0..35] of Byte =
|
|
($83,$ec,$0c,$d9,$3c,$24,$d9,$7C,$24,$02,$66,$81,$4c,$24,$02,$00,$0f,$d9,$6c,
|
|
$24,$02,$df,$7c,$24,$04,$9b,$d9,$2c,$24,$59,$df,$2c,$24,$83,$c4,$08);
|
|
ffrac: array[0..34] of Byte =
|
|
($d9,$c0,$83,$ec,$04,$d9,$3c,$24,$d9,$7c,$24,02,$9b,$66,$81,$4c,$24,$02,$00,
|
|
$0f,$d9,$6c,$24,$02,$d9,$fc,$9b,$d9,$2c,$24,$83,$c4,$04,$de,$e9);
|
|
fsign: array[0..23] of Byte =
|
|
($d9,$ee,$d8,$d9,$9b,$df,$e0,$9e,$76,$08,$dd,$d8,$d9,$e8,$d9,$e0,$eb,$06,$73,
|
|
$04,$dd,$d8,$d9,$e8);
|
|
call: Byte = ($e8);
|
|
|
|
function CompileExpr(const Bytecode: Expression; PT: tyPassType = tyPassRef): Pointer;
|
|
Type
|
|
PExtended = ^Extended;
|
|
TIConsts = record
|
|
e: Integer;
|
|
end;
|
|
TConstantEntry = record
|
|
Addr: ^Pointer;
|
|
Index: Integer;
|
|
end;
|
|
Var
|
|
_IP: Integer; // Instruction Pointer
|
|
Befehl: EOpCodes;
|
|
P: PByte;
|
|
I, J, ConstsCount: Integer;
|
|
index: Integer;
|
|
IConsts: TIConsts;
|
|
AddIConsts: array of Extended;
|
|
ConstsTable: array of TConstantEntry;
|
|
|
|
Procedure LoadArgNo(ConstNo: Integer);
|
|
begin
|
|
Case PT of
|
|
tyPassRef:
|
|
begin
|
|
ConstNo := ConstNo * SizeOf(Extended);
|
|
if ConstNo < 128 then
|
|
begin
|
|
if ConstNo = 0 then
|
|
begin
|
|
Move(fldIndex0, P^, SizeOf(fldIndex0)); inc(P, SizeOf(fldIndex0));
|
|
end else
|
|
begin
|
|
Move(Fld8, P^, SizeOf(Fld8)); inc(P, SizeOf(Fld8));
|
|
P^ := ConstNo; inc(P);
|
|
end;
|
|
end else
|
|
begin
|
|
Move(Fld16, P^, SizeOf(Fld16)); inc(P, SizeOf(Fld16));
|
|
Move(ConstNo, P^, SizeOf(DWord)); inc(P, SizeOf(DWord));
|
|
end;
|
|
end;
|
|
tyPass1V:
|
|
begin
|
|
if ConstNo > 0 then
|
|
EInvalidArgument.Create('CompileExpr: Only one variable can be passed by value');
|
|
Move(fldIndex0by1Value, P^, SizeOf(fldIndex0by1Value));
|
|
inc(P, SizeOf(fldIndex0by1Value));
|
|
end;
|
|
tyPass2V:
|
|
Case ConstNo of
|
|
0: begin
|
|
Move(fldIndex0by2Values, P^, SizeOf(fldIndex0by2Values));
|
|
inc(P, SizeOf(fldIndex0by2Values));
|
|
end;
|
|
1: begin
|
|
Move(fldIndex1by2Values, P^, SizeOf(fldIndex1by2Values));
|
|
inc(P, SizeOf(fldIndex1by2Values));
|
|
end
|
|
else
|
|
EInvalidArgument.Create('CompileExpr: Only two variables can be passed by value');
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
Procedure AddToConstsTable(P: Pointer; Index: Integer);
|
|
Var I: Integer;
|
|
begin
|
|
I := length(ConstsTable);
|
|
SetLength(ConstsTable, I+1);
|
|
ConstsTable[I].Addr := P;
|
|
ConstsTable[I].Index := Index;
|
|
end;
|
|
|
|
procedure AddIConst(Var IConst: Integer; const Value: Extended);
|
|
begin // Add inline constant (e,...) to additional constants table
|
|
if IConst >= 0 then
|
|
begin
|
|
Move(fldAddr, P^, SizeOf(fldAddr)); inc(P, SizeOf(fldAddr));
|
|
AddToConstsTable(P, IConst); inc(P, SizeOf(DWord));
|
|
end else
|
|
begin
|
|
Index := length(AddIConsts);
|
|
SetLength(AddIConsts, Index+1);
|
|
AddIConsts[Index] := Value;
|
|
IConst := Index+ConstsCount;
|
|
Move(fldAddr, P^, SizeOf(fldAddr)); inc(P, SizeOf(fldAddr));
|
|
AddToConstsTable(P, IConst); inc(P, SizeOf(DWord));
|
|
end;
|
|
end;
|
|
|
|
procedure AddPowerCmd;
|
|
Var
|
|
Callee: DWord;
|
|
begin
|
|
P^ := call; inc(P);
|
|
Callee := DWord(@XPower)-DWord(P)-4; // relative Position
|
|
Move(Callee, P^, SizeOf(Callee)); inc(P, SizeOf(Callee));
|
|
end;
|
|
|
|
begin
|
|
{$ifdef ErrCode}
|
|
with Bytecode do
|
|
if Error then
|
|
raise Exception.Create('ParseExpr: '+FormatError(ErrInfo));
|
|
{$else}
|
|
if Bytecode.Error then
|
|
raise Exception.Create('ParseExpr: Syntax error');
|
|
{$endif}
|
|
|
|
Result := VirtualAlloc(nil, 4096, MEM_RESERVE or MEM_COMMIT, PAGE_EXECUTE_READWRITE);
|
|
if Result = nil then
|
|
raise Exception.Create('CompileExpr: '+getLastErrorMsg);
|
|
|
|
try
|
|
FillChar(IConsts, SizeOF(IConsts), -1); // list with indexes of inline constants that cannot be
|
|
// directly converted
|
|
ConstsCount := length(Bytecode.Consts); // how many (not inline) constants in expression
|
|
|
|
P := Result;
|
|
|
|
// Move(Prologue, P^, SizeOf(Prologue));
|
|
// inc(P, SizeOf(Prologue));
|
|
|
|
_IP := 0;
|
|
Befehl := EOpCodes(ByteCode.Bytecode[0]);
|
|
while Befehl <> OpEnd do
|
|
begin
|
|
inc(_IP);
|
|
Case Befehl of
|
|
OpVar:
|
|
begin
|
|
LoadArgNo(Bytecode.Bytecode[_IP]);
|
|
inc(_IP);
|
|
end;
|
|
OpConst:
|
|
begin
|
|
Move(fldAddr, P^, SizeOf(fldAddr)); inc(P, SizeOf(fldAddr));
|
|
AddToConstsTable(P, Integer(Bytecode.Bytecode[_IP])); inc(P, SizeOf(DWord));
|
|
inc(_IP);
|
|
end;
|
|
OpIConst:
|
|
begin
|
|
Case EConst(ByteCode.Bytecode[_IP]) of
|
|
_pi : begin Move(fldpi, P^, SizeOf(fldpi)); inc(P, SizeOf(fldpi)); end;
|
|
_one : begin Move(fld1, P^, SizeOf(fld1)); inc(P, SizeOf(fld1)); end;
|
|
_zero: begin Move(fld0, P^, SizeOf(fld0)); inc(P, SizeOf(fld0)); end;
|
|
_e : AddIConst(IConsts.e, exp(1));
|
|
else
|
|
raise Exception.Create('CompileExpr: Constant not supported');
|
|
end;
|
|
inc(_IP);
|
|
end;
|
|
OpMul: begin
|
|
Move(fmulp, P^, SizeOf(fmulp)); inc(P, SizeOf(fmulp));
|
|
end;
|
|
OpDiv: begin
|
|
Move(fdivp, P^, SizeOf(fdivp)); inc(P, SizeOf(fdivp));
|
|
end;
|
|
OpAdd: begin
|
|
Move(faddp, P^, SizeOf(faddp)); inc(P, SizeOf(faddp));
|
|
end;
|
|
OpSub: begin
|
|
Move(fsubp, P^, SizeOf(fsubp)); inc(P, SizeOf(fsubp));
|
|
end;
|
|
OpHoch: begin
|
|
AddPowerCmd;
|
|
end;
|
|
OpNeg: begin
|
|
Move(fchs, P^, SizeOf(fchs)); inc(P, SizeOf(fchs));
|
|
end;
|
|
OpFunc:
|
|
begin
|
|
Case EFuncs(ByteCode.Bytecode[_IP]) of
|
|
_abs : begin
|
|
Move(fabs, P^, SizeOf(fabs)); inc(P, SizeOf(fabs));
|
|
end;
|
|
_arctan : begin
|
|
Move(fatan, P^, SizeOf(fatan)); inc(P, SizeOf(fatan));
|
|
end;
|
|
_arccot : begin
|
|
Move(facot, P^, SizeOf(facot)); inc(P, SizeOf(facot));
|
|
end;
|
|
_arcsin : begin
|
|
Move(farcsin, P^, SizeOf(farcsin)); inc(P, SizeOf(farcsin));
|
|
end;
|
|
_arccos : begin
|
|
Move(farccos, P^, SizeOf(farccos)); inc(P, SizeOf(farccos));
|
|
end;
|
|
_sqr : begin
|
|
Move(fsqr, P^, SizeOf(fsqr)); inc(P, SizeOf(fsqr));
|
|
end;
|
|
_sqrt : begin
|
|
Move(fsqrt, P^, SizeOf(fsqrt)); inc(P, SizeOf(fsqrt));
|
|
end;
|
|
_sign : begin
|
|
Move(fsign, P^, SizeOf(fsign)); inc(P, SizeOf(fsign));
|
|
end;
|
|
_ln : begin
|
|
Move(fln, P^, SizeOf(fln)); inc(P, SizeOf(fln));
|
|
end;
|
|
_log : begin
|
|
Move(flog, P^, SizeOf(flog)); inc(P, SizeOf(flog));
|
|
end;
|
|
_lb : begin
|
|
Move(flb, P^, SizeOf(flb)); inc(P, SizeOf(flb));
|
|
end;
|
|
_cot : begin
|
|
Move(fcot, P^, SizeOf(fcot)); inc(P, SizeOf(fcot));
|
|
end;
|
|
_tan : begin
|
|
Move(ftan, P^, SizeOf(ftan)); inc(P, SizeOf(ftan));
|
|
end;
|
|
_sin : begin
|
|
Move(fsin, P^, SizeOf(fsin)); inc(P, SizeOf(fsin));
|
|
end;
|
|
_cos : begin
|
|
Move(fcos, P^, SizeOf(fcos)); inc(P, SizeOf(fcos));
|
|
end;
|
|
_round : begin
|
|
Move(fround, P^, SizeOf(fround)); inc(P, SizeOf(fround));
|
|
end;
|
|
_trunc : begin
|
|
Move(ftrunc, P^, SizeOf(ftrunc)); inc(P, SizeOf(ftrunc));
|
|
end;
|
|
_frac : begin
|
|
Move(ffrac, P^, SizeOf(ffrac)); inc(P, SizeOf(ffrac));
|
|
end;
|
|
_heaviside: begin
|
|
Move(fheaviside, P^, SizeOf(fheaviside)); inc(P, SizeOf(fheaviside));
|
|
end;
|
|
_exp : begin
|
|
Move(fexp, P^, SizeOf(fexp)); inc(P, SizeOf(fexp));
|
|
end else
|
|
raise Exception.Create('CompileExpr: Function not supported');
|
|
end;
|
|
inc(_IP);
|
|
end;
|
|
end;
|
|
Befehl := EOpCodes(ByteCode.Bytecode[_IP]);
|
|
end;
|
|
Case PT of
|
|
tyPassRef:
|
|
begin
|
|
Move(Epilogue, P^, SizeOf(Epilogue));
|
|
inc(P, SizeOf(Epilogue));
|
|
end;
|
|
tyPass1V:
|
|
begin
|
|
Move(EpilogueBy1Value, P^, SizeOf(EpilogueBy1Value));
|
|
inc(P, SizeOf(EpilogueBy1Value));
|
|
end;
|
|
tyPass2V:
|
|
begin
|
|
Move(EpilogueBy2Values, P^, SizeOf(EpilogueBy2Values));
|
|
inc(P, SizeOf(EpilogueBy2Values));
|
|
end;
|
|
end;
|
|
For I := 0 to length(ConstsTable)-1 do
|
|
begin
|
|
J := ConstsTable[I].Index;
|
|
if J < ConstsCount then
|
|
Move(Bytecode.Consts[J], P^, SizeOf(Extended))
|
|
else
|
|
Move(AddIConsts[J-ConstsCount], P^, SizeOf(Extended));
|
|
ConstsTable[I].Addr^ := P;
|
|
inc(P, SizeOf(Extended));
|
|
end;
|
|
except
|
|
FreeFunc(Result);
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
procedure FreeFunc(E: Pointer);
|
|
begin
|
|
if not VirtualFree(E, 0, MEM_RELEASE) then
|
|
raise Exception.Create('FreeFunc: '+getLastErrorMsg);
|
|
end;
|
|
|
|
end.
|
|
|