求助一个C语言的解析器

huangjacky 2009-01-04 10:59:02
我自己在网上找了一个pascal脚本解析器.
自己花了点时间,改写成解析C的,能编译,可是不能运行.
可能在解析生成VMPcode的时候错误了,自己对比检测了,还是不能找到错误的地方.

不知道高手们是否搞过类似的.
请给点儿源码,小弟参考一下.
拜谢.
我的邮箱:huangjacky@163.com
...全文
223 9 打赏 收藏 转发到动态 举报
写回复
用AI写文章
9 条回复
切换为时间正序
请发表友善的回复…
发表回复
skertone 2009-03-03
  • 打赏
  • 举报
回复
老是回复内容过长!中间省略 N 字节,收尾...


function TCScript.ExpIsObject(S: String; var ObjName, ObjProp: String): Boolean;
var
ii: Integer;
begin
// 如果表达式是 Object.Property 格式的话 需特殊处理
// 处理方法 1.解析出 Object 名与 Property名
// 2.产生通知事件,通知界面仿真模块
// 3.在事件方法中 读/写 Object对像属性值
Result := False;
S := Trim(S);
ii := Pos('.',S);
if ii > 0 then
begin
ObjName := Copy(S,1,ii - 1);
ObjProp := Copy(S,ii + 1,MAXWORD);
ii := TokenTableFind(ObjName);
if ii > 0 then
Result := FTokenTbl[ii].Typ = ttObject;
end
end;

procedure TCScript.EventIPMoved(IP: Integer);
begin
if Assigned(FIPMoved) then
try
FIPMoved(Self,IP);
except
end;
end;

procedure TCScript.EventSrcSet(Source: String);
begin
if Assigned(FSrcSet) then
try
FSrcSet(Self,Source);
except
end;
end;

procedure TCScript.CheckStepByStep;
begin
if not FPause then
FPause := FStep;

while FPause do
begin
Application.ProcessMessages;
Sleep(20);
end;
end;

procedure TCScript.NextStep;
begin
FPause := False;
end;

procedure TCScript.GetTokenInfo(const Token: String; var sType,sValue: String);
var
iIndex: Integer;
begin
iIndex := TokenTableFind(Token);
if iIndex >=0 then
with FTokenTbl[iIndex] do
begin
case Kind of
tkArray: sType := '数组';
tkVariable: sType := '变量';
tkFunction: sType := '函数';
tkConst: sType := '常量';
else sType := '未知';
end;
if Kind = tkArray then
begin
sValue := PChar(ptr(Address));
end
else
sValue := TokenValue(Token);
end;
end;

function TCScript.CheckBreakTokenList(AToken: String): Boolean;
var
ii: Integer;
begin
Result := False;
if FStep then Exit;
if FBreakTokenList.Count > 0 then
for ii := 0 to FBreakTokenList.Count -1 do
if Trim(AToken) <> '' then
begin
Result := FBreakTokenList[ii] = Trim(AToken);
if Result then
Break;
end;
end;

procedure TCScript.SetEntryCount(const Value: Integer);
begin
FEntryCount := Value;

if FStop then
FStop := FEntryCount > 0;
end;

procedure TCScript.Stop;
begin
if EntryCount > 0 then
FStop := True;

FStep := False;
FPause := False;
end;

procedure TCScript.Pause;
begin
if EntryCount > 0 then
FPause := True;
end;

{ TCMathProcess }

constructor TCMathProcess.Create;
begin
FNumbStack := TStrings.Create;
FOppStack := TStrings.Create;
end;

destructor TCMathProcess.Destroy;
begin
FOppStack.Free;
FNumbStack.Free;
end;

function TCMathProcess.Exec: Variant;
begin
end;

procedure TCMathProcess.SplitToken;
const
ExpList: array[1..8] of String[3] = ('\w+','\(+','\)+','\++','\*+','/+','%+','-+');
var
ii: Integer;
PosList: TStrings;
begin
PosList := TStringList.Create;
PosList.Capacity := Length(FInput);
for ii := 0 to PosList.Count - 1 do
PosList[ii] := '';

