From 04807d1ac47cdeff7ccb79b51cd0329693ecc7e4 Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Sat, 6 May 2017 20:11:26 +0000 Subject: [PATCH] fcl-passrc: implemented $if git-svn-id: trunk@36140 - --- packages/fcl-passrc/src/pasresolver.pp | 3 +- packages/fcl-passrc/src/pscanner.pp | 946 +++++++++++++++++++++++- packages/fcl-passrc/tests/tcscanner.pas | 151 +++- 3 files changed, 1078 insertions(+), 22 deletions(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 34e4ed0a50..6f54cfafc6 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -137,8 +137,9 @@ Works: - dotted unitnames ToDo: +- $IFOpt + $IF option() - @@ -- fix slow lookup declaration proc in PParser - fail to write a loop var inside the loop - warn: create class with abstract methods - classes - TPasClassType diff --git a/packages/fcl-passrc/src/pscanner.pp b/packages/fcl-passrc/src/pscanner.pp index b64a5b4924..c4491293fb 100644 --- a/packages/fcl-passrc/src/pscanner.pp +++ b/packages/fcl-passrc/src/pscanner.pp @@ -37,12 +37,18 @@ const nLogIFDefRejected = 1010; nLogIFNDefAccepted = 1011; nLogIFNDefRejected = 1012; - nLogIFOPTIgnored = 1013; - nLogIFIgnored = 1014; - nErrInvalidMode = 1015; - nErrInvalidModeSwitch = 1016; - nUserDefined = 1017; - nErrXExpectedButYFound = 1018; + nLogIFAccepted = 1013; + nLogIFRejected = 1014; + nLogIFOPTIgnored = 1015; + nLogIFIgnored = 1016; + nErrInvalidMode = 1017; + nErrInvalidModeSwitch = 1018; + nErrXExpectedButYFound = 1019; + nErrRangeCheck = 1020; + nErrDivByZero = 1021; + nErrOperandAndOperatorMismatch = 1022; + // keep this last: + nUserDefined = 1023; // resourcestring patterns of messages resourcestring @@ -58,12 +64,17 @@ resourcestring SLogIFDefRejected = 'IFDEF %s found, rejecting.'; SLogIFNDefAccepted = 'IFNDEF %s found, accepting.'; SLogIFNDefRejected = 'IFNDEF %s found, rejecting.'; + SLogIFAccepted = 'IF %s found, accepting.'; + SLogIFRejected = 'IF %s found, rejecting.'; SLogIFOPTIgnored = 'IFOPT %s found, ignoring (rejected).'; SLogIFIgnored = 'IF %s found, ignoring (rejected).'; SErrInvalidMode = 'Invalid mode: "%s"'; SErrInvalidModeSwitch = 'Invalid mode switch: "%s"'; SErrUserDefined = 'User defined error: "%s"'; SErrXExpectedButYFound = '"%s" expected, but "%s" found'; + sErrRangeCheck = 'range check failed'; + sErrDivByZero = 'division by zero'; + sErrOperandAndOperatorMismatch = 'operand and operator mismatch'; type TMessageType = ( @@ -376,6 +387,74 @@ type Property Streams: TStringList read FStreams; end; +const + CondDirectiveBool: array[boolean] of string = ( + '0', // false + '1' // true Note: True is <>'0' + ); +type + TCondDirectiveEvaluator = class; + + TCEEvalVarEvent = function(Sender: TCondDirectiveEvaluator; Name: String; out Value: string): boolean of object; + TCEEvalFunctionEvent = function(Sender: TCondDirectiveEvaluator; Name, Param: String; out Value: string): boolean of object; + TCELogEvent = procedure(Sender: TCondDirectiveEvaluator; Args : Array of const) of object; + + { TCondDirectiveEvaluator - evaluate $IF expression } + + TCondDirectiveEvaluator = class + private + FOnEvalFunction: TCEEvalFunctionEvent; + FOnEvalVariable: TCEEvalVarEvent; + FOnLog: TCELogEvent; + protected + type + TPrecedenceLevel = ( + ceplFirst, // tkNot + ceplSecond, // *, /, div, mod, and, shl, shr + ceplThird, // +, -, or, xor + ceplFourth // =, <>, <, >, <=, >= + ); + TStackItem = record + Level: TPrecedenceLevel; + Operathor: TToken; + Operand: String; + OperandPos: integer; + end; + protected + FTokenStart: PChar; + FTokenEnd: PChar; + FToken: TToken; + FStack: array of TStackItem; + FStackTop: integer; + function IsFalse(const Value: String): boolean; inline; + function IsTrue(const Value: String): boolean; inline; + function IsInteger(const Value: String; out i: int64): boolean; + function IsExtended(const Value: String; out e: extended): boolean; + procedure NextToken; + procedure Log(aMsgType: TMessageType; aMsgNumber: integer; + const aMsgFmt: String; const Args: array of const; MsgPos: integer = 0); + procedure LogXExpectedButTokenFound(const X: String; ErrorPos: integer = 0); + procedure ReadOperand(Skip: boolean = false); // unary operators plus one operand + procedure ReadExpression; // binary operators + procedure ResolveStack(MinStackLvl: integer; Level: TPrecedenceLevel; + NewOperator: TToken); + function GetTokenString: String; + function GetStringLiteralValue: String; // read value of tkString + procedure Push(const AnOperand: String; OperandPosition: integer); + public + Expression: String; + MsgPos: integer; + MsgNumber: integer; + MsgType: TMessageType; + MsgPattern: String; // Format parameter + constructor Create; + destructor Destroy; override; + function Eval(const Expr: string): boolean; + property OnEvalVariable: TCEEvalVarEvent read FOnEvalVariable write FOnEvalVariable; + property OnEvalFunction: TCEEvalFunctionEvent read FOnEvalFunction write FOnEvalFunction; + property OnLog: TCELogEvent read FOnLog write FOnLog; + end; + EScannerError = class(Exception); EFileNotFoundError = class(Exception); @@ -411,6 +490,7 @@ type TPascalScanner = class private FAllowedModeSwitches: TModeSwitches; + FConditionEval: TCondDirectiveEvaluator; FCurrentModeSwitches: TModeSwitches; FForceCaret: Boolean; FLastMsg: string; @@ -428,6 +508,8 @@ type FMacros, FDefines: TStrings; FMacrosOn: boolean; + FOnEvalFunction: TCEEvalFunctionEvent; + FOnEvalVariable: TCEEvalVarEvent; FOptions: TPOptions; FLogEvents: TPScannerLogEvents; FOnLog: TPScannerLogHandler; @@ -444,6 +526,12 @@ type PPSkipModeStack: array[0..255] of TPascalScannerPPSkipMode; PPIsSkippingStack: array[0..255] of Boolean; function GetCurColumn: Integer; + function OnCondEvalFunction(Sender: TCondDirectiveEvaluator; Name, + Param: String; out Value: string): boolean; + procedure OnCondEvalLog(Sender: TCondDirectiveEvaluator; + Args: array of const); + function OnCondEvalVar(Sender: TCondDirectiveEvaluator; Name: String; out + Value: string): boolean; procedure SetAllowedModeSwitches(const AValue: TModeSwitches); procedure SetCurrentModeSwitches(AValue: TModeSwitches); procedure SetOptions(AValue: TPOptions); @@ -513,6 +601,9 @@ type property LogEvents : TPScannerLogEvents Read FLogEvents Write FLogEvents; property OnLog : TPScannerLogHandler Read FOnLog Write FOnLog; property MacrosOn: boolean read FMacrosOn write FMacrosOn; + property ConditionEval: TCondDirectiveEvaluator read FConditionEval; + property OnEvalVariable: TCEEvalVarEvent read FOnEvalVariable write FOnEvalVariable; + property OnEvalFunction: TCEEvalFunctionEvent read FOnEvalFunction write FOnEvalFunction; property LastMsg: string read FLastMsg write FLastMsg; property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber; @@ -891,6 +982,743 @@ begin Result:=(TheFilename<>'') and (TheFilename[1]='/'); end; +{ TCondDirectiveEvaluator } + +// inline +function TCondDirectiveEvaluator.IsFalse(const Value: String): boolean; +begin + Result:=Value=CondDirectiveBool[false]; +end; + +// inline +function TCondDirectiveEvaluator.IsTrue(const Value: String): boolean; +begin + Result:=Value<>CondDirectiveBool[false]; +end; + +function TCondDirectiveEvaluator.IsInteger(const Value: String; out i: int64 + ): boolean; +var + Code: integer; +begin + val(Value,i,Code); + Result:=Code=0; +end; + +function TCondDirectiveEvaluator.IsExtended(const Value: String; out e: extended + ): boolean; +var + Code: integer; +begin + val(Value,e,Code); + Result:=Code=0; +end; + +procedure TCondDirectiveEvaluator.NextToken; +const + IdentChars = ['a'..'z','A'..'Z','_','0'..'9']; + + function IsIdentifier(a,b: PChar): boolean; + var + ac: Char; + begin + repeat + ac:=a^; + if (ac in IdentChars) and (upcase(ac)=upcase(b^)) then + begin + inc(a); + inc(b); + end + else + begin + Result:=(not (ac in IdentChars)) and (not (b^ in IdentChars)); + exit; + end; + until false; + end; + + function ReadIdentifier: TToken; + begin + Result:=tkIdentifier; + case FTokenEnd-FTokenStart of + 2: + if IsIdentifier(FTokenStart,'or') then + Result:=tkor; + 3: + if IsIdentifier(FTokenStart,'not') then + Result:=tknot + else if IsIdentifier(FTokenStart,'and') then + Result:=tkand + else if IsIdentifier(FTokenStart,'xor') then + Result:=tkxor + else if IsIdentifier(FTokenStart,'shl') then + Result:=tkshl + else if IsIdentifier(FTokenStart,'shr') then + Result:=tkshr + else if IsIdentifier(FTokenStart,'mod') then + Result:=tkmod + else if IsIdentifier(FTokenStart,'div') then + Result:=tkdiv; + end; + end; + +begin + FTokenStart:=FTokenEnd; + // skip white space + repeat + case FTokenStart^ of + #0: + if FTokenStart-PChar(Expression)>=length(Expression) then + begin + FToken:=tkEOF; + FTokenEnd:=FTokenStart; + exit; + end + else + inc(FTokenStart); + #9,#10,#13,' ': + inc(FTokenStart); + else break; + end; + until false; + // read token + FTokenEnd:=FTokenStart; + case FTokenEnd^ of + 'a'..'z','A'..'Z','_': + begin + inc(FTokenEnd); + while FTokenEnd^ in IdentChars do inc(FTokenEnd); + FToken:=ReadIdentifier; + end; + '0'..'9': + begin + FToken:=tkNumber; + // examples: 1, 1.2, 1.2E3, 1E-2 + inc(FTokenEnd); + while FTokenEnd^ in ['0'..'9'] do inc(FTokenEnd); + if (FTokenEnd^='.') and (FTokenEnd[1]<>'.') then + begin + inc(FTokenEnd); + while FTokenEnd^ in ['0'..'9'] do inc(FTokenEnd); + end; + if FTokenEnd^ in ['e','E'] then + begin + inc(FTokenEnd); + if FTokenEnd^ in ['-','+'] then inc(FTokenEnd); + while FTokenEnd^ in ['0'..'9'] do inc(FTokenEnd); + end; + end; + '$': + begin + FToken:=tkNumber; + while FTokenEnd^ in ['0'..'9','a'..'f','A'..'F'] do inc(FTokenEnd); + end; + '%': + begin + FToken:=tkNumber; + while FTokenEnd^ in ['0','1'] do inc(FTokenEnd); + end; + '(': + begin + FToken:=tkBraceOpen; + inc(FTokenEnd); + end; + ')': + begin + FToken:=tkBraceClose; + inc(FTokenEnd); + end; + '=': + begin + FToken:=tkEqual; + inc(FTokenEnd); + end; + '<': + begin + inc(FTokenEnd); + case FTokenEnd^ of + '=': + begin + FToken:=tkLessEqualThan; + inc(FTokenEnd); + end; + '<': + begin + FToken:=tkshl; + inc(FTokenEnd); + end; + '>': + begin + FToken:=tkNotEqual; + inc(FTokenEnd); + end; + else + FToken:=tkLessThan; + end; + end; + '>': + begin + inc(FTokenEnd); + case FTokenEnd^ of + '=': + begin + FToken:=tkGreaterEqualThan; + inc(FTokenEnd); + end; + '>': + begin + FToken:=tkshr; + inc(FTokenEnd); + end; + else + FToken:=tkGreaterThan; + end; + end; + '+': + begin + FToken:=tkPlus; + inc(FTokenEnd); + end; + '-': + begin + FToken:=tkMinus; + inc(FTokenEnd); + end; + '*': + begin + FToken:=tkMul; + inc(FTokenEnd); + end; + '/': + begin + FToken:=tkDivision; + inc(FTokenEnd); + end; + '''': + begin + FToken:=tkString; + repeat + inc(FTokenEnd); + if FTokenEnd^='''' then + begin + inc(FTokenEnd); + if FTokenEnd^<>'''' then break; + end + else if FTokenEnd^ in [#0,#10,#13] then + Log(mtError,nErrOpenString,SErrOpenString,[]); + until false; + end + else + FToken:=tkEOF; + end; + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.NextToken END Token[',FTokenStart-PChar(Expression)+1,']="',GetTokenString,'" ',FToken); + {$ENDIF} +end; + +procedure TCondDirectiveEvaluator.Log(aMsgType: TMessageType; + aMsgNumber: integer; const aMsgFmt: String; const Args: array of const; + MsgPos: integer); +begin + if MsgPos<1 then + MsgPos:=FTokenEnd-PChar(Expression)+1; + MsgType:=aMsgType; + MsgNumber:=aMsgNumber; + MsgPattern:=aMsgFmt; + if Assigned(OnLog) then + begin + OnLog(Self,Args); + if not (aMsgType in [mtError,mtFatal]) then exit; + end; + raise EScannerError.CreateFmt(MsgPattern+' at '+IntToStr(MsgPos),Args); +end; + +procedure TCondDirectiveEvaluator.LogXExpectedButTokenFound(const X: String; + ErrorPos: integer); +begin + Log(mtError,nErrXExpectedButYFound,SErrXExpectedButYFound, + [X,TokenInfos[FToken]],ErrorPos); +end; + +procedure TCondDirectiveEvaluator.ReadOperand(Skip: boolean); +{ Read operand and put it on the stack + Examples: + Variable + not Variable + not not undefined Variable + defined(Variable) + !Variable + unicodestring + 123 + $45 + 'Abc' + (expression) +} +var + i: Int64; + e: extended; + S, aName, Param: String; + Code: integer; + NameStartP: PChar; + p, Lvl: integer; +begin + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.ReadOperand START Token[',FTokenStart-PChar(Expression)+1,']="',GetTokenString,'" ',FToken,BoolToStr(Skip,' SKIP','')); + {$ENDIF} + case FToken of + tknot: + begin + // boolean not + NextToken; + ReadOperand(Skip); + if not Skip then + FStack[FStackTop].Operand:=CondDirectiveBool[IsFalse(FStack[FStackTop].Operand)]; + end; + tkMinus: + begin + // unary minus + NextToken; + ReadOperand(Skip); + if not Skip then + begin + i:=StrToInt64Def(FStack[FStackTop].Operand,0); + FStack[FStackTop].Operand:=IntToStr(-i); + end; + end; + tkPlus: + begin + // unary plus + NextToken; + ReadOperand(Skip); + if not Skip then + begin + i:=StrToInt64Def(FStack[FStackTop].Operand,0); + FStack[FStackTop].Operand:=IntToStr(i); + end; + end; + tkNumber: + begin + // number: convert to decimal + if not Skip then + begin + S:=GetTokenString; + val(S,i,Code); + if Code=0 then + begin + // integer + Push(IntToStr(i),FTokenStart-PChar(Expression)+1); + end + else + begin + val(S,e,Code); + if Code>0 then + Log(mtError,nErrRangeCheck,sErrRangeCheck,[]); + if e=0 then ; + // float + Push(S,FTokenStart-PChar(Expression)+1); + end; + end; + NextToken; + end; + tkString: + begin + // string literal + if not Skip then + Push(GetStringLiteralValue,FTokenStart-PChar(Expression)+1); + NextToken; + end; + tkIdentifier: + if Skip then + begin + NextToken; + if FToken=tkBraceOpen then + begin + // only one parameter is supported + NextToken; + if FToken=tkIdentifier then + NextToken; + if FToken<>tkBraceClose then + LogXExpectedButTokenFound(')'); + NextToken; + end; + end + else + begin + aName:=GetTokenString; + p:=FTokenStart-PChar(Expression)+1; + NextToken; + if FToken=tkBraceOpen then + begin + // function + NameStartP:=FTokenStart; + NextToken; + // only one parameter is supported + Param:=''; + if FToken=tkIdentifier then + begin + Param:=GetTokenString; + NextToken; + end; + if FToken<>tkBraceClose then + LogXExpectedButTokenFound(')'); + if not OnEvalFunction(Self,aName,Param,S) then + begin + FTokenStart:=NameStartP; + FTokenEnd:=FTokenStart+length(aName); + LogXExpectedButTokenFound('function'); + end; + Push(S,p); + NextToken; + end + else + begin + // variable + if OnEvalVariable(Self,aName,S) then + Push(S,p) + else + begin + // variable does not exist -> evaluates to false + Push(CondDirectiveBool[false],p); + end; + end; + end; + tkBraceOpen: + begin + NextToken; + if Skip then + begin + Lvl:=1; + repeat + case FToken of + tkEOF: + LogXExpectedButTokenFound(')'); + tkBraceOpen: inc(Lvl); + tkBraceClose: + begin + dec(Lvl); + if Lvl=0 then break; + end; + end; + NextToken; + until false; + end + else + begin + ReadExpression; + if FToken<>tkBraceClose then + LogXExpectedButTokenFound(')'); + end; + NextToken; + end; + else + LogXExpectedButTokenFound('identifier'); + end; + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.ReadOperand END Top=',FStackTop,' Value="',FStack[FStackTop].Operand,'" Token[',FTokenStart-PChar(Expression)+1,']="',GetTokenString,'" ',FToken); + {$ENDIF} +end; + +procedure TCondDirectiveEvaluator.ReadExpression; +// read operand operator operand ... til tkEOF or tkBraceClose +var + OldStackTop: Integer; + + procedure ReadBinary(Level: TPrecedenceLevel; NewOperator: TToken); + begin + ResolveStack(OldStackTop,Level,NewOperator); + NextToken; + ReadOperand; + end; + +begin + OldStackTop:=FStackTop; + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.ReadExpression START Top=',FStackTop,' Token[',FTokenStart-PChar(Expression)+1,']="',GetTokenString,'" ',FToken); + {$ENDIF} + ReadOperand; + repeat + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.ReadExpression NEXT Top=',FStackTop,' Token[',FTokenStart-PChar(Expression)+1,']="',GetTokenString,'" ',FToken); + {$ENDIF} + case FToken of + tkEOF,tkBraceClose: + begin + ResolveStack(OldStackTop,high(TPrecedenceLevel),tkEOF); + exit; + end; + tkand: + begin + ResolveStack(OldStackTop,ceplSecond,tkand); + NextToken; + if (FStackTop=OldStackTop+1) and IsFalse(FStack[FStackTop].Operand) then + begin + // false and ... + // -> skip all "and" + repeat + ReadOperand(true); + if FToken<>tkand then break; + NextToken; + until false; + FStack[FStackTop].Operathor:=tkEOF; + end + else + ReadOperand; + end; + tkMul,tkDivision,tkdiv,tkmod,tkshl,tkshr: + ReadBinary(ceplSecond,FToken); + tkor: + begin + ResolveStack(OldStackTop,ceplThird,tkor); + NextToken; + if (FStackTop=OldStackTop+1) and IsTrue(FStack[FStackTop].Operand) then + begin + // true or ... + // -> skip all "and" and "or" + repeat + ReadOperand(true); + if not (FToken in [tkand,tkor]) then break; + NextToken; + until false; + FStack[FStackTop].Operathor:=tkEOF; + end + else + ReadOperand; + end; + tkPlus,tkMinus,tkxor: + ReadBinary(ceplThird,FToken); + tkEqual,tkNotEqual,tkLessThan,tkGreaterThan,tkLessEqualThan,tkGreaterEqualThan: + ReadBinary(ceplFourth,FToken); + else + LogXExpectedButTokenFound('operator'); + end; + until false; + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.ReadExpression END Top=',FStackTop,' Value="',FStack[FStackTop].Operand,'" Token[',FTokenStart-PChar(Expression)+1,']=',GetTokenString,' ',FToken); + {$ENDIF} +end; + +procedure TCondDirectiveEvaluator.ResolveStack(MinStackLvl: integer; + Level: TPrecedenceLevel; NewOperator: TToken); +var + A, B, R: String; + Op: TToken; + AInt, BInt: int64; + AFloat, BFloat: extended; + BPos: Integer; +begin + // resolve all higher or equal level operations + // Note: the stack top contains operand B + // the stack second contains operand A and the operator between A and B + + //writeln('TCondDirectiveEvaluator.ResolveStack FStackTop=',FStackTop,' MinStackLvl=',MinStackLvl); + //if FStackTop>MinStackLvl+1 then + // writeln(' FStack[FStackTop-1].Level=',FStack[FStackTop-1].Level,' Level=',Level); + while (FStackTop>MinStackLvl+1) and (FStack[FStackTop-1].Level<=Level) do + begin + // pop last operand and operator from stack + B:=FStack[FStackTop].Operand; + BPos:=FStack[FStackTop].OperandPos; + dec(FStackTop); + Op:=FStack[FStackTop].Operathor; + A:=FStack[FStackTop].Operand; + {$IFDEF VerbosePasDirectiveEval} + writeln(' ResolveStack Top=',FStackTop,' A="',A,'" ',Op,' B="',B,'"'); + {$ENDIF} + {$IFOPT R+}{$DEFINE RangeChecking}{$ENDIF} + {$R+} + try + case Op of + tkand: // boolean and + R:=CondDirectiveBool[IsTrue(A) and IsTrue(B)]; + tkor: // boolean or + R:=CondDirectiveBool[IsTrue(A) or IsTrue(B)]; + tkxor: // boolean xor + R:=CondDirectiveBool[IsTrue(A) xor IsTrue(B)]; + tkMul, tkdiv, tkmod, tkshl, tkshr, tkPlus, tkMinus: + if IsInteger(A,AInt) then + begin + if IsInteger(B,BInt) then + case Op of + tkMul: R:=IntToStr(AInt*BInt); + tkdiv: R:=IntToStr(AInt div BInt); + tkmod: R:=IntToStr(AInt mod BInt); + tkshl: R:=IntToStr(AInt shl BInt); + tkshr: R:=IntToStr(AInt shr BInt); + tkPlus: R:=IntToStr(AInt+BInt); + tkMinus: R:=IntToStr(AInt-BInt); + end + else if IsExtended(B,BFloat) then + case Op of + tkMul: R:=FloatToStr(Extended(AInt)*BFloat); + tkPlus: R:=FloatToStr(Extended(AInt)+BFloat); + tkMinus: R:=FloatToStr(Extended(AInt)-BFloat); + else + LogXExpectedButTokenFound('integer',BPos); + end + else + LogXExpectedButTokenFound('integer',BPos); + end + else if IsExtended(A,AFloat) then + begin + if IsExtended(B,BFloat) then + case Op of + tkMul: R:=FloatToStr(AFloat*BFloat); + tkPlus: R:=FloatToStr(AFloat+BFloat); + tkMinus: R:=FloatToStr(AFloat-BFloat); + else + LogXExpectedButTokenFound('float',BPos); + end + else + LogXExpectedButTokenFound('float',BPos); + end + else + Log(mtError,nErrOperandAndOperatorMismatch,sErrOperandAndOperatorMismatch,[]); + tkDivision: + if IsExtended(A,AFloat) then + begin + if IsExtended(B,BFloat) then + R:=FloatToStr(AFloat/BFloat) + else + LogXExpectedButTokenFound('float',BPos); + end + else + Log(mtError,nErrOperandAndOperatorMismatch,sErrOperandAndOperatorMismatch,[]); + tkEqual, + tkNotEqual, + tkLessThan,tkGreaterThan, + tkLessEqualThan,tkGreaterEqualThan: + begin + if IsInteger(A,AInt) and IsInteger(B,BInt) then + case Op of + tkEqual: R:=CondDirectiveBool[AInt=BInt]; + tkNotEqual: R:=CondDirectiveBool[AInt<>BInt]; + tkLessThan: R:=CondDirectiveBool[AIntBInt]; + tkLessEqualThan: R:=CondDirectiveBool[AInt<=BInt]; + tkGreaterEqualThan: R:=CondDirectiveBool[AInt>=BInt]; + end + else if IsExtended(A,AFloat) and IsExtended(B,BFloat) then + case Op of + tkEqual: R:=CondDirectiveBool[AFloat=BFloat]; + tkNotEqual: R:=CondDirectiveBool[AFloat<>BFloat]; + tkLessThan: R:=CondDirectiveBool[AFloatBFloat]; + tkLessEqualThan: R:=CondDirectiveBool[AFloat<=BFloat]; + tkGreaterEqualThan: R:=CondDirectiveBool[AFloat>=BFloat]; + end + else + case Op of + tkEqual: R:=CondDirectiveBool[A=B]; + tkNotEqual: R:=CondDirectiveBool[A<>B]; + tkLessThan: R:=CondDirectiveBool[AB]; + tkLessEqualThan: R:=CondDirectiveBool[A<=B]; + tkGreaterEqualThan: R:=CondDirectiveBool[A>=B]; + end; + end; + else + Log(mtError,nErrOperandAndOperatorMismatch,sErrOperandAndOperatorMismatch,[]); + end; + except + on E: EDivByZero do + Log(mtError,nErrDivByZero,sErrDivByZero,[]); + on E: EZeroDivide do + Log(mtError,nErrDivByZero,sErrDivByZero,[]); + on E: EMathError do + Log(mtError,nErrRangeCheck,sErrRangeCheck+' '+E.Message,[]); + on E: EInterror do + Log(mtError,nErrRangeCheck,sErrRangeCheck+' '+E.Message,[]); + end; + {$IFNDEF RangeChecking}{$R-}{$UNDEF RangeChecking}{$ENDIF} + {$IFDEF VerbosePasDirectiveEval} + writeln(' ResolveStack Top=',FStackTop,' A="',A,'" ',Op,' B="',B,'" = "',R,'"'); + {$ENDIF} + FStack[FStackTop].Operand:=R; + FStack[FStackTop].OperandPos:=BPos; + end; + FStack[FStackTop].Operathor:=NewOperator; + FStack[FStackTop].Level:=Level; +end; + +function TCondDirectiveEvaluator.GetTokenString: String; +begin + Result:=copy(Expression,FTokenStart-PChar(Expression)+1,FTokenEnd-FTokenStart); +end; + +function TCondDirectiveEvaluator.GetStringLiteralValue: String; +var + p, StartP: PChar; +begin + Result:=''; + p:=FTokenStart; + repeat + case p^ of + '''': + begin + inc(p); + StartP:=p; + repeat + case p^ of + #0: Log(mtError,nErrInvalidCharacter,SErrInvalidCharacter,['#0']); + '''': break; + end; + until false; + if p>StartP then + Result:=Result+copy(Expression,StartP-PChar(Expression)+1,p-StartP); + inc(p); + end; + else + Log(mtError,nErrInvalidCharacter,SErrInvalidCharacter,['#0']); + end; + until false; +end; + +procedure TCondDirectiveEvaluator.Push(const AnOperand: String; + OperandPosition: integer); +begin + inc(FStackTop); + if FStackTop>=length(FStack) then + SetLength(FStack,length(FStack)*2+4); + with FStack[FStackTop] do + begin + Operand:=AnOperand; + OperandPos:=OperandPosition; + Operathor:=tkEOF; + Level:=ceplFourth; + end; + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.Push Top=',FStackTop,' Operand="',AnOperand,'" Pos=',OperandPosition); + {$ENDIF} +end; + +constructor TCondDirectiveEvaluator.Create; +begin + +end; + +destructor TCondDirectiveEvaluator.Destroy; +begin + inherited Destroy; +end; + +function TCondDirectiveEvaluator.Eval(const Expr: string): boolean; +begin + {$IFDEF VerbosePasDirectiveEval} + writeln('TCondDirectiveEvaluator.Eval Expr="',Expr,'"'); + {$ENDIF} + Expression:=Expr; + MsgType:=mtInfo; + MsgNumber:=0; + MsgPattern:=''; + if Expr='' then exit(false); + FTokenStart:=PChar(Expr); + FTokenEnd:=FTokenStart; + FStackTop:=-1; + NextToken; + ReadExpression; + Result:=IsTrue(FStack[0].Operand); +end; + { TMacroDef } constructor TMacroDef.Create(const AName, AValue: String); @@ -1258,10 +2086,15 @@ begin FMacros:=CS; FCurrentModeSwitches:=FPCModeSwitches; FAllowedModeSwitches:=msAllFPCModeSwitches; + FConditionEval:=TCondDirectiveEvaluator.Create; + FConditionEval.OnLog:=@OnCondEvalLog; + FConditionEval.OnEvalVariable:=@OnCondEvalVar; + FConditionEval.OnEvalFunction:=@OnCondEvalFunction; end; destructor TPascalScanner.Destroy; begin + FreeAndNil(FConditionEval); ClearMacros; FreeAndNil(FMacros); FreeAndNil(FDefines); @@ -1445,14 +2278,14 @@ end; procedure TPascalScanner.Error(MsgNumber: integer; const Msg: string); begin SetCurMsg(mtError,MsgNumber,Msg,[]); - raise EScannerError.Create(Msg); + raise EScannerError.Create(FLastMsg); end; procedure TPascalScanner.Error(MsgNumber: integer; const Fmt: string; Args: array of const); begin SetCurMsg(mtError,MsgNumber,Fmt,Args); - raise EScannerError.CreateFmt(Fmt, Args); + raise EScannerError.Create(FLastMsg); end; function TPascalScanner.DoFetchTextToken:TToken; @@ -1790,12 +2623,18 @@ begin PPSkipMode := ppSkipAll else begin - { !!!: Currently, expressions are not supported, so they are - just assumed as evaluating to false. } - PPSkipMode := ppSkipIfBranch; - PPIsSkipping := true; + if ConditionEval.Eval(AParam) then + PPSkipMode := ppSkipElseBranch + else + begin + PPSkipMode := ppSkipIfBranch; + PPIsSkipping := true; + end; If LogEvent(sleConditionals) then - DoLog(mtInfo,nLogIFIgnored,sLogIFIgnored,[Uppercase(AParam)]) + if PPSkipMode=ppSkipElseBranch then + DoLog(mtInfo,nLogIFAccepted,sLogIFAccepted,[AParam]) + else + DoLog(mtInfo,nLogIFRejected,sLogIFRejected,[AParam]) end; end; @@ -2328,6 +3167,87 @@ begin Result := 0; end; +function TPascalScanner.OnCondEvalFunction(Sender: TCondDirectiveEvaluator; + Name, Param: String; out Value: string): boolean; +begin + {$IFDEF VerbosePasDirectiveEval} + writeln('TPascalScanner.OnCondEvalFunction Func="',Name,'" Param="',Param,'"'); + {$ENDIF} + if CompareText(Name,'defined')=0 then + begin + if not IsValidIdent(Param) then + Sender.Log(mtError,nErrXExpectedButYFound,SErrXExpectedButYFound, + ['identifier',Param]); + Value:=CondDirectiveBool[IsDefined(Param)]; + exit(true); + end; + if CompareText(Name,'undefined')=0 then + begin + if not IsValidIdent(Param) then + Sender.Log(mtError,nErrXExpectedButYFound,SErrXExpectedButYFound, + ['identifier',Param]); + Value:=CondDirectiveBool[not IsDefined(Param)]; + exit(true); + end; + // last check user hook + if Assigned(OnEvalFunction) then + begin + Result:=OnEvalFunction(Sender,Name,Param,Value); + exit; + end; + Value:=''; + Result:=false; +end; + +procedure TPascalScanner.OnCondEvalLog(Sender: TCondDirectiveEvaluator; + Args: array of const); +begin + {$IFDEF VerbosePasDirectiveEval} + writeln('TPascalScanner.OnCondEvalLog "',Sender.MsgPattern,'"'); + {$ENDIF} + // ToDo: move CurLine/CurRow to Sender.MsgPos + if Sender.MsgType<=mtError then + begin + SetCurMsg(Sender.MsgType,Sender.MsgNumber,Sender.MsgPattern,Args); + raise EScannerError.Create(FLastMsg); + end + else + DoLog(Sender.MsgType,Sender.MsgNumber,Sender.MsgPattern,Args,true); +end; + +function TPascalScanner.OnCondEvalVar(Sender: TCondDirectiveEvaluator; + Name: String; out Value: string): boolean; +var + i: Integer; + M: TMacroDef; +begin + {$IFDEF VerbosePasDirectiveEval} + writeln('TPascalScanner.OnCondEvalVar "',Name,'"'); + {$ENDIF} + // first check defines + if FDefines.IndexOf(Name)>=0 then + begin + Value:='1'; + exit(true); + end; + // then check macros + i:=FMacros.IndexOf(Name); + if i>=0 then + begin + M:=FMacros.Objects[i] as TMacroDef; + Value:=M.Value; + exit(true); + end; + // last check user hook + if Assigned(OnEvalVariable) then + begin + Result:=OnEvalVariable(Sender,Name,Value); + exit; + end; + Value:=''; + Result:=false; +end; + procedure TPascalScanner.SetAllowedModeSwitches(const AValue: TModeSwitches); begin if FAllowedModeSwitches=AValue then Exit; diff --git a/packages/fcl-passrc/tests/tcscanner.pas b/packages/fcl-passrc/tests/tcscanner.pas index fc013cea89..6999009192 100644 --- a/packages/fcl-passrc/tests/tcscanner.pas +++ b/packages/fcl-passrc/tests/tcscanner.pas @@ -224,6 +224,20 @@ type procedure TestMacro2; procedure TestMacro3; procedure TestMacroHandling; + procedure TestIFDefined; + procedure TestIFUnDefined; + procedure TestIFAnd; + procedure TestIFAndShortEval; + procedure TestIFOr; + procedure TestIFOrShortEval; + procedure TestIFXor; + procedure TestIFAndOr; + procedure TestIFEqual; + procedure TestIFNotEqual; + procedure TestIFGreaterThan; + procedure TestIFGreaterEqualThan; + procedure TestIFLesserThan; + procedure TestIFLesserEqualThan; Procedure TestModeSwitch; end; @@ -1511,24 +1525,21 @@ procedure TTestScanner.TestMacro1; begin FScanner.SkipWhiteSpace:=True; FScanner.SkipComments:=True; - FScanner.MacrosOn:=true; - TestTokens([tkbegin,tkend,tkDot],'{$DEFINE MM:=begin end.}'#13#10'MM',True,False); + TestTokens([tkbegin,tkend,tkDot],'{$MACRO on}{$DEFINE MM:=begin end.}'#13#10'MM',True,False); end; procedure TTestScanner.TestMacro2; begin FScanner.SkipWhiteSpace:=True; FScanner.SkipComments:=True; - FScanner.MacrosOn:=true; - TestTokens([tkbegin,tkend,tkDot],'{$DEFINE MM:=begin end}'#13#10'MM .',True,False); + TestTokens([tkbegin,tkend,tkDot],'{$MACRO on}{$DEFINE MM:=begin end}'#13#10'MM .',True,False); end; procedure TTestScanner.TestMacro3; begin FScanner.SkipComments:=True; FScanner.SkipWhiteSpace:=True; - FScanner.MacrosOn:=true; - TestTokens([tkof],'{$DEFINE MM:=begin end}'#13#10'{$IFDEF MM} of {$ELSE} in {$ENDIF}'); + TestTokens([tkof],'{$MACRO on}{$DEFINE MM:=begin end}'#13#10'{$IFDEF MM} of {$ELSE} in {$ENDIF}'); end; procedure TTestScanner.TestMacroHandling; @@ -1536,11 +1547,135 @@ begin TTestingPascalScanner(FScanner).DoSpecial:=True; FScanner.SkipComments:=True; FScanner.SkipWhiteSpace:=True; - FScanner.MacrosOn:=true; - TestTokens([tkIdentifier],'{$DEFINE MM:=begin end}'#13#10'MM'); + TestTokens([tkIdentifier],'{$MACRO on}{$DEFINE MM:=begin end}'#13#10'MM'); AssertEQuals('Correct identifier', 'somethingweird',LastIdentifier); end; +procedure TTestScanner.TestIFDefined; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot],'{$DEFINE A}{$IF defined(A)}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFUnDefined; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot],'{$IF undefined(A)}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFAnd; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot], + '{$DEFINE A}{$IF defined(A) and undefined(B)}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFAndShortEval; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot], + '{$UNDEFINE A}{$IF defined(A) and undefined(B)}wrong{$ELSE}begin{$ENDIF}end.', + True,False); +end; + +procedure TTestScanner.TestIFOr; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot], + '{$DEFINE B}{$IF defined(A) or defined(B)}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFOrShortEval; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot], + '{$DEFINE A}{$IF defined(A) or defined(B)}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFXor; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot], + '{$DEFINE B}{$IF defined(A) xor defined(B)}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFAndOr; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + TestTokens([tkbegin,tkend,tkDot], + '{$IF defined(A) and defined(B) or defined(C)}wrong1{$ENDIF}'+LineEnding + +'{$IF defined(A) and defined(B) or undefined(C)}{$ELSE}wrong2{$ENDIF}'+LineEnding + +'{$IF defined(A) and undefined(B) or defined(C)}wrong3{$ENDIF}'+LineEnding + +'{$IF defined(A) and undefined(B) or undefined(C)}{$ELSE}wrong4{$ENDIF}'+LineEnding + +'{$IF undefined(A) and defined(B) or defined(C)}wrong5{$ENDIF}'+LineEnding + +'{$IF undefined(A) and defined(B) or undefined(C)}{$ELSE}wrong6{$ENDIF}'+LineEnding + +'{$IF undefined(A) and undefined(B) or defined(C)}{$ELSE}wrong7{$ENDIF}'+LineEnding + +'{$IF undefined(A) and undefined(B) or undefined(C)}begin{$ENDIF}end.', + True,False); +end; + +procedure TTestScanner.TestIFEqual; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddMacro('Version','30101'); + TestTokens([tkbegin,tkend,tkDot], + '{$IF Version=30101}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFNotEqual; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddMacro('Version','30101'); + TestTokens([tkbegin,tkend,tkDot], + '{$IF Version<>30000}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFGreaterThan; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddMacro('Version','30101'); + TestTokens([tkbegin,tkend,tkDot], + '{$IF Version>30000}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFGreaterEqualThan; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddMacro('Version','30101'); + TestTokens([tkbegin,tkend,tkDot], + '{$IF Version>=30000}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFLesserThan; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddMacro('Version','30101'); + TestTokens([tkbegin,tkend,tkDot], + '{$IF Version<40000}begin{$ENDIF}end.',True,False); +end; + +procedure TTestScanner.TestIFLesserEqualThan; +begin + FScanner.SkipWhiteSpace:=True; + FScanner.SkipComments:=True; + FScanner.AddMacro('Version','30101'); + TestTokens([tkbegin,tkend,tkDot], + '{$IF Version<=30101}begin{$ENDIF}end.',True,False); +end; + procedure TTestScanner.TestModeSwitch; Const