paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-03 22:00:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: parser is now abortable

Browse Source 
git-svn-id: trunk@3601 -
This commit is contained in:
lazarus 2002-11-02 23:30:58 +00:00
parent 1cb12c9983
commit 6ecb567b0a
2 changed files with 90 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
components/codetools/codetoolmanager.pas
View File

@ -56,9 +56,11 @@ type
TOnSearchUsedUnit = function(const SrcFilename: string;
const TheUnitName, TheUnitInFilename: string): TCodeBuffer of object;
TOnCodeToolCheckAbort = function: boolean of object;
TCodeToolManager = class
private
FAbortable: boolean;
FAddInheritedCodeToOverrideMethod: boolean;
FAdjustTopLineDueToComment: boolean;
FCatchExceptions: boolean;
@ -75,6 +77,7 @@ type
FJumpCentered: boolean;
FOnAfterApplyChanges: TOnAfterApplyChanges;
FOnBeforeApplyChanges: TOnBeforeApplyChanges;
FOnCheckAbort: TOnCodeToolCheckAbort;
FOnSearchUsedUnit: TOnSearchUsedUnit;
FResourceTool: TResourceCodeTool;
FSetPropertyVariablename: string;
@ -98,6 +101,7 @@ type
function FindCodeToolForSource(Code: TCodeBuffer): TCustomCodeTool;
function GetCodeToolForSource(Code: TCodeBuffer;
ExceptionOnError: boolean): TCustomCodeTool;
procedure SetAbortable(const AValue: boolean);
procedure SetAddInheritedCodeToOverrideMethod(const AValue: boolean);
procedure SetCheckFilesOnDisk(NewValue: boolean);
procedure SetCompleteProperties(const AValue: boolean);
@ -113,6 +117,7 @@ type
procedure OnToolSetWriteLock(Lock: boolean);
procedure OnToolGetWriteLockInfo(var WriteLockIsSet: boolean;
var WriteLockStep: integer);
procedure OnParserProgress(Tool: TCustomCodeTool);
function GetResourceTool: TResourceCodeTool;
public
DefinePool: TDefinePool; // definition templates (rules)
@ -147,6 +152,9 @@ type
property ErrorLine: integer read fErrorLine;
property ErrorMessage: string read fErrorMsg;
property ErrorTopLine: integer read fErrorTopLine;
property Abortable: boolean read FAbortable write SetAbortable;
property OnCheckAbort: TOnCodeToolCheckAbort
read FOnCheckAbort write FOnCheckAbort;
// tool settings
property AdjustTopLineDueToComment: boolean
@ -328,6 +336,10 @@ var CodeToolBoss: TCodeToolManager;
implementation
type
ECodeToolAbort = Exception;
function CompareCodeToolMainSources(Data1, Data2: Pointer): integer;
var
Src1, Src2: integer;
@ -571,26 +583,33 @@ var ErrorSrcTool: TCustomCodeTool;
begin
fErrorMsg:=AnException.Message;
fErrorTopLine:=0;
if not ((AnException is ELinkScannerError) or (AnException is ECodeToolError))
then begin
FErrorMsg:=AnException.ClassName+': '+FErrorMsg;
end;
if (AnException is ELinkScannerError) then begin
// linker error
fErrorCode:=TCodeBuffer(ELinkScannerError(AnException).Sender.Code);
if fErrorCode<>nil then begin
fErrorCode.AbsoluteToLineCol(
ELinkScannerError(AnException).Sender.SrcPos,fErrorLine,fErrorColumn);
end;
end else if (AnException is ECodeToolError) then begin
// codetool error
ErrorSrcTool:=ECodeToolError(AnException).Sender;
fErrorCode:=ErrorSrcTool.ErrorPosition.Code;
fErrorColumn:=ErrorSrcTool.ErrorPosition.X;
fErrorLine:=ErrorSrcTool.ErrorPosition.Y;
end else if FCurCodeTool<>nil then begin
fErrorCode:=FCurCodeTool.ErrorPosition.Code;
fErrorColumn:=FCurCodeTool.ErrorPosition.X;
fErrorLine:=FCurCodeTool.ErrorPosition.Y;
end else if (AnException is ECodeToolAbort) then begin
// abort
FErrorMsg:='Abort';
fErrorCode:=nil;
end else begin
// unknown exception
FErrorMsg:=AnException.ClassName+': '+FErrorMsg;
if FCurCodeTool<>nil then begin
fErrorCode:=FCurCodeTool.ErrorPosition.Code;
fErrorColumn:=FCurCodeTool.ErrorPosition.X;
fErrorLine:=FCurCodeTool.ErrorPosition.Y;
end;
end;
// adjust error topline
if (fErrorCode<>nil) and (fErrorTopLine<1) then begin
fErrorTopLine:=fErrorLine;
if (fErrorTopLine>0) and JumpCentered then begin
@ -598,6 +617,7 @@ begin
if fErrorTopLine<1 then fErrorTopLine:=1;
end;
end;
// write error
if FWriteExceptions then begin
{$IFDEF CTDEBUG}
WriteDebugReport(true,false,false,false,false);
@ -608,6 +628,7 @@ begin
if ErrorCode<>nil then write(' in "',ErrorCode.Filename,'"');
writeln('');
end;
// raise or catch
if not FCatchExceptions then raise AnException;
Result:=false;
end;
@ -1524,6 +1545,14 @@ begin
Result:=nil;
end;
procedure TCodeToolManager.OnParserProgress(Tool: TCustomCodeTool);
begin
if not FAbortable then exit;
if not Assigned(OnCheckAbort) then exit;
if OnCheckAbort() then
raise ECodeToolAbort.Create('Abort');
end;
function TCodeToolManager.OnScannerGetInitValues(Code: Pointer;
var AChangeStep: integer): TExpressionEvaluator;
begin
@ -1673,6 +1702,13 @@ begin
TFindDeclarationTool(Result).OnFindUsedUnit:=@DoOnFindUsedUnit;
Result.OnSetGlobalWriteLock:=@OnToolSetWriteLock;
Result.OnGetGlobalWriteLockInfo:=@OnToolGetWriteLockInfo;
TFindDeclarationTool(Result).OnParserProgress:=@OnParserProgress;
end;
procedure TCodeToolManager.SetAbortable(const AValue: boolean);
begin
if FAbortable=AValue then exit;
FAbortable:=AValue;
end;
procedure TCodeToolManager.SetAddInheritedCodeToOverrideMethod(

57
components/codetools/pascalparsertool.pas
View File

@ -46,6 +46,8 @@ uses
LinkScanner, CodeCache, AVL_Tree, TypInfo, SourceChanger;
type
TOnParserProgress = procedure(Tool: TCustomCodeTool) of object;
TProcHeadAttribute = (
// extract attributes:
phpWithStart, // proc keyword e.g. 'function', 'class procedure'
@ -98,10 +100,13 @@ type
ExtractSearchPos: integer;
ExtractFoundPos: integer;
ExtractProcHeadPos: TProcHeadExtractPos;
FProgressCount: integer;
FOnParserProgress: TOnParserProgress;
procedure RaiseCharExpectedButAtomFound(c: char);
procedure RaiseStringExpectedButAtomFound(const s: string);
procedure RaiseUnexpectedKeyWord;
procedure RaiseIllegalQualifier;
procedure DoProgress;
protected
procedure InitExtraction;
function GetExtraction: string;
@ -182,6 +187,7 @@ type
function CleanPosIsInComment(CleanPos, CleanCodePosInFront: integer;
var CommentStart, CommentEnd: integer): boolean;
procedure BeginParsing(DeleteNodes, OnlyInterfaceNeeded: boolean); override;
procedure BuildTree(OnlyInterfaceNeeded: boolean); virtual;
procedure BuildTreeAndGetCleanPos(TreeRange: TTreeRange;
CursorPos: TCodeXYPosition; var CleanCursorPos: integer;
@ -193,7 +199,7 @@ type
var FunctionResult: TCodeTreeNode);
function DoAtom: boolean; override;
function ExtractPropName(PropNode: TCodeTreeNode;
InUpperCase: boolean): string;
function ExtractPropType(PropNode: TCodeTreeNode;
@ -246,6 +252,9 @@ type
procedure MoveCursorToUsesEnd(UsesNode: TCodeTreeNode);
procedure ReadPriorUsedUnit(var UnitNameAtom, InAtom: TAtomPosition);
property OnParserProgress: TOnParserProgress
read FOnParserProgress write FOnParserProgress;
constructor Create;
destructor Destroy; override;
@ -792,6 +801,7 @@ var Level: integer;
begin
Level:=1;
while (CurPos.StartPos<=SrcLen) and (Level>0) do begin
DoProgress;
ReadNextAtom;
if CurPos.Flag=cafRECORD then inc(Level)
else if (CurPos.Flag=cafEND) then dec(Level);
@ -1603,16 +1613,18 @@ end;
function TPascalParserTool.DoAtom: boolean;
begin
//writeln('[TPascalParserTool.DoAtom] A ',HexStr(Cardinal(CurKeyWordFuncList),8));
if (CurPos.StartPos>SrcLen) or (CurPos.EndPos<=CurPos.StartPos) then
Result:=false
else if IsIdentStartChar[Src[CurPos.StartPos]] then
Result:=CurKeyWordFuncList.DoItUpperCase(UpperSrc,CurPos.StartPos,
CurPos.EndPos-CurPos.StartPos)
else begin
if Src[CurPos.StartPos] in ['(','['] then
ReadTilBracketClose(true);
Result:=true;
end;
DoProgress;
if (CurPos.StartPos<=SrcLen) and (CurPos.EndPos>CurPos.StartPos) then begin
if IsIdentStartChar[Src[CurPos.StartPos]] then
Result:=CurKeyWordFuncList.DoItUpperCase(UpperSrc,CurPos.StartPos,
CurPos.EndPos-CurPos.StartPos)
else begin
if Src[CurPos.StartPos] in ['(','['] then
ReadTilBracketClose(true);
Result:=true;
end;
end else
Result:=false;
end;
function TPascalParserTool.KeyWordFuncSection: boolean;
@ -1662,6 +1674,7 @@ begin
CurNode.Desc:=ctnFinalization;
CurSection:=CurNode.Desc;
repeat
DoProgress;
ReadNextAtom;
if (CurSection=ctnInitialization) and UpAtomIs('FINALIZATION') then
begin
@ -1853,6 +1866,7 @@ begin
RaiseUnknownBlockType;
BlockStartPos:=CurPos.StartPos;
repeat
DoProgress;
ReadNextAtom;
if (CurPos.StartPos>SrcLen) then
SaveRaiseExceptionWithBlockStartHint(ctsUnexpectedEndOfSource);
@ -2085,6 +2099,7 @@ begin
end else begin
// read till semicolon or 'end'
while (CurPos.Flag<>cafSemicolon) do begin
DoProgress;
ReadNextAtom;
if CurPos.Flag=cafEND then begin
UndoReadNextAtom;
@ -2292,6 +2307,7 @@ begin
CurNode.Desc:=ctnTypeSection;
// read all type definitions Name = Type;
repeat
DoProgress;
ReadNextAtom; // name
if AtomIsIdentifier(false) then begin
CreateChildNode;
@ -2342,6 +2358,7 @@ begin
CurNode.Desc:=ctnVarSection;
// read all variable definitions Name : Type; [cvar;] [public [name '']]
repeat
DoProgress;
ReadNextAtom; // name
if AtomIsIdentifier(false) then begin
CreateChildNode;
@ -2390,6 +2407,7 @@ begin
CurNode.Desc:=ctnConstSection;
// read all constants Name = <Const>; or Name : type = <Const>;
repeat
DoProgress;
ReadNextAtom; // name
if AtomIsIdentifier(false) then begin
CreateChildNode;
@ -2445,6 +2463,7 @@ begin
CurNode.Desc:=ctnResStrSection;
// read all string constants Name = 'abc';
repeat
DoProgress;
ReadNextAtom; // name
if AtomIsIdentifier(false) then begin
CreateChildNode;
@ -2567,6 +2586,7 @@ begin
end else begin
Level:=1;
while (CurPos.StartPos<=SrcLen) do begin
DoProgress;
if CurPos.Flag=cafEND then begin
dec(Level);
if Level=0 then break;
@ -3141,6 +3161,14 @@ begin
SaveRaiseExceptionFmt(ctsIllegalQualifier,[GetAtom]);
end;
procedure TPascalParserTool.DoProgress;
begin
inc(FProgressCount);
if ((FProgressCount and $ff)<>0) then exit;
if Assigned(OnParserProgress) then
OnParserProgress(Self);
end;
procedure TPascalParserTool.InitExtraction;
begin
if ExtractMemStream=nil then
@ -3705,6 +3733,13 @@ begin
until CurPos.StartPos>=SrcLen;
end;
procedure TPascalParserTool.BeginParsing(DeleteNodes,
OnlyInterfaceNeeded: boolean);
begin
inherited BeginParsing(DeleteNodes, OnlyInterfaceNeeded);
FProgressCount:=0;
end;
procedure TPascalParserTool.BuildTreeAndGetCleanPos(
TreeRange: TTreeRange; CursorPos: TCodeXYPosition;
var CleanCursorPos: integer; BuildTreeFlags: TBuildTreeFlags);