// 串化输入
for ii := Low(ExpList) to High(ExpList) do
begin
with TRegExpr.Create do
try
Expression := ExpList[ii];
Exec(FInput);
while MatchLen[0] > 0 do
begin
PosList[MatchPos[0]] := Match[0];
ExecNext;
end;
finally
Free;
end;
end;

// 清除空行
for ii := PosList.Count - 1 downto 0 do
if Trim(PosList[ii]) = '' then
PosList.Delete(ii);

// 四则运算
while PosList.Count > 1 do
begin
if PosList[0][1] in ['+','-','*','/','%'] then
FOppStack.Add(PosList[0])
else
FNumbStack.Add(PosList[0]);

// ) 优先级最高
if PosList[0] = ')' then
begin
if FOppStack.Count > 0 then
case FOppStack[0][1] of
'+':;
'-':;
'*':;
'/':;
'%':;
end;
end;

PosList.Delete(0);
if FOppStack.Count > 1 then
end;

PosList.Free;
end;

end.


skertone 2009-03-03
  • 打赏
  • 举报
回复


procedure TCScript.TokenTableAdd(AToken: String; AKind: TTokenKind;
AType: TTokenType; AParam: Integer; Addr: DWORD);
begin
if Length(FTokenTbl) > 0 then
SetLength(FTokenTbl,Length(FTokenTbl) + 1)
else
SetLength(FTokenTbl,1);

with FTokenTbl[High(FTokenTbl)] do
begin
Name := AToken;
Kind := AKind;
Typ := AType;
Param := AParam;
Address := Addr;
end;
end;

procedure TCScript.DoAddDeclareToken(sToken, sValue: String);
// 拆出变量列表 带 *Str, intA[],格式
function GetVarList(sInput: String): TStrings;
var
iPos: Integer;
begin
Result := TStringList.Create;
iPos := Pos(',',sInput);
while iPos > 0 do
begin
Result.Add(Trim(Copy(sInput,1,iPos-1)));
sInput := Copy(sInput,iPos + 1,MAXWORD);
iPos := Pos(',',sInput);
end;
if Trim(sInput) <> '' then
Result.Add(Trim(sInput));
end;
// 判断是滞是否 *xx 格式,同时去掉 * 号
function IsPointerVar(var S: String): Boolean;
begin
Result := Pos('*',S) > 0;
if Result then
S := Trim(Copy(S,Pos('*',S) + 1,MAXWORD));
end;
// 判断是否 A[] 数组格式 去掉 []
function IsArrayVar(var S: String;var Param: Integer): Boolean;
var
sParam: String;
begin
Param := 0;
Result := Pos(']',S) > 0;
if Result then
begin
sParam := Trim(Copy(S,Pos('[',S) + 1,MAXWORD));
sParam := Trim(Copy(sParam,1,Pos(']',sParam) - 1));
S := Trim(Copy(S,1,Pos('[',S) - 1));
if sParam <> '' then
begin
try
if Pos('0x',sParam) > 0 then
begin
Delete(sParam,1,2);
Insert('$',sParam,1);
end;
Param := StrToInt(sParam);
except
end;
end
end;
end;
var
ii,iParam,iType,iSize: Integer;
sl: TStrings;
sTemp: String;
p: Pointer;
begin
// 注意: 这里参数名是物非
sToken := Trim(sToken);
sValue := Trim(sValue);
sl := GetVarList(sValue);
iType := TypeNameToID(sToken);
for ii := 0 to sl.Count - 1 do
begin
sTemp := sl.Strings[ii];
if IsPointerVar(sTemp) then
begin
// 所有指针都初始化为nil(NULL)
p := nil;
TokenTableAdd(sTemp,tkVariable,ttPointer,0,DWORD(p));
end
else
if IsArrayVar(sTemp,iParam) then
begin
if iParam = 0 then
begin
// 动态数组即空指针
p := nil;
case iType of
_U8,_char: TokenTableAdd(sTemp,tkArray,ttByte,0,DWORD(p));
_U16: TokenTableAdd(sTemp,tkArray,ttSmallInt,0,DWORD(p));
_U32,_int: TokenTableAdd(sTemp,tkArray,ttInteger,0,DWORD(p));
end;
end
else
begin
case iType of
_U8,_char: iSize := 1;
_U16: iSize := 2;
_U32,_int: iSize := 4;
end;
iSize := iSize * iParam;
GetMem(p,iSize * iParam);

