From 96a0c44d9e053b30cffbec2ce89409546b4e071b Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Tue, 26 Dec 2017 22:23:01 +0000 Subject: [PATCH] fcl-passrc: scanner: $Message directive, option po_StopOnErrorDirective git-svn-id: trunk@37821 - --- packages/fcl-passrc/src/pasresolver.pp | 33 ++++++- packages/fcl-passrc/src/pparser.pp | 2 + packages/fcl-passrc/src/pscanner.pp | 114 +++++++++++++++++------ packages/fcl-passrc/tests/tcresolver.pas | 24 +++-- 4 files changed, 135 insertions(+), 38 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index ceb71dad15..c53795c758 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -86,6 +86,7 @@ Works: - function pred(ordinal): ordinal - function high(ordinal): ordinal - cast integer to enum, enum to integer + - $ScopedEnums - sets - TPasSetType - set of char - set of integer @@ -171,14 +172,13 @@ Works: - var modifier 'absolute' ToDo: -- for..in..do - - operator +- $pop, $push +- $writableconst off $J- +- $RTTI inherited|explicit - range checking: - indexedprop[param] - case-of unique - defaultvalue -- scoped enum -- $writableconst off $J- - fail to write a loop var inside the loop - warn: create class with abstract methods - nested classes @@ -200,10 +200,13 @@ ToDo: - generics - futures - operator overload + - operator enumerator - attributes - anonymous functions - TPasFileType - labels +- $warn identifier ON|off|error|default +- $zerobasedstrings on|off Debug flags: -d VerbosePasResolver @@ -929,6 +932,14 @@ type ); TPasResolverOptions = set of TPasResolverOption; + TPasResolverStep = ( + prsInit, + prsParsing, + prsFinishingModule, + prsFinishedModule + ); + TPasResolverSteps = set of TPasResolverStep; + { TPasResolver } TPasResolver = Class(TPasTreeContainer) @@ -966,6 +977,7 @@ type FScopeClass_WithExpr: TPasWithExprScopeClass; FScopeCount: integer; FScopes: array of TPasScope; // stack of scopes + FStep: TPasResolverStep; FStoreSrcColumns: boolean; FSubScopeCount: integer; FSubScopes: array of TPasScope; // stack of scopes @@ -1480,6 +1492,7 @@ type // parsed values property DefaultNameSpace: String read FDefaultNameSpace; property RootElement: TPasModule read FRootElement; + property Step: TPasResolverStep read FStep; // scopes property StoreSrcColumns: boolean read FStoreSrcColumns write FStoreSrcColumns; { If true Line and Column is mangled together in TPasElement.SourceLineNumber. @@ -3415,6 +3428,8 @@ begin {$IFDEF VerbosePasResolver} writeln('TPasResolver.FinishModule START ',CurModule.Name); {$ENDIF} + FStep:=prsFinishingModule; + CurModuleClass:=CurModule.ClassType; if (CurModuleClass=TPasProgram) or (CurModuleClass=TPasLibrary) then begin @@ -3447,6 +3462,7 @@ begin CheckTopScope(TPasModuleScope); PopScope; + FStep:=prsFinishedModule; {$IFDEF VerbosePasResolver} writeln('TPasResolver.FinishModule END ',CurModule.Name); {$ENDIF} @@ -10163,7 +10179,11 @@ begin El.SourceFilename:=ASrcPos.FileName; El.SourceLinenumber:=SrcY; if FRootElement=nil then + begin FRootElement:=NoNil(Result) as TPasModule; + if FStep=prsInit then + FStep:=prsParsing; + end; if IsElementSkipped(El) then exit; @@ -11592,6 +11612,11 @@ procedure TPasResolver.LogMsg(const id: int64; MsgType: TMessageType; MsgNumber: integer; const Fmt: String; Args: array of const; PosEl: TPasElement); begin + if (FStepnil) + and (CurrentParser.Scanner.IgnoreMsgType(MsgType)) then + exit; // during parsing consider directives like $Hints on|off + SetLastMsg(id,MsgType,MsgNumber,Fmt,Args,PosEl); if Assigned(OnLog) then OnLog(Self,FLastMsg) diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 23c532cadf..8f67fecad6 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -4047,6 +4047,8 @@ Var Msg : String; begin + if (Scanner<>nil) and Scanner.IgnoreMsgType(MsgType) then + exit; SetLastMsg(MsgType,MsgNumber,Fmt,Args); If Assigned(FOnLog) then begin diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index bdc1e322cc..eb251c52f1 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -271,12 +271,16 @@ type // switches, that can be 'on' or 'off' and have no corresponding letter switch TBoolSwitch = ( + bsHints, + bsNotes, + bsWarnings, bsMacro, bsScopedEnums ); TBoolSwitches = set of TBoolSwitch; const - bsAll = [bsMacro..bsScopedEnums]; + bsAll = [low(TBoolSwitch)..high(TBoolSwitch)]; + FPCModeBoolSwitches = [bsHints,bsNotes,bsWarnings,bsMacro]; type TTokenOption = (toForceCaret,toOperatorToken); @@ -487,7 +491,7 @@ type TPascalScannerPPSkipMode = (ppSkipNone, ppSkipIfBranch, ppSkipElseBranch, ppSkipAll); TPOption = ( - po_delphi, // DEPRECATED Delphi mode: forbid nested comments + po_delphi, // DEPRECATED since fpc 3.1.1: Delphi mode: forbid nested comments po_KeepScannerError, // default: catch EScannerError and raise an EParserError instead po_CAssignments, // allow C-operators += -= *= /= po_ResolveStandardTypes, // search for 'longint', 'string', etc., do not use dummies, TPasResolver sets this to use its declarations @@ -497,7 +501,8 @@ type po_ArrayRangeExpr, // enable: create TPasArrayType.IndexRange, disable: create TPasArrayType.Ranges po_SelfToken, // Self is a token. For backward compatibility. po_CheckModeSwitches, // stop on unknown modeswitch with an error - po_CheckCondFunction // stop on unknown function in conditional expression, default: return '0' + po_CheckCondFunction, // stop on unknown function in conditional expression, default: return '0' + po_StopOnErrorDirective // stop on user $Error, $message error|fatal ); TPOptions = set of TPOption; @@ -576,8 +581,6 @@ type Value: string): boolean; procedure SetAllowedBoolSwitches(const AValue: TBoolSwitches); procedure SetAllowedModeSwitches(const AValue: TModeSwitches); - procedure SetCurrentBoolSwitches(const AValue: TBoolSwitches); - procedure SetCurrentModeSwitches(AValue: TModeSwitches); procedure SetMacrosOn(const AValue: boolean); procedure SetOptions(AValue: TPOptions); procedure SetReadOnlyBoolSwitches(const AValue: TBoolSwitches); @@ -603,6 +606,7 @@ type procedure HandleENDIF(const AParam: String); procedure HandleDefine(Param: String); virtual; procedure HandleError(Param: String); virtual; + procedure HandleMessageDirective(Param: String); virtual; procedure HandleIncludeFile(Param: String); virtual; procedure HandleUnDefine(Param: String);virtual; function HandleInclude(const Param: String): TToken;virtual; @@ -615,6 +619,8 @@ type procedure ClearFiles; Procedure ClearMacros; Procedure SetCurTokenString(AValue : string); + procedure SetCurrentBoolSwitches(const AValue: TBoolSwitches); virtual; + procedure SetCurrentModeSwitches(AValue: TModeSwitches); virtual; function LogEvent(E : TPScannerLogEvent) : Boolean; inline; public constructor Create(AFileResolver: TBaseFileResolver); @@ -638,6 +644,7 @@ type Procedure SetCompilerMode(S : String); function CurSourcePos: TPasSourcePos; Function SetForceCaret(AValue : Boolean) : Boolean; // returns old state + function IgnoreMsgType(MsgType: TMessageType): boolean; virtual; property FileResolver: TBaseFileResolver read FFileResolver; property CurSourceFile: TLineReader read FCurSourceFile; property CurFilename: string read FCurFilename; @@ -849,35 +856,38 @@ const ); LetterSwitchNames: array['A'..'Z'] of string=( - 'ALIGN' // A - ,'BOOLEVAL' // B - ,'ASSERTIONS' // C - ,'DEBUGINFO' // D - ,'EXTENSION' // E + 'ALIGN' // A align fields + ,'BOOLEVAL' // B complete boolean evaluation + ,'ASSERTIONS' // C generate code for assertions + ,'DEBUGINFO' // D generate debuginfo (debug lines), OR: $description 'text' + ,'EXTENSION' // E output file extension ,'' // F ,'IMPORTEDDATA' // G - ,'LONGSTRINGS' // H - ,'IOCHECKS' // I - ,'WRITEABLECONST' // J + ,'LONGSTRINGS' // H String=AnsiString + ,'IOCHECKS' // I generate EInOutError + ,'WRITEABLECONST' // J writable typed const ,'' // K - ,'LOCALSYMBOLS' // L - ,'TYPEINFO' // M + ,'LOCALSYMBOLS' // L generate local symbol information (debug, requires $D+) + ,'TYPEINFO' // M allow published members OR $M minstacksize,maxstacksize ,'' // N - ,'OPTIMIZATION' // O - ,'OPENSTRINGS' // P + ,'OPTIMIZATION' // O enable safe optimizations (-O1) + ,'OPENSTRINGS' // P deprecated Delphi directive ,'OVERFLOWCHECKS' // Q - ,'RANGECHECKS' // R + ,'RANGECHECKS' // R OR resource ,'' // S - ,'TYPEADDRESS' // T + ,'TYPEDADDRESS' // T enabled: @variable gives typed pointer, otherwise untyped pointer ,'SAFEDIVIDE' // U - ,'VARSTRINGCHECKS'// V - ,'STACKFRAMES' // W - ,'EXTENDEDSYNTAX' // X - ,'REFERENCEINFO' // Y + ,'VARSTRINGCHECKS'// V strict shortstring checking, e.g. cannot pass shortstring[3] to shortstring + ,'STACKFRAMES' // W always generate stackframes (debugging) + ,'EXTENDEDSYNTAX' // X deprecated Delphi directive + ,'REFERENCEINFO' // Y store for each identifier the declaration location ,'' // Z ); BoolSwitchNames: array[TBoolSwitch] of string = ( + 'Hints', + 'Notes', + 'Warnings', 'Macro', 'ScopedEnums' ); @@ -2218,7 +2228,7 @@ begin FAllowedModes:=AllLanguageModes; FCurrentModeSwitches:=FPCModeSwitches; FAllowedModeSwitches:=msAllFPCModeSwitches; - FCurrentBoolSwitches:=[]; + FCurrentBoolSwitches:=FPCModeBoolSwitches; FAllowedBoolSwitches:=bsAll; FConditionEval:=TCondDirectiveEvaluator.Create; FConditionEval.OnLog:=@OnCondEvalLog; @@ -2624,12 +2634,41 @@ end; procedure TPascalScanner.HandleError(Param: String); begin - if po_CheckCondFunction in Options then + if po_StopOnErrorDirective in Options then Error(nUserDefined, SUserDefined,[Param]) else DoLog(mtWarning,nUserDefined,SUserDefined+' error',[Param]); end; +procedure TPascalScanner.HandleMessageDirective(Param: String); +var + p: Integer; + Kind: String; + MsgType: TMessageType; +begin + if Param='' then exit; + p:=1; + while (p<=length(Param)) and (Param[p] in ['a'..'z','A'..'Z']) do inc(p); + Kind:=LeftStr(Param,p-1); + MsgType:=mtHint; + case UpperCase(Kind) of + 'HINT': MsgType:=mtHint; + 'NOTE': MsgType:=mtNote; + 'WARN': MsgType:=mtError; + 'ERROR': MsgType:=mtError; + 'FATAL': MsgType:=mtFatal; + else + // $Message 'hint text' + p:=1; + end; + while (p<=length(Param)) and (Param[p] in [' ',#9]) do inc(p); + Delete(Param,1,p-1); + if MsgType in [mtFatal,mtError] then + HandleError(Param) + else + DoLog(MsgType,nUserDefined,SUserDefined,[Param]) +end; + procedure TPascalScanner.HandleUnDefine(Param: String); begin UnDefine(GetMacroName(Param)); @@ -2945,23 +2984,31 @@ begin 'ERROR': HandleError(Param); 'HINT': - DoLog(mtHint,nUserDefined,SUserDefined,[Directive]); + DoLog(mtHint,nUserDefined,SUserDefined,[Param]); + 'HINTS': + DoBoolDirective(bsHints); 'I','INCLUDE': Result:=HandleInclude(Param); 'MACRO': DoBoolDirective(bsMacro); + 'MESSAGE': + HandleMessageDirective(Param); 'MODE': HandleMode(Param); 'MODESWITCH': HandleModeSwitch(Param); 'NOTE': - DoLog(mtNote,nUserDefined,SUserDefined,[Directive]); + DoLog(mtNote,nUserDefined,SUserDefined,[Param]); + 'NOTES': + DoBoolDirective(bsNotes); 'SCOPEDENUMS': DoBoolDirective(bsScopedEnums); 'UNDEF': HandleUnDefine(Param); 'WARNING': - DoLog(mtWarning,nUserDefined,SUserDefined,[Directive]); + DoLog(mtWarning,nUserDefined,SUserDefined,[Param]); + 'WARNINGS': + DoBoolDirective(bsWarnings); else Handled:=false; end; @@ -3656,6 +3703,7 @@ Var Msg : String; begin + if IgnoreMsgType(MsgType) then exit; SetCurMsg(MsgType,MsgNumber,Fmt,Args); If Assigned(FOnLog) then begin @@ -3841,4 +3889,14 @@ begin Exclude(FTokenOptions,toForceCaret) end; +function TPascalScanner.IgnoreMsgType(MsgType: TMessageType): boolean; +begin + case MsgType of + mtWarning: if not (bsWarnings in FCurrentBoolSwitches) then exit(true); + mtNote: if not (bsNotes in FCurrentBoolSwitches) then exit(true); + mtHint: if not (bsHints in FCurrentBoolSwitches) then exit(true); + end; + Result:=false; +end; + end. diff --git a/packages/fcl-passrc/tests/tcresolver.pas b/packages/fcl-passrc/tests/tcresolver.pas index b93f594a5c..6d9645b49c 100644 --- a/packages/fcl-passrc/tests/tcresolver.pas +++ b/packages/fcl-passrc/tests/tcresolver.pas @@ -213,9 +213,10 @@ type Procedure TestIntegerRange; Procedure TestIntegerRangeHighLowerLowFail; Procedure TestIntegerRangeLowHigh; - Procedure TestAssignIntRangeFail; - Procedure TestByteRangeFail; - Procedure TestCustomIntRangeFail; + Procedure TestAssignIntRangeWarning; + Procedure TestByteRangeWarning; + Procedure TestByteRangeWarningOff; + Procedure TestCustomIntRangeWarning; Procedure TestIntSet_Const; Procedure TestIntSet_ConstDuplicateElement; Procedure TestInt_ForIn; @@ -2542,7 +2543,7 @@ begin CheckResolverUnexpectedHints; end; -procedure TTestResolver.TestAssignIntRangeFail; +procedure TTestResolver.TestAssignIntRangeWarning; begin StartProgram(false); Add([ @@ -2556,7 +2557,7 @@ begin CheckResolverUnexpectedHints; end; -procedure TTestResolver.TestByteRangeFail; +procedure TTestResolver.TestByteRangeWarning; begin StartProgram(false); Add([ @@ -2568,7 +2569,18 @@ begin CheckResolverUnexpectedHints; end; -procedure TTestResolver.TestCustomIntRangeFail; +procedure TTestResolver.TestByteRangeWarningOff; +begin + StartProgram(false); + Add([ + '{$warnings off}', + 'var b:byte=300;', + 'begin']); + ParseProgram; + CheckResolverUnexpectedHints; +end; + +procedure TTestResolver.TestCustomIntRangeWarning; begin StartProgram(false); Add([