我想问一下各位那位有关于表达式的分析的源码！哪位好心人帮忙编一下算法也行！(47分)

我想问一下各位那位有关于表达式的分析的源码！哪位好心人帮忙编一下算法也行！

http://www.delphibbs.com/delphibbs/dispq.asp?lid=1918531

什么语言写的程序都行
最好是pascal或c

给你个单元看看吧!
unit SpeedParser;
{**************************************}
{ SpeedParser VCL Component, v 0.3 }
{ Copyright ?2001 Mattias Andersson }
{ mattias@centaurix.com }
{**************************************}
interface
uses
SysUtils, Classes, Math;
{ Defines what type to use in your computation -
valid types are real, single and extended }
{$DEFINE REAL}
type
PVarEntry = ^TVarEntry;
TVarEntry = record
Name: string[7];
Value: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
end;
TMathMode = (mmMult, mmDiv, mmAdd, mmSub, mmPower, mmFaculty, mmAbs, mmFrac,
mmSin, mmCos, mmTan, mmCot, mmASin, mmACos, mmATan, mmSinh,
mmCosh, mmTanh, mmLog, mmLn, mmExp, mmSave);
TSpeedParser = class(TComponent)
private
FParseString: String;
FoundVar: Boolean;
ValList: TList;
// Constant values from string expression
MemList: TList;
// Value of expression inside a paranthesis
{ Array of pointers from either VarList, ValList or MemList }
PtrArray: array of ^{$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
{ This array contains the math instructions. The parse function
will iterate through this array. }
ModeArray: array of TMathMode;
Term: array of {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
MemIndex, ModeIndex, PtrIndex, MaxTermIndex: Word;
procedure SetParseString(Value: string);
public
VarList: TList;
// Variable names and values
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
procedure AddVar(AName: string;
AValue: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0);
procedure SetVar(AName: string;
AValue: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0);
function GetIndex(const AName: string): Word;
function FindVar(const AName: string): {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
function Parse(X: {$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}{$IFDEF EXTENDED}Extended{$ENDIF} = 0;
Y: {$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}{$IFDEF EXTENDED}Extended{$ENDIF} = 0;
Z: {$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}{$IFDEF EXTENDED}Extended{$ENDIF} = 0):
{$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}{$IFDEF EXTENDED}Extended{$ENDIF};
function Faculty(X: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF}):
{$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
published
property ParseString: string read FParseString write SetParseString;
end;

procedure Register;
implementation
type
charSet = set of char;
const
Digits: charSet = ['0'..'9'];
Commas: charSet = ['.', ','];
VarSet: charSet = ['a'..'z', 'A'..'Z'];
Separators: charSet = ['+', '-', '*', '/', '^', '!'];
procedure Register;
begin
RegisterComponents('System', [TSpeedParser]);
end;

constructor TSpeedParser.Create(AOwner: TComponent);
var
i: Byte;
begin
inherited create(AOwner);
VarList := TList.Create;
ValList := TList.Create;
for i := ord('a') to ord('z')do
AddVar(chr(i));
AddVar('pi');
SetVar('pi', Pi);
end;

destructor TSpeedParser.Destroy;
begin
VarList.Free;
ValList.Free;
MemList.Free;
inherited;
end;

{ This routine recompiles the string expression into an array of pointers and
an array of instructions, which are evaluated in the parse function. This will
greatly optimize performance in comparison with a routine exclusively working
with strings }
procedure TSpeedParser.SetParseString(Value: string);
procedure AddMode(Mode: TMathMode);
begin
Inc(ModeIndex);
SetLength(ModeArray, ModeIndex);
ModeArray[ModeIndex - 1] := Mode;
end;

procedure AddPointer(Value: Pointer);
begin
Inc(ptrIndex);
SetLength(PtrArray, PtrIndex);
PtrArray[PtrIndex - 1] := Value;
end;

function AddReal(var List: TList;
const Value: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0): pointer;
var
PReal: ^{$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
begin
New(PReal);
if PReal = nil then
raise Exception.Create('Could not allocate memory for new value!');
PReal^ := Value;
with Listdo
Result := Items[Add(PReal)];
end;

procedure Recurse(SubString: string);
var
TermCount, I: Word;
Mode: TMathMode;
NewMode: Boolean;
StrValue: string;
begin
TermCount := 0;
Mode := mmMult;
I := 1;
while I <= length(SubString)do
begin
NewMode := False;
StrValue := '';
if (SubString in Digits + Commas) then
begin
repeat
if SubString = '.' then
SubString := ',';
StrValue := StrValue + SubString;
Inc(I);
until (SubString in Digits + Commas) = false;
AddPointer(AddReal(ValList, strtofloat(StrValue)));
NewMode := True;
end
else
if (SubString in VarSet) then
begin
repeat
StrValue := StrValue + SubString;
Inc(i);
until (SubString in VarSet) = false;
FindVar(StrValue);
if FoundVar then
begin
AddPointer(@TVarEntry(VarList.Items[GetIndex(StrValue)]^).Value);
NewMode := True;
end;
end
else
if SubString = '(' then
begin
AddPointer(MemList.Items[MemIndex]);
Inc(MemIndex);
Inc(I, 2);
NewMode := True
end
else
if (SubString in separators) then
begin
StrValue := SubString;
Inc(I);
end
else
Inc(I);
if NewMode then
begin
AddMode(Mode);
end
else
begin
StrValue := LowerCase(StrValue);
case length(StrValue) of
1: case StrValue[1] of
'*': Mode := mmMult;
'/': Mode := mmDiv;
'+': begin
AddMode(mmAdd);
inc(TermCount);
end;
'-': begin
AddMode(mmSub);
inc(TermCount);
end;
'^': begin
Mode := mmPower;
Dec(ModeIndex);
end;
'!': begin
Dec(ModeIndex);
AddMode(mmFaculty);
end;
end;
2: if StrValue = 'ln' then
Mode := mmLn;
3: begin
if StrValue = 'abs' then
Mode := mmAbs
else
if StrValue = 'log' then
Mode := mmLog
else
if StrValue = 'exp' then
Mode := mmExp
else
if StrValue = 'sin' then
Mode := mmSin
else
if StrValue = 'cos' then
Mode := mmCos
else
if StrValue = 'tan' then
Mode := mmTan
else
if StrValue = 'cot' then
Mode := mmCot
end;
4: begin
if StrValue = 'frac' then
Mode := mmFrac
else
if StrValue = 'asin' then
Mode := mmASin
else
if StrValue = 'acos' then
Mode := mmACos
else
if StrValue = 'atan' then
Mode := mmATan
else
if StrValue = 'sinh' then
Mode := mmSinh
else
if StrValue = 'cosh' then
Mode := mmCosh
else
if StrValue = 'tanh' then
Mode := mmTanh
end;
end;
end;
end;
if TermCount > MaxTermIndex then
MaxTermIndex := TermCount;
AddMode(mmSave);
end;

var
Level, I, Current, MaxLevel, Count, Index: Word;
begin
FParseString := Value;
Current := 0;
Index := 0;
MaxLevel := 0;
MemIndex := 0;
PtrIndex := 0;
ModeIndex := 0;
MaxTermIndex := 0;
MemList.Free;
MemList := TList.Create;
if Length(FParseString) = 0 then
FParseString := '0';
// raise Exception.Create('Input string contains no data!');
for I := 0 to Length(FParseString)do
begin
case FParseString of
'(': Inc(Current);
')': Dec(Current);
end;
if Current > MaxLevel then
MaxLevel := current;
end;
Current := 0;
for Level := MaxLeveldo
wnto 1do
begin
I := 0;
while I <= length(FParseString)do
begin
case FParseString of
')': begin
if Current = Level then
begin
Count := I - Index;
Recurse(copy(FParseString, Index, Count));
AddReal(MemList);
Delete(FParseString, Index, Count);
I := Index;
end;
Dec(Current);
end;
'(': begin
Inc(Current);
if Current = Level then
Index := I + 1;
end;
end;
Inc(i);
end;
end;
AddReal(MemList);
Recurse(FParseString);
SetLength(Term, MaxTermIndex + 1);
end;

{ This function is called from your application to evaluate the ParseString
expression. The X, Y and Z variable are set when calling this function }
function TSpeedParser.Parse(X: {$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0;
Y: {$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0;
Z: {$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0):
{$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
function GetNextVal: Real;
begin
Result := PtrArray[PtrIndex]^;
inc(PtrIndex);
end;

var
I, ModeCount: Word;
TempSum: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
Index: Word;
PReal: ^{$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
begin
with VarListdo
begin
TVarEntry(Items[23]^).Value := X;
TVarEntry(Items[24]^).Value := Y;
TVarEntry(Items[25]^).Value := Z;
end;

PtrIndex := 0;
MemIndex := 0;
Index := 0;
for I := 0 to MaxTermIndexdo
Term := 1;
if ModeArray[0] = mmSub then
Term[0] := 0;
for ModeCount := 0 to High(ModeArray)do
begin
case ModeArray[ModeCount] of
mmSave: begin
TempSum := 0;
for I := 0 to Indexdo
begin
TempSum := TempSum + Term;
Term := 1;
end;
{$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF}
(MemList.Items[MemIndex]^) := TempSum;
Inc(MemIndex);
Index := 0;
end;
mmMult: Term[Index] := Term[Index] * GetNextVal;
mmDiv: Term[Index] := Term[Index] / GetNextVal;
mmAdd: Inc(Index);
mmSub: begin
Inc(Index);
Term[Index] := -1;
end;
mmPower: Term[Index] := Term[Index] * Power(GetNextVal, GetNextVal);
mmFaculty: Term[Index] := Term[Index] * Faculty(GetNextVal);
mmAbs: Term[Index] := Term[Index] * Abs(GetNextVal);
mmFrac: Term[Index] := Term[Index] * Frac(GetNextVal);
mmSin: Term[Index] := Term[Index] * Sin(GetNextVal);
mmCos: Term[Index] := Term[Index] * Cos(GetNextVal);
mmTan: Term[Index] := Term[Index] * Tan(GetNextVal);
mmCot: Term[Index] := Term[Index] * CoTan(GetNextVal);
mmASin: Term[Index] := Term[Index] * ArcSin(GetNextVal);
mmACos: Term[Index] := Term[Index] * ArcCos(GetNextVal);
mmATan: Term[Index] := Term[Index] * ArcTan(GetNextVal);
mmSinh: Term[Index] := Term[Index] * Sinh(GetNextVal);
mmCosh: Term[Index] := Term[Index] * Cosh(GetNextVal);
mmTanh: Term[Index] := Term[Index] * Tanh(GetNextVal);
mmLog: Term[Index] := Term[Index] * Log10(GetNextVal);
mmLn: Term[Index] := Term[Index] * Ln(GetNextVal);
mmExp: Term[Index] := Term[Index] * Exp(GetNextVal);
end;
end;
Result := {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF}(MemList.Items[MemIndex-1]^);
end;

{ This procedure allows you to define your own variables }
procedure TSpeedParser.AddVar(AName: string;
AValue: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0);
var
NewEntry: PVarEntry;
begin
New(NewEntry);
if NewEntry = nil then
raise Exception.Create('Could not allocate memory for new variable!');
with NewEntry^do
begin
Name := AName;
Value := AValue;
end;
Varlist.Add(NewEntry);
end;

{ Use this procedure to set an existing variable }
procedure TSpeedParser.SetVar(AName: string;
AValue: {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF} = 0);
var
I: Integer;
begin
with VarListdo
begin
for I := 0 to Count - 1do
with TVarEntry(Items^)do
if Name = AName then
Value := AValue;
end;
end;

function TSpeedParser.FindVar(const AName: string): {$IFDEF REAL}Real{$ENDIF}
{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
var
I: Word;
begin
with VarListdo
begin
FoundVar := False;
I := 0;
while (TVarEntry(Items^).Name <> AName) and (I < Count - 1)do
Inc(I);
with TVarEntry(Items^)do
begin
FoundVar := Name = AName;
Result := Value;
end;
end;
end;

function TSpeedParser.GetIndex(const AName: string): Word;
var
I: Word;
begin
I := 0;
while (TVarEntry(Varlist.Items^).Name <> AName) and (I < VarList.Count - 1)do
Inc(I);
Result := I;
end;

function TSpeedParser.Faculty(X: {$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF}):
{$IFDEF REAL}Real{$ENDIF}{$IFDEF SINGLE}Single{$ENDIF}
{$IFDEF EXTENDED}Extended{$ENDIF};
var
I: Integer;
begin
Result := 1;
if frac(x) = 0 then
for I := 2 to round(X)do
Result := Result * I;
end;

end.

例子程序在这里
object MainForm: TMainForm
Left = 393
Top = 144
Width = 265
Height = 429
Caption = 'SpeedParser Demo'
Color = clBtnFace
Font.Charset = ANSI_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnResize = FormResize
PixelsPerInch = 96
TextHeight = 13
object Panel1: TPanel
Left = 0
Top = 0
Width = 257
Height = 257
Align = alClient
BevelOuter = bvLowered
TabOrder = 0
object Image: TImage
Left = 1
Top = 1
Width = 255
Height = 255
Align = alClient
end
end
object Panel2: TPanel
Left = 0
Top = 257
Width = 257
Height = 145
Align = alBottom
BevelInner = bvRaised
BevelOuter = bvLowered
TabOrder = 1
object lblRed: TLabel
Left = 16
Top = 40
Width = 19
Height = 13
Caption = 'Red'
end
object lblGreen: TLabel
Left = 16
Top = 64
Width = 29
Height = 13
Caption = 'Green'
end
object lblBlue: TLabel
Left = 16
Top = 88
Width = 20
Height = 13
Caption = 'Blue'
end
object Label1: TLabel
Left = 16
Top = 16
Width = 36
Height = 13
Caption = 'Presets'
end
object btnDraw: TButton
Left = 8
Top = 112
Width = 233
Height = 25
Caption = 'Draw'
TabOrder = 0
OnClick = btnDrawClick
end
object BlueComponent: TEdit
Left = 56
Top = 80
Width = 185
Height = 21
TabOrder = 1
Text = '(y/height)*255'
end
object GreenComponent: TEdit
Left = 56
Top = 56
Width = 185
Height = 21
TabOrder = 2
Text = '0'
end
object RedComponent: TEdit
Left = 56
Top = 32
Width = 185
Height = 21
TabOrder = 3
Text = '(x/width)*255'
end
object cmbPreset: TComboBox
Left = 56
Top = 8
Width = 145
Height = 21
ItemHeight = 13
TabOrder = 4
OnChange = cmbPresetChange
Items.Strings = (
'Sinuspattern'
'Gradient'
'Spheres'
'Forest')
end
end
object SpeedParserRed: TSpeedParser
Left = 16
Top = 16
end
object SpeedParserGreen: TSpeedParser
Left = 56
Top = 16
end
object SpeedParserBlue: TSpeedParser
Left = 96
Top = 16
end
end

unit SpeedParserUnit;
{****************************************}
{ This application demonstrates how to }
{ use the SpeedParser Component }
{ Copyright ?2001 Mattias Andersson }
{ mattias@centaurix.com }
{****************************************}
interface
uses
Windows, Messages, Classes, Graphics, Controls, Forms, SpeedParser,
StdCtrls, ExtCtrls, g32, icqclient;
type
TMainForm = class(TForm)
SpeedParserRed: TSpeedParser;
SpeedParserGreen: TSpeedParser;
SpeedParserBlue: TSpeedParser;
Panel1: TPanel;
Image: TImage;
Panel2: TPanel;
btnDraw: TButton;
BlueComponent: TEdit;
GreenComponent: TEdit;
RedComponent: TEdit;
cmbPreset: TComboBox;
lblRed: TLabel;
lblGreen: TLabel;
lblBlue: TLabel;
Label1: TLabel;
procedure btnDrawClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure cmbPresetChange(Sender: TObject);
procedure FormResize(Sender: TObject);
end;

var
MainForm: TMainForm;
implementation
{$R *.DFM}
procedure TMainForm.FormCreate(Sender: TObject);
begin
// You can register SpeedParser in the Components Palette
// to be able to simply drop SpeedParser components on your
// form at design time instead of creating them by code as
// we aredo
ing here:
SpeedParserRed := TSpeedParser.Create(Self);
SpeedParserGreen := TSpeedParser.Create(Self);
SpeedParserBlue := TSpeedParser.Create(Self);
{ Here we add the new variables }
SpeedParserRed.AddVar('width');
SpeedParserRed.AddVar('height');
SpeedParserGreen.AddVar('width');
SpeedParserGreen.AddVar('height');
SpeedParserBlue.AddVar('width');
SpeedParserBlue.AddVar('height');
end;

procedure TMainForm.btnDrawClick(Sender: TObject);
var
R, G, B: Byte;
X, Y: Integer;
begin
Screen.Cursor := crHourGlass;
{ Setting the parsestring property will cause the
component to optimize the expression in memory }
SpeedParserRed.ParseString := RedComponent.Text;
SpeedParserGreen.ParseString := GreenComponent.Text;
SpeedParserBlue.ParseString := BlueComponent.Text;
with Imagedo
begin
{ We set the variables 'width' and 'height' to the
corresponding image properties }
SpeedParserRed.SetVar('width', Width);
SpeedParserRed.SetVar('height', Height);
SpeedParserGreen.SetVar('width', Width);
SpeedParserGreen.SetVar('height', Height);
SpeedParserBlue.SetVar('width', Width);
SpeedParserBlue.SetVar('height', Height);
end;
for Y := 0 to Image.Heightdo
begin
for X := 0 to Image.Widthdo
begin
{ We calculate the RGB values for every pixel using the parse function }
R := Round(SpeedParserRed.Parse(X, Y));
G := Round(SpeedParserGreen.Parse(X, Y));
B := Round(SpeedParserBlue.Parse(X, Y));
Image.Canvas.Pixels[X, Y] := R + G shl 8 + B shl 16;
end;
if Y mod 64 = 0 then
Image.Repaint;
end;
Screen.Cursor := crDefault;
end;

procedure TMainForm.cmbPresetChange(Sender: TObject);
begin
case cmbPreset.ItemIndex of
0:begin
RedComponent.Text := 'x+sin(y/2)*16+y+sin(x/2)*16';
GreenComponent.Text := 'x+sin(y/2)*16+y+sin(x/2)*16';
BlueComponent.Text := 'abs(x+y-255)';
end;
1:begin
RedComponent.Text := '255-(x/width)*255';
GreenComponent.Text := '(x/width)*255';
BlueComponent.Text := '(y/height)*255';
end;
2:begin
RedComponent.Text := 'abs(255-sqrt((x-127)*(x-127)+(y-127)*(y-127))/64)';
GreenComponent.Text := 'abs(255-sqrt((x-127)*(x-127)+(y-127)*(y-127))/32)';
BlueComponent.Text := 'abs(255-sqrt((x-127)*(x-127)+(y-127)*(y-127))/64)';
end;
3:begin
RedComponent.Text := '-x*2+y';
GreenComponent.Text := '-x*3+y*2';
BlueComponent.Text := '0';
end;

end;
end;

procedure TMainForm.FormResize(Sender: TObject);
begin
Image.Picture.Bitmap.Height := Image.Height;
Image.Picture.Bitmap.Width := Image.Width;
end;

end.

原始下载地址:
http://ftp.tuwien.ac.at/pc/delphi/newl/d60/
具体的忘了,自己找找吧

unit m;
interface
uses
Windows, Messages, Math, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
const
Symbol_Mod = 'M';
Symbol_Div = 'D';
Symbol_Shl = 'L';
Symbol_Shr = 'R';
Symbol_Or = 'O';
Symbol_Xor = 'X';
Symbol_And = 'A';
type
TForm1 = class(TForm)
Button1: TButton;
Edit1: TEdit;
Edit2: TEdit;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
implementation
{$R *.DFM}
function ConvertExpression(ExpressionString: PChar): PChar;
var
inputexp: string;
begin
inputexp := ExpressionString;
//convert input expression to recognize expression
if pos('=', inputexp) = 0 then
inputexp := inputexp + '='
else
inputexp := Copy(inputexp, 1, Pos('=', inputexp));
inputexp := UpperCase(inputexp);
inputexp := StringReplace(inputexp, ' ', '', [rfReplaceAll]);
inputexp := StringReplace(inputexp, 'MOD', Symbol_Mod, [rfReplaceAll]);
inputexp := StringReplace(inputexp, 'DIV', Symbol_Div, [rfReplaceAll]);
inputexp := StringReplace(inputexp, 'AND', Symbol_And, [rfReplaceAll]);
inputexp := StringReplace(inputexp, 'XOR', Symbol_Xor, [rfReplaceAll]);
inputexp := StringReplace(inputexp, 'OR', Symbol_Or, [rfReplaceAll]);
inputexp := StringReplace(inputexp, 'SHL', Symbol_Shl, [rfReplaceAll]);
inputexp := StringReplace(inputexp, 'SHR', Symbol_Shr, [rfReplaceAll]);
inputexp := StringReplace(inputexp, '(-', '(0-', [rfReplaceAll]);
if pos('-', inputexp) = 1 then
inputexp := '0' + inputexp;
Result := PChar(inputexp);
end;

function ParseExpression(ExpressionString: PChar): extended;
var
nextch: char;
nextchpos, position: word;
inputexp: string;
procedure expression(var ev: extended);
forward;
procedure readnextch;
begin
repeat
if inputexp[position] = '=' then
nextch := '='
else
begin
inc(nextchpos);
inc(position);
nextch := inputexp[position];
end;
until (nextch <> ' ') or eoln;
end;
procedure error(ErrorString: string);
begin
MessageDlg('无法识别的语法 : ' + ErrorString, mterror, [mbok], 0);
exit;
end;
procedure number(var nv: extended);
var
radix: longint;
snv: string;
function BinToInt(value: string): integer;
var
i, size: integer;
begin
// convert binary number to integer
result := 0;
size := length(value);
for i := sizedo
wnto 1do
if copy(value, i, 1) = '1'
then
result := result + (1 shl (size - i));
end;
begin
nv := 0;
snv := '';
while nextch in ['0'..'9', 'A'..'F']do
begin
// nv:=10*nv+ord(nextch)-ord('0');
snv := snv + nextch;
readnextch;
end;
// parse Hex, Bin
if snv <> '' then
if snv[Length(snv)] = 'B'
then
nv := BinToInt(Copy(snv, 1, Length(snv) - 1))
else
if nextch = 'H' then
begin
nv := StrToInt('$' + snv);
readnextch;
end
else
nv := StrToInt(snv);
if nextch = '.' then
begin
radix := 10;
readnextch;
while nextch in ['0'..'9']do
begin
nv := nv + (ord(nextch) - ord('0')) / radix;
radix := radix * 10;
readnextch;
end;
end;
end;
procedure factor(var fv: extended);
var
Symbol: string;
function CalcN(Value: integer): extended;
var
i: integer;
begin
Result := 1;
if Value = 0 then
Exit
else
for i := 1 to Valuedo
Result := Result * i;
end;
function ParseFunction(var FunctionSymbol: string): boolean;
begin
FunctionSymbol := '';
while not (nextch in ['0'..'9', '.', '(', ')', '+', '-', '*', '/', '='])do
begin
FunctionSymbol := FunctionSymbol + nextch;
readnextch;
end;
if FunctionSymbol = 'ABS' then
Result := true
else
if FunctionSymbol = 'SIN' then
Result := true
else
if FunctionSymbol = 'COS' then
Result := true
else
if FunctionSymbol = 'TG' then
Result := true
else
if FunctionSymbol = 'TAN' then
Result := true
else
if FunctionSymbol = 'ARCSIN' then
Result := true
else
if FunctionSymbol = 'ARCCOS' then
Result := true
else
if FunctionSymbol = 'ARCTG' then
Result := true
else
if FunctionSymbol = 'ARCTAN' then
Result := true
else
if FunctionSymbol = 'LN' then
Result := true
else
if FunctionSymbol = 'LG' then
Result := true
else
if FunctionSymbol = 'EXP' then
Result := true
else
if FunctionSymbol = 'SQR' then
Result := true
else
if FunctionSymbol = 'SQRT' then
Result := true
else
if FunctionSymbol = 'PI' then
Result := true
else
if FunctionSymbol = 'NOT' then
Result := true
else
if FunctionSymbol = 'N!' then
Result := true
else
if FunctionSymbol = 'E' then
Result := true
else
Result := false;
end;
begin
case nextch of
'0'..'9': number(fv);
'(':
begin
readnextch;
expression(fv);
if nextch = ')'
then
readnextch
else
error(nextch);
end
else
if ParseFunction(Symbol) then
if nextch = '(' then
begin
readnextch;
expression(fv);
if Symbol = 'ABS' then
fv := abs(fv)
else
if Symbol = 'SIN' then
fv := sin(fv)
else
if Symbol = 'COS' then
fv := cos(fv)
else
if Symbol = 'TG' then
fv := tan(fv)
else
if Symbol = 'TAN' then
fv := tan(fv)
else
if Symbol = 'ARCSIN' then
fv := arcsin(fv)
else
if Symbol = 'ARCCOS' then
fv := arccos(fv)
else
if Symbol = 'ARCTG' then
fv := arctan(fv)
else
if Symbol = 'ARCTAN' then
fv := arctan(fv)
else
if Symbol = 'LN' then
fv := ln(fv)
else
if Symbol = 'LG' then
fv := ln(fv) / ln(10)
else
if Symbol = 'EXP' then
fv := exp(fv)
else
if Symbol = 'SQR' then
fv := sqr(fv)
else
if Symbol = 'SQRT' then
fv := sqrt(fv)
else
if Symbol = 'NOT' then
fv := not (Round(fv))
else
if Symbol = 'N!' then
fv := CalcN(Round(fv))
else
error(symbol);
if nextch = ')' then
readnextch
else
error(nextch);
end
else
begin
// parse constant
if Symbol = 'PI' then
fv := 3.14159265358979324
else
if Symbol = 'E' then
fv := 2.71828182845904523
else
error(symbol);
end
else
begin
error(Symbol);
fv := 1;
end;
end;
end;
procedure Power_(var pv: extended);
var
multiop: char;
fs: extended;
begin
factor(pv);
while nextch in ['^']do
begin
multiop := nextch;
readnextch;
factor(fs);
case multiop of
'^':
if pv <> 0.0 then
pv := exp(ln(pv) * fs)
else
error(multiop);
end;
end;
end;
procedure term_(var tv: extended);
var
multiop: char;
fs: extended;
begin
Power_(tv);
while nextch in ['*', '/', Symbol_Mod, Symbol_Div, Symbol_And, Symbol_Shl, Symbol_Shr]do
begin
multiop := nextch;
readnextch;
Power_(fs);
case multiop of
'*': tv := tv * fs;
'/':
if fs <> 0.0 then
tv := tv / fs
else
error(multiop);
Symbol_Mod: tv := round(tv) mod round(fs);
// prase mod
Symbol_Div: tv := round(tv) div round(fs);
// parse div
Symbol_And: tv := round(tv) and round(fs);
// parse and
Symbol_Shl: tv := round(tv) shl round(fs);
// parse shl
Symbol_Shr: tv := round(tv) shr round(fs);
// parse shr
end;
end;
end;
procedure expression(var ev: extended);
var
addop: char;
fs: extended;
begin
term_(ev);
while nextch in ['+', '-', Symbol_Or, Symbol_Xor]do
begin
addop := nextch;
readnextch;
term_(fs);
case addop of
'+': ev := ev + fs;
'-': ev := ev - fs;
Symbol_Or: ev := round(ev) or round(fs);
// parse or
Symbol_Xor: ev := round(ev) xor round(fs);
// parse xor
end;
end;
end;
begin
inputexp := ConvertExpression(ExpressionString);
if pos('=', inputexp) = 0 then
inputexp := ConvertExpression(ExpressionString);
position := 0;
while inputexp[position] <> '='do
begin
nextchpos := 0;
readnextch;
expression(result);
end;
end;

function ParseExpressionToStr(ExpressionString: PChar): PChar;
var
ES: string;
begin
ES := ExpressionString;
if pos('=', ES) = 0
then
ES := ES + '='
else
ES := Copy(ES, 1, Pos('=', ES));
ES := ES + FormatFloat('0.000000000000', ParseExpression(ExpressionString));
Result := PChar(ES);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Edit1.Text:=ConvertExpression(pchar(Edit1.text));
Edit2.Text:=floattostr(ParseExpression(Pchar(Edit1.text)));
end;

end.

下载地址
http://ftp.tuwien.ac.at/pc/delphi/ftp/d20free/SpeedParser.zip
引用页面
http://ftp.tuwien.ac.at/pc/delphi/newl/d60/f014_001.htm