case iType of
_U8,_char: TokenTableAdd(sTemp,tkArray,ttByte,iSize,DWORD(p));
_U16: TokenTableAdd(sTemp,tkArray,ttSmallInt,iSize,DWORD(p));
_U32,_int: TokenTableAdd(sTemp,tkArray,ttInteger,iSize,DWORD(p));
end;
end;
end
else
if iType > 8 then
begin
TokenTableAdd(sTemp,tkVariable,ttObject,0,DWORD(nil));
end
else
begin
case iType of
_U8,_char: iSize := 1;
_U16: iSize := 2;
_U32,_int: iSize := 4;
_PU8,_PU16,
_PU32: iSize := 4;
end;

GetMem(p,iSize);

case iType of
_U8,_char: TokenTableAdd(sTemp,tkVariable,ttByte,iSize,DWORD(p));
_U16: TokenTableAdd(sTemp,tkVariable,ttSmallInt,iSize,DWORD(p));
_U32,_int: TokenTableAdd(sTemp,tkVariable,ttInteger,iSize,DWORD(p));
_PU8,_PU16,
_PU32: TokenTableAdd(sTemp,tkVariable,ttPointer,iSize,DWORD(p));
end;


end;
end;
sl.Free;
end;


function TCScript.TypeNameToID(sType: String): Integer;
var
ii: Integer;
begin
Result := 0;
for ii := Low(TypeNameList) to High(TypeNameList) do
if TypeNameList[ii] = sType then
begin
Result := ii;
Break;
end;
end;

function TCScript.TokenDebugOut: String;
var
ii: Integer;
sl: TStrings;
begin
sl := TStringList.Create;
for ii := Low(FTokenTbl) to High(FTokenTbl) do
begin
with FTokenTbl[ii] do
begin
sl.Add(Format('%s= Kind:%d Type:%d Param:%d Addr:%.8x',[Name,Ord(Kind),Ord(Typ),Param,Address]));
end;
end;

for ii := Low(FSystemFuncTbl) to High(FSystemFuncTbl) do
begin
with FSystemFuncTbl[ii] do
begin
sl.Add(Format('%s= Type:%d Param:%d P1=%d P2=%d P3=%d P4=%d',[Name,Ord(Typ),Param,Ord(ParamType[0]),Ord(ParamType[1]),Ord(ParamType[2]),Ord(ParamType[3])]));
end;
end;

Result := sl.Text;
sl.Free;
end;

procedure TCScript.TokenTableReSize(iNewSize: Integer);
var
ii: Integer;
begin
if Length(FTokenTbl) > iNewSize then
begin
for ii := High(FtokenTbl) downto iNewSize do
with FtokenTbl[ii] do
begin
// 释放占用的内存
//ShowMessage(Format('%s T=%d P=%d %.8x',[Name,Ord(Typ),Param,Address]));
// 这里Char * 实占用 Param + 1 字节空间 有少少内存泄露 需优化!
if Param > 0 then
if Ptr(Address) <> nil then
FreeMem(Ptr(Address),Param);
end;

SetLength(FTokenTbl,iNewSize);
end;
end;

procedure TCScript.DoAddDeclFuncToken(sToken, sValue: String);
var
p: Pointer;
begin
sToken := Trim(sToken); // 实为函数返回值类型
sValue := Trim(sValue); // 实为函数名
if TokenTableFind(sValue) >= 0 then Exit;

//if Pos('unsigned',sToken) then;/// 这里没处理这些类型及 P_XXX类型
case TypeNameToID(sToken) of
_VOID: TokenTableAdd(sValue,tkFunction,ttVoid,0,DWORD(nil));
_U8,_char: TokenTableAdd(sValue,tkFunction,ttByte,0,DWORD(nil));
_U16: TokenTableAdd(sValue,tkFunction,ttSmallInt,0,DWORD(nil));
_U32,_int: TokenTableAdd(sValue,tkFunction,ttInteger,0,DWORD(nil));
else
TokenTableAdd(sValue,tkFunction,ttInteger,0,DWORD(nil));
end;
end;


skertone 2009-03-03
  • 打赏
  • 举报
回复


constructor TCScript.Create;
begin
FSourceCode := TStringList.Create;
FGlobeTokenCount := 0;
FCurrentTokenCount := 0;

// 装载系统函数表
LoadSystemFunctionTbl;

FBreakTokenList := TStringList.Create;
EntryCount := 0;
end;

destructor TCScript.Destroy;
begin
FSourceCode.Free;
FBreakTokenList.Free;
end;


procedure TCScript.DoAddDefineToken(sToken, sValue: String);
var
p: Pointer;
begin
sToken := Trim(sToken);
sValue := Trim(sValue);
// 字符串常量
if Pos('"',sValue) > 0 then
begin
// 去掉 " "
Delete(sValue,1,1);
Delete(sValue,Length(sValue),1);
GetMem(p,Length(sValue) + 1); // 这里给常量保留了空间
StrPCopy(p,sValue);
TokenTableAdd(sToken,tkConst,ttString,Length(sValue),DWORD(p));
end
else
begin
if Pos('0X',UpperCase(sValue)) > 0 then
begin
// 十六进制整数
Delete(sValue,1,2);
Insert('$',sValue,1);
end;
GetMem(p,SizeOf(DWORD));
PDWORD(p)^ := StrToInt(sValue);
TokenTableAdd(sToken,tkConst,ttDWORD,SizeOf(DWORD),DWORD(p));
end
end;

procedure TCScript.Execute(Code: String;InLoop: Boolean);
var
ii,iTblSize: Integer;
sCode: String;
regExp: TRegExpr;
curIP: Integer;
begin
//***********************************************************************
// 执行一段代码块
// 此函数能递归执行
// 执行模式: 1.每取一行用正则表达式进行语义识别
// 2.向语义执行函数下传递整个代码块及IP作为参数
// 3.循环上述操直至IP指向代码段未尾
//***********************************************************************
iTblSize := CurrentTokenTblSize;

curIP := 1;

EntryCount := EntryCount + 1; // 重入记数

CleanSourceCode(Code);

while curIP < Length(Code) do
begin

if FStop then
begin
EntryCount := EntryCount - 1;
Break;
end;

if FLoopFlag = FLAG_CONTINUE then // continue; 调用
begin
if InLoop then // 此代码块恰好属循环体第一层,直接从头开始
ClearLoopFlag;
Break; // continue 不是跳到前面去执行,而是直接完成代码段
end
else
if FLoopFlag = FLAG_BREAK then // break;调用
begin
if InLoop then
ClearLoopFlag;
Break;
end;

sCode := GetExecuteCode(curIP,Code);

EventSrcSet(Code); // 输出清理过后的源码

EventIPMoved(curIP); // 输出当前执行位置

CheckStepByStep; // 检查是否需单步中断

regExp := TRegExpr.Create;
try
//ShowMessage(TokenDebugOut);

// 利用语义模式列表来识别相应语义
for ii := Low(RegExpList) to High(RegExpList) do
with regExp do
begin
Expression := RegExpList[ii];
Exec(sCode);
if MatchLen[0] > 0 then
begin
//do...
case ii of
EXP_CallFunc: DoCallFunction(curIP,Code);
EXP_DoubleOpp: DoDoubleOpp(curIP,Code);
EXP_While: DoWhile(curIP,Code);
EXP_For: DoFor(curIP,Code);
EXP_Excepression: DoExpression(curIP,Code);
EXP_If: DoIfElse(curIP,Code);
EXP_DoWhile: DoDoWhile(curIP,Code);
EXP_SelfOpp: DoSelfOpp(curIP,Code); // 没有执行体
EXP_Break: DoBreak(curIP,Code);
EXP_Continue: DoContinue(curIP,Code);
EXP_Return: ;
EXP_DeclVar: DoDeclLocalVar(curIP,Code);
else
DoBreak(curIP,Code); // 防死循环 (暂未加入Debug控制)
end;
end;
end;
finally
regExp.Free;
end;
end;

EventSrcSet('');
TokenTableReSize(iTblSize);
end;

procedure TCScript.GetDeclareTable;
begin
with TRegExpr.Create do
try
Expression := '\b(\w+)\s+([\w,\x20\*\[\]]*);';
InputString := SourceCode.Text;
Exec;
while MatchLen[0] > 0 do
begin
AddToTakenTbl(Match[1],Match[2]);
ExecNext;
end;
finally
Free;
end;
end;


procedure TCScript.GetGlobeDeclTable(Code: TStrings);
var
ii: Integer;
sl: TStrings;
begin
// 以下代码提取全局声明
sl := TStringList.Create;
try
sl.AddStrings(Code);
CleanSourceCode(sl); // 先清除注释行
sl.Text := BoneSourceCode(sl.Text); // 剔除代码

for ii := sl.Count - 1 downto 0 do
begin
// 删除掉空行,暂时不处理 #include..
if (Trim(sl[ii]) = '') OR (Pos('#include',sl[ii]) > 0) then
sl.Delete(ii);
end;

with TRegExpr.Create do
try
// 提取#define xxx xxx
Expression := REGEXP_Define;
Exec(sl.Text);
while MatchLen[0] > 0 do
begin
DoAddDefineToken(Match[1],Match[2]);
ExecNext;
end;
finally
Free;
end;

with TRegExpr.Create do
try
// 提取变量声明
Expression := REGEXP_DeclVar;
Exec(sl.Text);
while MatchLen[0] > 0 do
begin
// ShowMessage(Match[1] + ' ' + match[2]); debug
DoAddDeclareToken(Match[1],Match[2]);
ExecNext;
end;
finally
Free;
end;

with TRegExpr.Create do
try
// 提取函数声明
Expression := REGEXP_DeclFunc;
Exec(sl.Text);
while MatchLen[0] > 0 do
begin
//ShowMessage(Match[1] + ' ' + match[2]);
DoAddDeclFuncToken(Match[1],Match[2]);
ExecNext;
end;
finally
Free;
end;

finally
end;
end;


skertone 2009-03-03
  • 打赏
  • 举报
回复


const
FLAG_CONTINUE: Integer = -1;
FLAG_BREAK: Integer = -2;
TypeNameList: array[0..16] of String = ('void','U8','U16','U32','int','char','PU8','PU16','PU32',
'Text','Button','Edit','CheckBox','RadioButton','Combo',
'ListBox','Window');

_VOID = 0;
_U8 = 1;
_U16 = 2;
_U32 = 3;
_int = 4;
_char = 5;
_PU8 = 6;
_PU16 = 7;
_PU32 = 8;

RegExpList: array[1..12] of String = (
'^\s*(\w+)\(([^;\r\n]*)\)\s*;',
'(\*?[\w]+)(\+\+|--)\s*;',
'\bwhile\s*\(([^;\n\r]+)\)',
'\bfor\s*\(\s*([^;]*)\s*;\s*([^;]*)\s*;\s*([^;\)]*)\s*\)\s*\{?',
'([\*\w\.]+)\s*=\s*([^;=]+);',
'^\s*if\s*\(',
'\bdo\s*\{',
'(\*?[\w]+)\s*([\+-]{1}=)([^;]+);',
'\bbreak\s*;',
'\bcontinue\s*;',
'',
'^\s*(\w+)\s+([^;\(\)\{\}\r=]+)\s*;'
);
REGEXP_Define = '#define\s+(\w+)\s+([^\r]+)\s+';
REGEXP_DeclVar = '\r\s*(\w+)\s+([^;\(\)\{\}\r=]+)\s*;';
REGEXP_DeclFunc = '\b(\w+\x20*\w+)\s+(\w+)\(([^;\(\)]*)\)';
EXP_CallFunc = 1;
EXP_DoubleOpp = 2;
EXP_While = 3;
EXP_For = 4;
EXP_Excepression = 5;
EXP_If = 6;
EXP_DoWhile = 7;
EXP_SelfOpp = 8;
EXP_Break = 9;
EXP_Continue = 10;
EXP_Return = 11;
EXP_DeclVar = 12;

EXP_DeclFunc = 10;
EXP_Define = 11;


//EXP_CallFunc = '\b\w+\([\w,\x20\*&\[\]]*\)\s*;';
//EXP_DoubleOpp = '(\*?[\w]+)(\+\+|--)\s*;';
//EXP_While = '\bwhile\s*\(([^;\n\r]+)\)(\{|\s+)';
//EXP_For = '\bfor\s*\(\s*([^;]*)\s*;\s*([^;]*)\s*;\s*([^;]*)\s*\)(\{|\s+)';
//EXP_Excepression = '([\*\w]+)\s*=\s*([^;]+);';
//EXP_If = '\bif\s*\(([^;]+)\)\s{1}';
//EXP_DoWhile = '\bdo\s*\{';
//EXP_SelfOpp = '(\*?[\w]+)\s*([\+-]{1}=)([^;]+);' // *name += 123 + ia;


function GetCodeBlock(var sCode,sBlock: String;chLeft,chRight: Char): Integer;

implementation

uses SystemCallU,JBPlatformD;
{ TCScript }
procedure TCScript.AddToTakenTbl(sType,sVars: String);
var
ii: Integer;
sl: TStrings;
wType: Word;
sTemp: String;
// 拆出变量列表 带 *Str, intA[],格式
function GetVarList(sInput: String): TStrings;
var
iPos: Integer;
begin
Result := TStringList.Create;
iPos := Pos(',',sInput);
while iPos > 0 do
begin
Result.Add(Trim(Copy(sInput,1,iPos-1)));
sInput := Copy(sInput,iPos + 1,MAXWORD);
end;
if Trim(sInput) <> '' then
Result.Add(Trim(sInput));
end;
// 判断是滞是否 *xx 格式,同时去掉 * 号
function IsPointerVar(var S: String): Boolean;
begin
Result := Pos('*',S) > 0;
if Result then
S := Trim(Copy(S,Pos('*',S) + 1,MAXWORD));
end;
// 判断是否 A[] 数组格式 去掉 []
function IsArrayVar(var S: String): Boolean;
begin
Result := Pos(']',S) > 0;
if Result then
S := Trim(Copy(S,1,Pos('[',S) - 1));
end;
begin
end;

function TCScript.BoneSourceCode(Code: String): String;
var
ii,iPos: Integer;
begin
// 层层将 { .. } 内东东去掉
Result := Code;
iPos := Pos('}',Result);
while iPos > 0 do
begin
if Pos('(',Result) > 0 then
begin
for ii := iPos downto 1 do
if Ord(Result[ii]) = Ord('{') then
begin
Delete(Result,ii,iPos - ii + 1);
Break;
end;
end
else
Delete(Result,iPos,1);
iPos := Pos('}',Result);
end;
end;

procedure TCScript.CleanSourceCode(Code: TStrings);
var
ii,iPos: Integer;
rgp: TRegExpr;
sTemp: String;
begin
Code.BeginUpdate;
// 去掉多行注释
sTemp := Code.Text;
iPos := Pos('/*',sTemp);
while iPos > 0 do
begin
ii := Pos('*/',sTemp);
if ii > 0 then
Delete(sTemp,iPos,ii - iPos + 2);
iPos := Pos('/*',sTemp);
end;
Code.Text := sTemp;

rgp := TRegExpr.Create;
try
with Code do
if Count > 0 then
for ii := Count - 1 downto 0 do
begin
// 去掉注释 全行注释将变成空行,由去空行部分再去掉
rgp.Expression := '\s*//[^\r]*';
rgp.Exec(Strings[ii]);
if rgp.MatchLen[0] > 0 then
begin
sTemp := Strings[ii];
System.Delete(sTemp,rgp.MatchPos[0],MAXWORD);
Strings[ii] := sTemp;
end;

// 去掉空行
if Trim(Strings[ii]) = '' then
Delete(ii);
end;
finally
rgp.Free;
end;
Code.EndUpdate;
end;


skertone 2009-03-03
  • 打赏
  • 举报
回复


TCScript = class
private
FObjNeed: TEventObjectNeed;
FSrcSet: TEventSrcSet;
FIPMoved: TEventIPMoved;

FEntryCount: Integer; // 记录Execute 被重入次数
FPause: Boolean;
FStep: Boolean;
FStop: Boolean;
FLoopBreak: Boolean;
FLoopFlag: Integer;
FBreakTokenList: TStrings;

FGlobeTokenCount: Integer;
FSystemFuncCount: Integer;
FCurrentTokenCount: Integer;
FSourceCode: TStrings;
Fip: Integer;
FTokenTbl: array of TTokenNode;
FSystemFuncTbl: array of TSystemFunc;

function IsBreak: Boolean;
procedure ClearLoopFlag;

function TypeNameToID(sType: String): Integer;
procedure LoadSystemFunctionTbl;
procedure ClearStringSpace(var Str: String);
function GetExecuteCode(var IP: Integer;Code: String): String;

function GetTokenTypeByName(sType: String): TTokenType;


procedure AddToTakenTbl(sType,sVars: String);
procedure GetDeclareTable;//?
procedure CleanSourceCode(Code: TStrings); overload;
procedure CleanSourceCode(var Code: String); overload;
function BoneSourceCode(Code: String): String;

procedure TokenTableAdd(AToken: String;AKind: TTokenKind;AType: TTokenType;AParam: Integer;Addr: DWORD);
function TokenTableFind(AToken: String): Integer;
procedure TokenFunction(sName,sType,sParam: String);

function SystemFuncTableFind(sName: String): Integer;

function GetParamTokenListFromStr(sParam: String): TStrings;

procedure EventSrcSet(Source: String);
procedure EventIPMoved(IP: Integer);

procedure DoAddDefineToken(sToken,sValue: String);
procedure DoAddDeclareToken(sToken,sValue: String);
procedure DoAddDeclFuncToken(sToken,sValue: String);

// 此类精细识别只分析单行字符应 ^xxxx$ 显式标明首尾
function LeftIsFunction(S: String;var sFunc,sParam: String): Boolean;
function LeftIsSimple(S: String;var sToken: String): Boolean;
function LeftIsExpression(S: String;var sExpression: String): Boolean;
function ExpIsObject(S: String;var ObjName,ObjProp: String): Boolean;

function GoArithmetic(sExpression: String): Variant;
function GoCallFunction(sFunc,sParam: String): Variant;
function GoAssignValue(sValue: String): Variant;
function GoCondition(sExpression: String): Boolean;

function RePlaceToken(sexpr: String): String;
procedure AssignTokenValue(AToken: String;Value: Variant);
function TokenValue(AToken: String): Variant;
function TokenValueOfByte(AToken: String): Byte;
function TokenValueOfWord(AToken: String): Word;
function TokenValueOfInteger(AToken: String): Integer;
function TokenValueOfDword(AToken: String): DWORD;
function TokenValueOfDouble(AToken: String): Double;
function TokenValueOfPointer(AToken: String): Pointer;

function GetTokenTblSize: Integer;

procedure CheckStepByStep;
procedure SetEntryCount(const Value: Integer);
protected
procedure DoExpression(var IP: Integer;sCode: String);
procedure DoCallFunction(var IP: Integer;sCode: String);
procedure DoIfElse(var IP: Integer;sCode: String);
procedure DoWhile(var IP: Integer;sCode: String);
procedure DoBreak(var IP: Integer;sCode: String);
procedure DoSelfOpp(var IP: Integer;sCode: String);
procedure DoContinue(var IP: Integer;sCode: String);
procedure DoDoubleOpp(var IP: Integer;sCode: String);
procedure DoDoWhile(var IP: Integer;sCode: String);
procedure DoFor(var IP: Integer;sCode: String);
procedure DoDeclLocalVar(var IP: Integer;sCode: String);

function GetLocalDeclTable(Code: String): Integer;
function CheckBreakTokenList(AToken: String): Boolean;
property EntryCount: Integer read FEntryCount write SetEntryCount;
public
function GetTokenValue(AToken: String): Variant;
procedure GetGlobeDeclTable(Code: TStrings);
procedure TokenTableReSize(iNewSize: Integer);
constructor Create;
destructor Destroy;
procedure Execute(Code: String;InLoop: Boolean=False); overload;
procedure NextStep;
procedure Stop;
procedure Pause;
procedure GetTokenInfo(const Token: String;var sType,sValue: String);
property SourceCode: TStrings read FSourceCode;
property CurrentTokenTblSize: Integer read GetTokenTblSize;
property OnObjNeed: TEventObjectNeed read FObjNeed write FObjNeed;
property OnSrcSet: TEventSrcSet read FSrcSet write FSrcSet;
property OnIPMoved: TEventIPMoved read FIPMoved write FIPMoved;
property StepByStep: Boolean read FStep write FStep;
property BreakTokenList: TStrings read FBreakTokenList write FBreakTokenList;

function TokenDebugOut: String;
end;





skertone 2009-03-03
  • 打赏
  • 举报
回复
我写过一个简单的C语言解释器,不编译及检查错误,直接解释执行,可单步及查看变量

因为当时语法检测有其它编译工具进行了,该代码只是“模拟”执行而已,连四则运算都懒得做全了

逻辑运算根本就没做。 使用了正则表达式模块可以网上找到。



unit CScriptU;
//******************************************************************************
//
// C 语言解释执行类
//
//******************************************************************************

interface
uses Windows,RegExprNew,Classes,Sysutils,ExprCalcU,Dialogs,Forms,Variants;

const
NULL = vaNULL;
type
TEventObjectNeed = procedure(Sender: TObject;ObjName: String;ObjPro: String;var Value: Variant) of Object;
TEventSrcSet = procedure(Sender: TObject;Code: String) of Object;
TEventIPMoved = procedure(Sender: TObject;IP: Integer) of Object;

TTokenKind = (tkUnknow,tkArray,tkVariable,tkFunction,tkConst);
TTokenType = (ttUnknow,ttByte,ttSmallInt,ttInteger,ttDWORD,ttDouble,ttString,ttPointer,ttVoid,ttObject);
TTokenNode = record
Name: String[120]; // 保存符号名
Kind: TTokenKind; // 符号代表类型
Typ: TTokenType; // 容纳数据类型
Param: Integer; // 占用空间 注:指针占用空间为0
Address: DWORD; // 地址
end;

TSystemFunc = record // 保存系统支持列程名称
Name: String[120]; // 函数名
Typ: TTokenType; // 返回值类型
Param: Integer; // 参数个数
ParamType: array[0..10] of TTokenType;// 参数数据类型 10以上参数不支持:P
end;

TParamNode = packed record
case Integer of
0:(dValue: DWORD);
1:(iValue: Integer);
2:(bValue: Byte);
3:(wValue: Word);
4:(pValue: Pointer);
5:(fValue: Double);
end;


TCMathProcess = class
FInput: String;
FNumbStack: TStrings;
FOppStack: TStrings;
private
procedure SplitToken;
public
constructor Create;
destructor Destroy;
function Exec: Variant;
end;


genispan 2009-03-03
  • 打赏
  • 举报
回复
楼上牛人啊 佩服
gyk120 2009-02-16
  • 打赏
  • 举报
回复
能写解析器的都是大牛啊。。。暂时还没达到那地步的某人飘过膜拜
tanqth 2009-02-15
  • 打赏
  • 举报
回复
帮顶一下

16,748

社区成员

发帖
与我相关
我的任务
社区描述
Delphi 语言基础/算法/系统设计
社区管理员
  • 语言基础/算法/系统设计社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