diff --git a/.gitattributes b/.gitattributes index 576bc039c5..ea6a7ddedf 100644 --- a/.gitattributes +++ b/.gitattributes @@ -2575,6 +2575,7 @@ packages/fcl-passrc/examples/parsepp.pp svneol=native#text/plain packages/fcl-passrc/examples/test_parser.pp svneol=native#text/plain packages/fcl-passrc/examples/testunit1.pp svneol=native#text/plain packages/fcl-passrc/fpmake.pp svneol=native#text/plain +packages/fcl-passrc/src/pasresolveeval.pas svneol=native#text/plain packages/fcl-passrc/src/pasresolver.pp svneol=native#text/plain packages/fcl-passrc/src/passrcutil.pp svneol=native#text/plain packages/fcl-passrc/src/pastounittest.pp svneol=native#text/plain diff --git a/packages/fcl-passrc/src/pasresolveeval.pas b/packages/fcl-passrc/src/pasresolveeval.pas new file mode 100644 index 0000000000..2e3ae67ddd --- /dev/null +++ b/packages/fcl-passrc/src/pasresolveeval.pas @@ -0,0 +1,1765 @@ +unit PasResolveEval; + +{$mode objfpc}{$H+} + +{$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF} + +interface + +uses + PasTree, PScanner, sysutils; + +// message numbers +const + nIdentifierNotFound = 3001; + nNotYetImplemented = 3002; + nIllegalQualifier = 3003; + nSyntaxErrorExpectedButFound = 3004; + nWrongNumberOfParametersForCallTo = 3005; + nIncompatibleTypeArgNo = 3006; + nIncompatibleTypeArgNoVarParamMustMatchExactly = 3007; + nVariableIdentifierExpected = 3008; + nDuplicateIdentifier = 3009; + nXExpectedButYFound = 3010; + nAncestorCycleDetected = 3011; + nCantUseForwardDeclarationAsAncestor = 3012; + nCantDetermineWhichOverloadedFunctionToCall = 3013; + nForwardTypeNotResolved = 3014; + nForwardProcNotResolved = 3015; + nInvalidXModifierY = 3016; + nAbstractMethodsMustNotHaveImplementation = 3017; + nCallingConventionMismatch = 3018; + nResultTypeMismatchExpectedButFound = 3019; + nFunctionHeaderMismatchForwardVarName = 3020; + nFunctionHidesIdentifier = 3021; + nNoMethodInAncestorToOverride = 3022; + nInheritedOnlyWorksInMethods = 3023; + nInheritedNeedsAncestor = 3024; + nNoPropertyFoundToOverride = 3025; + nExprTypeMustBeClassOrRecordTypeGot = 3026; + nPropertyNotWritable = 3027; + nIncompatibleTypesGotExpected = 3028; + nTypesAreNotRelated = 3029; + nAbstractMethodsCannotBeCalledDirectly = 3030; + nMissingParameterX = 3031; + nCannotAccessThisMemberFromAX = 3032; + nInOperatorExpectsSetElementButGot = 3033; + nWrongNumberOfParametersForTypeCast = 3034; + nIllegalTypeConversionTo = 3035; + nConstantExpressionExpected = 3036; + nLeftSideOfIsOperatorExpectsAClassButGot = 3037; + nNotReadable = 3038; + nClassPropertyAccessorMustBeStatic = 3039; + nClassPropertyAccessorMustNotBeStatic = 3040; + nOnlyOneDefaultPropertyIsAllowed = 3041; + nWrongNumberOfParametersForArray = 3042; + nCantAssignValuesToAnAddress = 3043; + nIllegalExpression = 3044; + nCantAccessPrivateMember = 3045; + nMustBeInsideALoop = 3046; + nExpectXArrayElementsButFoundY = 3047; + nCannotCreateADescendantOfTheSealedClass = 3048; + nAncestorIsNotExternal = 3049; + nVirtualMethodXHasLowerVisibility = 3050; // FPC 3250 + nExternalClassInstanceCannotAccessStaticX = 3051; + nXModifierMismatchY = 3052; + nSymbolCannotBePublished = 3053; + nCannotTypecastAType = 3054; + nTypeIdentifierExpected = 3055; + nCannotNestAnonymousX = 3056; + nFoundCallCandidateX = 3057; + nSymbolXIsNotPortable = 3058; + nSymbolXIsExperimental = 3059; + nSymbolXIsNotImplemented = 3060; + nSymbolXBelongsToALibrary = 3061; + nSymbolXIsDeprecated = 3062; + nSymbolXIsDeprecatedY = 3063; + nRangeCheckError = 3064; + nHighRangeLimitLTLowRangeLimit = 3065; + nRangeCheckEvaluatingConstantsVMinMax = 3066; + nIllegalChar = 3067; + nOverflowInArithmeticOperation = 3068; + +// resourcestring patterns of messages +resourcestring + sIdentifierNotFound = 'identifier not found "%s"'; + sNotYetImplemented = 'not yet implemented: %s'; + sIllegalQualifier = 'illegal qualifier "%s"'; + sSyntaxErrorExpectedButFound = 'Syntax error, "%s" expected but "%s" found'; + sWrongNumberOfParametersForCallTo = 'Wrong number of parameters specified for call to "%s"'; + sIncompatibleTypeArgNo = 'Incompatible type arg no. %s: Got "%s", expected "%s"'; + sIncompatibleTypeArgNoVarParamMustMatchExactly = 'Incompatible type arg no. %s: Got "%s", expected "%s". Var param must match exactly.'; + sVariableIdentifierExpected = 'Variable identifier expected'; + sDuplicateIdentifier = 'Duplicate identifier "%s" at %s'; + sXExpectedButYFound = '%s expected, but %s found'; + sAncestorCycleDetected = 'Ancestor cycle detected'; + sCantUseForwardDeclarationAsAncestor = 'Can''t use forward declaration "%s" as ancestor'; + sCantDetermineWhichOverloadedFunctionToCall = 'Can''t determine which overloaded function to call'; + sForwardTypeNotResolved = 'Forward type not resolved "%s"'; + sForwardProcNotResolved = 'Forward %s not resolved "%s"'; + sInvalidXModifierY = 'Invalid %s modifier %s'; + sAbstractMethodsMustNotHaveImplementation = 'Abstract method must not have an implementation.'; + sCallingConventionMismatch = 'Calling convention mismatch'; + sResultTypeMismatchExpectedButFound = 'Result type mismatch, expected %s, but found %s'; + sFunctionHeaderMismatchForwardVarName = 'function header "%s" doesn''t match forward : var name changes %s => %s'; + sFunctionHidesIdentifier = 'function hides identifier "%s" at "%s"'; + sNoMethodInAncestorToOverride = 'There is no method in an ancestor class to be overridden "%s"'; + sInheritedOnlyWorksInMethods = 'Inherited works only in methods'; + sInheritedNeedsAncestor = 'inherited needs an ancestor'; + sNoPropertyFoundToOverride = 'No property found to override'; + sExprTypeMustBeClassOrRecordTypeGot = 'Expression type must be class or record type, got %s'; + sPropertyNotWritable = 'No member is provided to access property'; + sIncompatibleTypesGotExpected = 'Incompatible types: got "%s" expected "%s"'; + sTypesAreNotRelated = 'Types are not related'; + sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly'; + sMissingParameterX = 'Missing parameter %s'; + sCannotAccessThisMemberFromAX = 'Cannot access this member from a %s'; + sInOperatorExpectsSetElementButGot = 'the in-operator expects a set element, but got %s'; + sWrongNumberOfParametersForTypeCast = 'wrong number of parameters for type cast to %s'; + sIllegalTypeConversionTo = 'Illegal type conversion: "%s" to "%s"'; + sConstantExpressionExpected = 'Constant expression expected'; + sLeftSideOfIsOperatorExpectsAClassButGot = 'left side of is-operator expects a class, but got %s'; + sNotReadable = 'not readable'; + sClassPropertyAccessorMustBeStatic = 'class property accessor must be static'; + sClassPropertyAccessorMustNotBeStatic = 'class property accessor must not be static'; + sOnlyOneDefaultPropertyIsAllowed = 'Only one default property is allowed'; + sWrongNumberOfParametersForArray = 'Wrong number of parameters for array'; + sCantAssignValuesToAnAddress = 'Can''t assign values to an address'; + sIllegalExpression = 'Illegal expression'; + sCantAccessPrivateMember = 'Can''t access %s member %s'; + sMustBeInsideALoop = '%s must be inside a loop'; + sExpectXArrayElementsButFoundY = 'Expect %s array elements, but found %s'; + sCannotCreateADescendantOfTheSealedClass = 'Cannot create a descendant of the sealed class "%s"'; + sAncestorIsNotExternal = 'Ancestor "%s" is not external'; + sVirtualMethodXHasLowerVisibility = 'Virtual method "%s" has a lower visibility (%s) than parent class %s (%s)'; + sExternalClassInstanceCannotAccessStaticX = 'External class instance cannot access static %s'; + sXModifierMismatchY = '%s modifier "%s" mismatch'; + sSymbolCannotBePublished = 'Symbol cannot be published'; + sCannotTypecastAType = 'Cannot type cast a type'; + sTypeIdentifierExpected = 'Type identifier expected'; + sCannotNestAnonymousX = 'Cannot nest anonymous %s'; + sFoundCallCandidateX = 'Found call candidate %s'; + sSymbolXIsNotPortable = 'Symbol "%s" is not portable'; + sSymbolXIsExperimental = 'Symbol "%s" is experimental'; + sSymbolXIsNotImplemented = 'Symbol "%s" is implemented'; + sSymbolXBelongsToALibrary = 'Symbol "%s" belongs to a library'; + sSymbolXIsDeprecated = 'Symbol "%s" is deprecated'; + sSymbolXIsDeprecatedY = 'Symbol "%s" is deprecated: %s'; + sRangeCheckError = 'Range check error'; + sHighRangeLimitLTLowRangeLimit = 'High range limit < low range limit'; + sRangeCheckEvaluatingConstantsVMinMax = 'range check error while evaluating constants (%s must be between %s and %s)'; + sIllegalChar = 'Illegal character'; + sOverflowInArithmeticOperation = 'Overflow in arithmetic operation'; + +type + { TResolveData - base class for data stored in TPasElement.CustomData } + + TResolveData = Class(TPasElementBase) + private + FElement: TPasElement; + procedure SetElement(AValue: TPasElement); + public + Owner: TObject; // e.g. a TPasResolver + Next: TResolveData; // TPasResolver uses this for its memory chain + constructor Create; virtual; + destructor Destroy; override; + property Element: TPasElement read FElement write SetElement;// Element.CustomData=Self + end; + TResolveDataClass = class of TResolveData; + +type + { TResEvalValue } + + TREVKind = ( + revkNone, + revkCustom, + revkNil, // TResEvalValue + revkBool, // TResEvalInt + revkInt, // TResEvalInt + revkUInt, // TResEvalUInt + revkFloat, // TResEvalFloat + revkString, // TResEvalString + revkUnicodeString, // TResEvalUTF16 + revkEnum, // TResEvalEnum + revkRangeInt, // range of enum, int, char, widechar, e.g. 1..2 + revkRangeUInt, // range of uint, e.g. 1..2 + revkSetEmpty, // [] + revkSetOfInt // set of enum, int, char, widechar, e.g. [1,2..3] + ); + TResEvalValue = class(TResolveData) + public + Kind: TREVKind; + IdentEl: TPasElement; + function Clone: TResEvalValue; virtual; + function AsDebugString: string; virtual; + function AsString: string; virtual; + end; + TResEvalValueClass = class of TResEvalValue; + + { TResEvalInt } + + TResEvalInt = class(TResEvalValue) + public + Int: NativeInt; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + end; + + { TResEvalUInt } + + TResEvalUInt = class(TResEvalValue) + public + UInt: NativeUInt; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + end; + + { TResEvalFloat } + + TResEvalFloat = class(TResEvalValue) + public + FloatValue: extended; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + end; + + { TResEvalString - Kind=revkString } + + TResEvalString = class(TResEvalValue) + public + S: RawByteString; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + end; + + { TResEvalUTF16 - Kind=revkUnicodeString } + + TResEvalUTF16 = class(TResEvalValue) + public + S: UnicodeString; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + end; + + { TResEvalEnum - Kind=revkEnum, Value.Int, IdentEl is TPasEnumValue } + + TResEvalEnum = class(TResEvalValue) + public + Index: integer; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsDebugString: string; override; + function AsString: string; override; + end; + + { TResEvalRangeInt - Kind=revkRangeInt } + + TResEvalRangeInt = class(TResEvalValue) + public + type + TRgIntElKind = ( + revrikBool, + revrikEnum, // IdentEl is TPasEnumType + revrikInt, + revrikChar + ); + public + ElKind: TRgIntElKind; + RangeStart, RangeEnd: int64; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + function ElementAsString(El: int64): string; + end; + + { TResEvalRangeUInt } + + TResEvalRangeUInt = class(TResEvalValue) + public + RangeStart, RangeEnd: qword; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + end; + + { TResEvalSetInt - Kind=revkASet } + + TResEvalSetInt = class(TResEvalValue) + public + type + TSetElKind = ( + revsikEnum, // IdentEl is TPasEnumType + revsikInt, + revsikChar, + revsikWChar + ); + TItem = record + RangeStart, RangeEnd: int64; + end; + TItems = array of TItem; + public + ElKind: TSetElKind; + Ranges: TItems; + constructor Create; override; + function Clone: TResEvalValue; override; + function AsString: string; override; + function ElementAsString(El: int64): string; + end; + + TResEvalFlag = ( + refConst, // computing a const, error if a value is not const + refAutoConst, // set refConst if in a const + refSet // computing a set, allow ranges + ); + TResEvalFlags = set of TResEvalFlag; + + TResExprEvaluator = class; + + TPasResEvalLogHandler = procedure(Sender: TResExprEvaluator; const id: int64; + MsgType: TMessageType; MsgNumber: integer; + const Fmt: String; Args: Array of const; PosEl: TPasElement) of object; + TPasResEvalIdentHandler = function(Sender: TResExprEvaluator; + Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue of object; + + { TResExprEvaluator } + + TResExprEvaluator = class + private + FOnEvalIdentifier: TPasResEvalIdentHandler; + FOnLog: TPasResEvalLogHandler; + protected + procedure LogMsg(const id: int64; MsgType: TMessageType; MsgNumber: integer; + const Fmt: String; Args: Array of const; PosEl: TPasElement); overload; + procedure RaiseMsg(const Id: int64; MsgNumber: integer; const Fmt: String; + Args: Array of const; ErrorPosEl: TPasElement); + procedure RaiseNotYetImplemented(id: int64; El: TPasElement; Msg: string = ''); virtual; + procedure RaiseInternalError(id: int64; const Msg: string = ''); + procedure RaiseConstantExprExp(id: int64; ErrorEl: TPasElement); + procedure RaiseRangeCheck(id: int64; ErrorEl: TPasElement); + procedure RaiseOverflowArithmetic(id: int64; ErrorEl: TPasElement); + function EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags): TResEvalValue; + function EvalBinaryExpr(Expr: TBinaryExpr; Flags: TResEvalFlags): TResEvalValue; + function EvalArrayParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; + function EvalFuncParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; + function EvalSetParams(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; + function ExprStringToOrd(Value: TResEvalValue; PosEl: TPasElement): longword; virtual; + function EvalPrimitiveExprString(Expr: TPrimitiveExpr): TResEvalValue; virtual; + public + function Eval(Expr: TPasExpr; Flags: TResEvalFlags): TResEvalValue; + function IsInRange(Expr, RangeExpr: TPasExpr; EmitHints: boolean): boolean; + function IsConst(Expr: TPasExpr): boolean; + function IsSimpleExpr(Expr: TPasExpr): boolean; // true = no need to store result + procedure EmitRangeCheckConst(id: int64; const aValue, MinVal, MaxVal: String; + PosEl: TPasElement); virtual; + procedure EmitRangeCheckConst(id: int64; const aValue: String; + MinVal, MaxVal: int64; PosEl: TPasElement); + property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog; + property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier; + end; + +procedure ReleaseEvalValue(var Value: TResEvalValue); + +function RawStrToCaption(const r: RawByteString; MaxLength: integer): string; +function UnicodeStrToCaption(const u: UnicodeString; MaxLength: integer): Unicodestring; +function CanBeConvertedToUTF16(const s: String): integer; +function CodePointToString(CodePoint: longword): String; +function CodePointToUnicodeString(u: longword): UnicodeString; + +function GetObjName(o: TObject): string; +function dbgs(const Flags: TResEvalFlags): string; overload; +function dbgs(v: TResEvalValue): string; overload; + +implementation + +procedure ReleaseEvalValue(var Value: TResEvalValue); +begin + if Value=nil then exit; + if Value.Element<>nil then exit; + Value.Free; + Value:=nil; +end; + +function RawStrToCaption(const r: RawByteString; MaxLength: integer): string; +var + s: RawByteString; + p: PAnsiChar; + InLit: boolean; + Len: integer; + + procedure AddHash(o: integer); + var + h: String; + begin + if (Result<>'') and InLit then + begin + Result:=Result+''''; + inc(Len); + InLit:=false; + end; + h:='#'+IntToStr(o); + inc(Len,length(h)); + if Len<=MaxLength then + Result:=Result+h; + end; + + procedure AddLit(const Lit: string; CaptionLen: integer); + begin + if not InLit then + begin + Result:=Result+''''; + inc(Len); + InLit:=true; + end; + Result:=Result+Lit; + inc(Len,CaptionLen); + end; + +var + l: SizeInt; + CP: TSystemCodePage; + EndP: PAnsiChar; +begin + Result:=''; + s:=r; + CP:=StringCodePage(s); + if (CP<>CP_ACP) and (CP<>CP_UTF8) then + SetCodePage(s, CP_ACP, true); + p:=PAnsiChar(s); + EndP:=p+length(s); + Len:=0; + InLit:=false; + while Len'') and InLit then + begin + Result:=Result+''''; + inc(Len); + InLit:=false; + end; + h:='#'+UnicodeString(IntToStr(o)); + inc(Len,length(h)); + if Len<=MaxLength then + Result:=Result+h; + end; + + procedure AddLit(const Lit: Unicodestring; CaptionLen: integer); + begin + if not InLit then + begin + Result:=Result+''''; + inc(Len); + InLit:=true; + end; + Result:=Result+Lit; + inc(Len,CaptionLen); + end; + +begin + Result:=''; + p:=PWideChar(u); + Len:=0; + InLit:=false; + while LenCP_UTF8) and ((cp<>CP_ACP) or (DefaultSystemCodePage<>CP_UTF8)) then + begin + // need conversion -> not yet supported + exit(1); + end; + p:=PChar(s); + EndP:=p+length(s); + while p'' then Result:=Result+','; + str(f,s); + Result:=Result+s; + end; + Result:='['+Result+']'; +end; + +function dbgs(v: TResEvalValue): string; +begin + if v=nil then + Result:='nil' + else + Result:=v.AsDebugString; +end; + +{ TResEvalRangeUInt } + +constructor TResEvalRangeUInt.Create; +begin + inherited Create; + Kind:=revkRangeInt; +end; + +function TResEvalRangeUInt.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalRangeUInt(Result).RangeStart:=RangeStart; + TResEvalRangeUInt(Result).RangeEnd:=RangeEnd; +end; + +function TResEvalRangeUInt.AsString: string; +begin + Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd); +end; + +{ TResExprEvaluator } + +procedure TResExprEvaluator.LogMsg(const id: int64; MsgType: TMessageType; + MsgNumber: integer; const Fmt: String; Args: array of const; + PosEl: TPasElement); +begin + OnLog(Self,id,MsgType,MsgNumber,Fmt,Args,PosEl); +end; + +procedure TResExprEvaluator.RaiseMsg(const Id: int64; MsgNumber: integer; + const Fmt: String; Args: array of const; ErrorPosEl: TPasElement); +begin + LogMsg(id,mtError,MsgNumber,Fmt,Args,ErrorPosEl); + raise Exception.Create('['+IntToStr(id)+'] ('+IntToStr(MsgNumber)+') '+SafeFormat(Fmt,Args)); +end; + +procedure TResExprEvaluator.RaiseNotYetImplemented(id: int64; El: TPasElement; + Msg: string); +var + s: String; +begin + s:=sNotYetImplemented+' ['+IntToStr(id)+']'; + if Msg<>'' then + s:=s+' '+Msg; + {$IFDEF VerbosePasResolver} + writeln('TResExprEvaluator.RaiseNotYetImplemented s="',s,'" El=',GetObjName(El)); + {$ENDIF} + RaiseMsg(id,nNotYetImplemented,s,[GetObjName(El)],El); +end; + +procedure TResExprEvaluator.RaiseInternalError(id: int64; const Msg: string); +begin + raise Exception.Create('Internal error: ['+IntToStr(id)+'] '+Msg); +end; + +procedure TResExprEvaluator.RaiseConstantExprExp(id: int64; ErrorEl: TPasElement + ); +begin + RaiseMsg(id,nConstantExpressionExpected,sConstantExpressionExpected,[],ErrorEl); +end; + +procedure TResExprEvaluator.RaiseRangeCheck(id: int64; ErrorEl: TPasElement); +begin + RaiseMsg(id,nRangeCheckError,sRangeCheckError,[],ErrorEl); +end; + +procedure TResExprEvaluator.RaiseOverflowArithmetic(id: int64; + ErrorEl: TPasElement); +begin + RaiseMsg(id,nOverflowInArithmeticOperation,sOverflowInArithmeticOperation,[],ErrorEl); +end; + +function TResExprEvaluator.EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags + ): TResEvalValue; +begin + Result:=Eval(Expr.Operand,Flags); + if Result=nil then exit; + case Expr.OpCode of + eopAdd: ; + eopSubtract: + case Result.Kind of + revkInt: + begin + if TResEvalInt(Result).Int=0 then exit; + if Result.Element<>nil then + Result:=Result.Clone; + TResEvalInt(Result).Int:=-TResEvalInt(Result).Int; + end; + revkUInt: + begin + if TResEvalUInt(Result).UInt=0 then exit; + if Result.Element<>nil then + Result:=Result.Clone; + TResEvalUInt(Result).UInt:=-TResEvalUInt(Result).UInt; + end + else + begin + if Result.Element=nil then + Result.Free; + RaiseNotYetImplemented(20170518230738,Expr); + end; + end; + eopNot: + case Result.Kind of + revkBool: + begin + if Result.Element<>nil then + Result:=Result.Clone; + if TResEvalInt(Result).Int=0 then + TResEvalInt(Result).Int:=1 + else + TResEvalInt(Result).Int:=0; + end + else + begin + if Result.Element=nil then + Result.Free; + RaiseNotYetImplemented(20170518232804,Expr); + end; + end; + eopAddress: + begin + if Result.Element=nil then + Result.Free; + // @ operator requires a compiler -> return nil + Result:=TResEvalValue.Create; + Result.Kind:=revkNil; + end + else + RaiseNotYetImplemented(20170518232823,Expr); + end; +end; + +function TResExprEvaluator.EvalBinaryExpr(Expr: TBinaryExpr; + Flags: TResEvalFlags): TResEvalValue; +var + LeftValue, RightValue: TResEvalValue; + LeftInt, RightInt: LongWord; + Int: NativeInt; + UInt: NativeUInt; +begin + Result:=nil; + LeftValue:=nil; + RightValue:=nil; + try + LeftValue:=Eval(Expr.left,Flags); + if LeftValue=nil then exit; + RightValue:=Eval(Expr.right,Flags); + if RightValue=nil then exit; + case Expr.Kind of + pekRange: + // leftvalue..rightvalue + case LeftValue.Kind of + revkInt: + if RightValue.Kind=revkInt then + begin + if TResEvalInt(LeftValue).Int>TResEvalInt(RightValue).Int then + RaiseMsg(20170518222939,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right); + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikInt; + TResEvalRangeInt(Result).RangeStart:=TResEvalInt(LeftValue).Int; + TResEvalRangeInt(Result).RangeEnd:=TResEvalInt(RightValue).Int; + exit; + end + else if RightValue.Kind=revkUInt then + begin + // Note: when FPC compares int64 with qword it converts the qword to an int64 + if TResEvalUInt(RightValue).UInt<=NativeUInt(High(NativeInt)) then + begin + if TResEvalInt(LeftValue).Int>TResEvalUInt(RightValue).UInt then + RaiseMsg(20170519000235,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right); + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikInt; + TResEvalRangeInt(Result).RangeStart:=TResEvalInt(LeftValue).Int; + TResEvalRangeInt(Result).RangeEnd:=TResEvalUInt(RightValue).UInt; + exit; + end + else if TResEvalInt(LeftValue).Int<0 then + RaiseRangeCheck(20170522151629,Expr.Right) + else if qword(TResEvalInt(LeftValue).Int)>TResEvalUInt(RightValue).UInt then + RaiseMsg(20170522151708,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right); + Result:=TResEvalRangeUInt.Create; + TResEvalRangeUInt(Result).RangeStart:=TResEvalInt(LeftValue).Int; + TResEvalRangeUInt(Result).RangeEnd:=TResEvalUInt(RightValue).UInt; + exit; + end + else + RaiseRangeCheck(20170518222812,Expr.Right); + revkUInt: + if RightValue.Kind=revkInt then + begin + // Note: when FPC compares int64 with qword it converts the qword to an int64 + if TResEvalUInt(LeftValue).UInt>NativeUInt(High(NativeInt)) then + begin + if TResEvalInt(RightValue).Int<0 then + RaiseRangeCheck(20170522152608,Expr.Right) + else if TResEvalUInt(LeftValue).UInt>qword(TResEvalInt(RightValue).Int) then + RaiseMsg(20170522152648,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right); + Result:=TResEvalRangeUInt.Create; + TResEvalRangeUInt(Result).RangeStart:=TResEvalUInt(LeftValue).UInt; + TResEvalRangeUInt(Result).RangeEnd:=TResEvalInt(RightValue).Int; + exit; + end + else if TResEvalUInt(LeftValue).UInt>TResEvalInt(RightValue).Int then + RaiseMsg(20170522152804,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right); + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikInt; + TResEvalRangeInt(Result).RangeStart:=TResEvalUInt(LeftValue).UInt; + TResEvalRangeInt(Result).RangeEnd:=TResEvalInt(RightValue).Int; + exit; + end + else if RightValue.Kind=revkUInt then + begin + if TResEvalUInt(LeftValue).UInt>TResEvalUInt(RightValue).UInt then + RaiseMsg(20170519000240,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right); + Result:=TResEvalRangeUInt.Create; + TResEvalRangeUInt(Result).RangeStart:=TResEvalUInt(LeftValue).UInt; + TResEvalRangeUInt(Result).RangeEnd:=TResEvalUInt(RightValue).UInt; + exit; + end + else + RaiseRangeCheck(20170522123106,Expr.Right); + revkEnum: + if (RightValue.Kind<>revkEnum) then + RaiseRangeCheck(20170522153003,Expr.Right) + else if (TResEvalEnum(LeftValue).IdentEl<>TResEvalEnum(RightValue).IdentEl) then + RaiseRangeCheck(20170522123241,Expr.Right) + else if TResEvalEnum(LeftValue).Index>TResEvalEnum(RightValue).Index then + RaiseMsg(20170522123320,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right) + else + begin + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikEnum; + TResEvalRangeInt(Result).RangeStart:=TResEvalEnum(LeftValue).Index; + TResEvalRangeInt(Result).RangeEnd:=TResEvalEnum(RightValue).Index; + exit; + end; + revkString,revkUnicodeString: + begin + LeftInt:=ExprStringToOrd(LeftValue,Expr.left); + if RightValue.Kind in [revkString,revkUnicodeString] then + begin + RightInt:=ExprStringToOrd(RightValue,Expr.right); + if LeftInt>RightInt then + RaiseMsg(20170523151508,nHighRangeLimitLTLowRangeLimit, + sHighRangeLimitLTLowRangeLimit,[],Expr.Right); + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikChar; + TResEvalRangeInt(Result).RangeStart:=LeftInt; + TResEvalRangeInt(Result).RangeEnd:=RightInt; + exit; + end + else + RaiseRangeCheck(20170522123106,Expr.Right); + end + else + {$IFDEF EnablePasResRangeCheck} + writeln('TPasResolver.Eval pekRange Left=',GetObjName(Expr.Left),' LeftValue.Kind=',LeftValue.Kind); + RaiseNotYetImplemented(20170518221103,Expr.Left); + {$ELSE} + exit(nil); + {$ENDIF} + end; + pekBinary: + case Expr.OpCode of + eopAdd: + case LeftValue.Kind of + revkInt: + if RightValue.Kind=revkInt then + // int+int + try + {$Q+} + Int:=TResEvalInt(LeftValue).Int+TResEvalInt(RightValue).Int; + {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF} + Result:=TResEvalInt.Create; + TResEvalInt(Result).Int:=NativeInt(Int); + except + on E: EOverflow do + if (TResEvalInt(LeftValue).Int>0) and (TResEvalInt(RightValue).Int>0) then + begin + UInt:=NativeUInt(TResEvalInt(LeftValue).Int)+NativeUInt(TResEvalInt(RightValue).Int); + Result:=TResEvalUInt.Create; + TResEvalUInt(Result).UInt:=UInt; + end + else + RaiseOverflowArithmetic(20170525122256,Expr); + end + else + begin + {$IFDEF VerbosePasResolver} + writeln('TResExprEvaluator.EvalBinaryExpr add int+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString); + {$ENDIF} + RaiseNotYetImplemented(20170525115537,Expr); + end; + else + {$IFDEF VerbosePasResolver} + writeln('TResExprEvaluator.EvalBinaryExpr add ?+ Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString); + {$ENDIF} + RaiseNotYetImplemented(20170525115548,Expr); + end; + else + {$IFDEF VerbosePasResolver} + writeln('TResExprEvaluator.EvalBinaryExpr Opcode=',OpcodeStrings[Expr.OpCode],' Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString); + {$ENDIF} + RaiseNotYetImplemented(20170518232823,Expr); + end; + else + {$IFDEF VerbosePasResolver} + writeln('TResExprEvaluator.EvalBinaryExpr Kind=',Expr.Kind,' Opcode=',OpcodeStrings[Expr.OpCode]); + {$ENDIF} + RaiseNotYetImplemented(20170518232823,Expr); + end; + finally + ReleaseEvalValue(LeftValue); + ReleaseEvalValue(RightValue); + end; +end; + +function TResExprEvaluator.EvalArrayParams(Expr: TParamsExpr; + Flags: TResEvalFlags): TResEvalValue; +begin + Result:=nil; + {$IFDEF VerbosePasResEval} + writeln('TResExprEvaluator.EvalArrayParams '); + {$ENDIF} + if refConst in Flags then + RaiseConstantExprExp(20170522173150,Expr); +end; + +function TResExprEvaluator.EvalFuncParams(Expr: TParamsExpr; + Flags: TResEvalFlags): TResEvalValue; +begin + Result:=nil; + {$IFDEF VerbosePasResEval} + writeln('TResExprEvaluator.EvalFuncParams '); + {$ENDIF} + if refConst in Flags then + RaiseConstantExprExp(20170522173150,Expr); +end; + +function TResExprEvaluator.EvalSetParams(Expr: TParamsExpr; Flags: TResEvalFlags + ): TResEvalValue; +begin + Result:=nil; + {$IFDEF VerbosePasResEval} + writeln('TResExprEvaluator.EvalSetParams '); + {$ENDIF} + if length(Expr.Params)=0 then + begin + Result:=TResEvalValue.Create; + Result.Kind:=revkSetEmpty; + exit; + end; + if refConst in Flags then + RaiseConstantExprExp(20170522173150,Expr); +end; + +function TResExprEvaluator.ExprStringToOrd(Value: TResEvalValue; + PosEl: TPasElement): longword; +var + l: SizeInt; + S: RawByteString; + U: UnicodeString; +begin + if Value.Kind=revkString then + begin + S:=TResEvalString(Value).S; + l:=length(S); + if l=0 then + RaiseMsg(20170522221143,nXExpectedButYFound,sXExpectedButYFound, + ['char','string'],PosEl) + else if l=1 then + Result:=ord(S[1]) + else if l<=4 then + begin + U:=UTF8Decode(S); + if length(U)<>1 then + RaiseMsg(20170523150826,nXExpectedButYFound,sXExpectedButYFound, + ['char','string'],PosEl); + Result:=ord(U[1]); + end; + end + else if Value.Kind=revkUnicodeString then + begin + if length(TResEvalUTF16(Value).S)<>1 then + RaiseMsg(20170522221358,nXExpectedButYFound,sXExpectedButYFound, + ['char','string'],PosEl) + else + Result:=ord(TResEvalUTF16(Value).S[1]); + end + else + RaiseNotYetImplemented(20170522220959,PosEl); +end; + +function TResExprEvaluator.EvalPrimitiveExprString(Expr: TPrimitiveExpr + ): TResEvalValue; +{ Extracts the value from a Pascal string literal + + S is a Pascal string literal e.g. 'Line'#10 + '' empty string + '''' => "'" + #decimal + #$hex + ^l l is a letter a-z +} + + procedure RangeError(id: int64); + begin + Result.Free; + RaiseRangeCheck(id,Expr); + end; + + procedure Add(h: String); + begin + if Result.Kind=revkString then + TResEvalString(Result).S:=TResEvalString(Result).S+h + else + begin + if CanBeConvertedToUTF16(h)>0 then + begin + Result.Free; + RaiseMsg(20170523114733,nIllegalChar,sIllegalChar,[],Expr); + end; + TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+UnicodeString(h); + end; + end; + + procedure AddHash(u: longword); + var + h: RawByteString; + begin + if (u>255) and (Result.Kind=revkString) then + begin + h:=TResEvalString(Result).S; + Result.Free; + if CanBeConvertedToUTF16(h)>0 then + RaiseMsg(20170523123140,nIllegalChar,sIllegalChar,[],Expr); + Result:=TResEvalUTF16.Create; + TResEvalUTF16(Result).S:=UnicodeString(h); + end; + if Result.Kind=revkString then + TResEvalString(Result).S:=TResEvalString(Result).S+Chr(u) + else + TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+WideChar(u); + end; + +var + p, StartP: PChar; + c: Char; + u: longword; + S: String; +begin + Result:=nil; + S:=Expr.Value; + {$IFDEF VerbosePasResEval} + writeln('TResExprEvaluator.EvalPrimitiveExprString (',S,')'); + {$ENDIF} + if S='' then + RaiseInternalError(20170523113809); + Result:=TResEvalString.Create; + p:=PChar(S); + repeat + case p^ of + #0: break; + '''': + begin + inc(p); + StartP:=p; + repeat + c:=p^; + case c of + #0: + RaiseInternalError(20170523113938); + '''': + begin + if p>StartP then + Add(copy(S,StartP-PChar(S)+1,p-StartP)); + inc(p); + StartP:=p; + if p^<>'''' then + break; + Add(''''); + inc(p); + StartP:=p; + end; + else + inc(p); + end; + until false; + if p>StartP then + Add(copy(S,StartP-PChar(S)+1,p-StartP)); + end; + '#': + begin + inc(p); + if p^='$' then + begin + // #$hexnumber + inc(p); + StartP:=p; + u:=0; + repeat + c:=p^; + case c of + #0: break; + '0'..'9': u:=u*16+ord(c)-ord('0'); + 'a'..'f': u:=u*16+ord(c)-ord('a')+10; + 'A'..'F': u:=u*16+ord(c)-ord('A')+10; + else break; + end; + if u>$ffff then + RangeError(20170523115712); + inc(p); + until false; + if p=StartP then + RaiseInternalError(20170207164956); + AddHash(u); + end + else + begin + // #decimalnumber + StartP:=p; + u:=0; + repeat + c:=p^; + case c of + #0: break; + '0'..'9': u:=u*10+ord(c)-ord('0'); + else break; + end; + if u>$ffff then + RangeError(20170523123137); + inc(p); + until false; + if p=StartP then + RaiseInternalError(20170523123806); + AddHash(u); + end; + end; + '^': + begin + // ^A is #1 + inc(p); + c:=p^; + case c of + 'a'..'z': AddHash(ord(c)-ord('a')+1); + 'A'..'Z': AddHash(ord(c)-ord('A')+1); + else RaiseInternalError(20170523123809); + end; + inc(p); + end; + else + RaiseNotYetImplemented(20170523123815,Expr,'ord='+IntToStr(ord(p^))); + end; + until false; + {$IFDEF VerbosePasResEval} + writeln('TResExprEvaluator.EvalPrimitiveExprString Result=',Result.AsString); + {$ENDIF} +end; + +function TResExprEvaluator.Eval(Expr: TPasExpr; Flags: TResEvalFlags + ): TResEvalValue; +var + C: TClass; + Code: integer; + Int: NativeInt; + UInt: NativeUInt; + Ext: Extended; +begin + Result:=nil; + if Expr.CustomData is TResEvalValue then + begin + Result:=TResEvalValue(Expr.CustomData); + exit; + end; + {$IFDEF VerbosePasResEval} + writeln('TPasResolver.Eval Expr=',GetObjName(Expr),' Flags=',dbgs(Flags)); + {$ENDIF} + if refAutoConst in Flags then + begin + Exclude(Flags,refAutoConst); + if IsConst(Expr) then + Include(Flags,refConst); + end; + + C:=Expr.ClassType; + if C=TPrimitiveExpr then + begin + case TPrimitiveExpr(Expr).Kind of + pekIdent: + Result:=OnEvalIdentifier(Self,TPrimitiveExpr(Expr),Flags); + pekNumber: + begin + // try int64 + val(TPrimitiveExpr(Expr).Value,Int,Code); + if Code=0 then + begin + Result:=TResEvalInt.Create; + TResEvalInt(Result).Int:=Int; + exit; + end; + // try qword + val(TPrimitiveExpr(Expr).Value,UInt,Code); + if Code=0 then + begin + Result:=TResEvalUInt.Create; + TResEvalUInt(Result).UInt:=UInt; + exit; + end; + // try float + val(TPrimitiveExpr(Expr).Value,Ext,Code); + if Code=0 then + begin + Result:=TResEvalFloat.Create; + TResEvalFloat(Result).FloatValue:=Ext; + exit; + end; + RaiseRangeCheck(20170518202252,Expr); + end; + pekString: + begin + Result:=EvalPrimitiveExprString(TPrimitiveExpr(Expr)); + exit; + end; + else + RaiseNotYetImplemented(20170518200951,Expr); + end; + end + else if C=TNilExpr then + begin + Result:=TResEvalValue.Create; + Result.Kind:=revkNil; + end + else if C=TBoolConstExpr then + begin + Result:=TResEvalInt.Create; + Result.Kind:=revkBool; + if TBoolConstExpr(Expr).Value then + TResEvalInt(Result).Int:=1 + else + TResEvalInt(Result).Int:=0; + end + else if C=TUnaryExpr then + Result:=EvalUnaryExpr(TUnaryExpr(Expr),Flags) + else if C=TBinaryExpr then + Result:=EvalBinaryExpr(TBinaryExpr(Expr),Flags) + else if C=TParamsExpr then + case TParamsExpr(Expr).Kind of + pekArrayParams: Result:=EvalArrayParams(TParamsExpr(Expr),Flags); + pekFuncParams: Result:=EvalFuncParams(TParamsExpr(Expr),Flags); + pekSet: Result:=EvalSetParams(TParamsExpr(Expr),Flags); + else + RaiseInternalError(20170522173013); + end + else if refConst in Flags then + RaiseConstantExprExp(20170518213800,Expr); +end; + +function TResExprEvaluator.IsInRange(Expr, RangeExpr: TPasExpr; + EmitHints: boolean): boolean; +var + ExprValue, RangeValue: TResEvalValue; + RgInt: TResEvalRangeInt; + RgUInt: TResEvalRangeUInt; + CharIndex: LongWord; +begin + Result:=false; + ExprValue:=Eval(Expr,[refAutoConst]); + if ExprValue=nil then + exit(true); // a variable -> ok + RangeValue:=nil; + try + RangeValue:=Eval(RangeExpr,[]); + {$IFDEF VerbosePasResEval} + //writeln('TResExprEvaluator.IsInRange ExprValue=',dbgs(ExprValue),' RangeValue=',dbgs(RangeValue)); + {$ENDIF} + if RangeValue=nil then + RaiseNotYetImplemented(20170522171226,RangeExpr); + case RangeValue.Kind of + revkSetEmpty: + begin + Result:=false; + exit; + end; + revkRangeInt: + begin + RgInt:=TResEvalRangeInt(RangeValue); + case RgInt.ElKind of + revrikBool: + if ExprValue.Kind=revkBool then + exit(true) + else + RaiseNotYetImplemented(20170522220104,Expr); + revrikEnum: + begin + if ExprValue.Kind<>revkEnum then + RaiseInternalError(20170522172754) + else if ExprValue.IdentEl<>RgInt.IdentEl then + RaiseInternalError(20170522174028) + else if (TResEvalEnum(ExprValue).IndexRgInt.RangeEnd) then + begin + if EmitHints then + EmitRangeCheckConst(20170522174406,ExprValue.AsString, + RgInt.ElementAsString(RgInt.RangeStart), + RgInt.ElementAsString(RgInt.RangeEnd), + Expr); + exit(false); + end + else + exit(true); + end; + revrikInt: // int..int + if ExprValue.Kind=revkInt then + begin + // int in int..int + if (TResEvalInt(ExprValue).IntRgInt.RangeEnd) then + begin + if EmitHints then + EmitRangeCheckConst(20170522174958,ExprValue.AsString, + RgInt.ElementAsString(RgInt.RangeStart), + RgInt.ElementAsString(RgInt.RangeEnd), + Expr); + exit(false); + end + else + exit(true); + end + else if ExprValue.Kind=revkUInt then + begin + // uint in int..int + if (TResEvalUInt(ExprValue).UInt>NativeUInt(High(NativeInt))) + or (NativeInt(TResEvalUInt(ExprValue).UInt)RgInt.RangeEnd) then + begin + if EmitHints then + EmitRangeCheckConst(20170522215852,ExprValue.AsString, + RgInt.ElementAsString(RgInt.RangeStart), + RgInt.ElementAsString(RgInt.RangeEnd), + Expr); + exit(false); + end + else + exit(true); + end + else + RaiseNotYetImplemented(20170522215906,Expr); + revrikChar: + if ExprValue.Kind in [revkString,revkUnicodeString] then + begin + // string in char..char + CharIndex:=ExprStringToOrd(ExprValue,Expr); + if (CharIndexRgInt.RangeEnd) then + begin + if EmitHints then + EmitRangeCheckConst(20170522221709,ExprValue.AsString, + RgInt.ElementAsString(RgInt.RangeStart), + RgInt.ElementAsString(RgInt.RangeEnd), + Expr); + exit(false); + end + else + exit(true); + end + else + RaiseNotYetImplemented(20170522220210,Expr); + else + RaiseInternalError(20170522172630); + end; + end; + revkRangeUInt: + if ExprValue.Kind=revkInt then + begin + // int in uint..uint + RgUInt:=TResEvalRangeUInt(RangeValue); + if (TResEvalInt(ExprValue).Int<0) + or (NativeUInt(TResEvalInt(ExprValue).Int)RgUInt.RangeEnd) then + begin + if EmitHints then + EmitRangeCheckConst(20170522172250,ExprValue.AsString, + IntToStr(RgUInt.RangeStart), + IntToStr(RgUInt.RangeEnd),Expr); + exit(false); + end + else + exit(true); + end + else if ExprValue.Kind=revkUInt then + begin + // uint in uint..uint + RgUInt:=TResEvalRangeUInt(RangeValue); + if (TResEvalUInt(ExprValue).UIntRgUInt.RangeEnd) then + begin + if EmitHints then + EmitRangeCheckConst(20170522172544,IntToStr(TResEvalUInt(ExprValue).UInt), + IntToStr(RgUInt.RangeStart), + IntToStr(RgUInt.RangeEnd),Expr); + exit(false); + end + else + exit(true); + end + else + RaiseNotYetImplemented(20170522171551,Expr); + else + RaiseNotYetImplemented(20170522171307,RangeExpr); + end; + finally + ReleaseEvalValue(ExprValue); + ReleaseEvalValue(RangeValue); + end; +end; + +function TResExprEvaluator.IsConst(Expr: TPasExpr): boolean; +var + El: TPasElement; + C: TClass; +begin + El:=Expr; + while El<>nil do + begin + C:=El.ClassType; + if C.InheritsFrom(TPasProcedure) then exit(true); + if C.InheritsFrom(TPasImplBlock) then exit(false); + El:=El.Parent; + end; + Result:=true; +end; + +function TResExprEvaluator.IsSimpleExpr(Expr: TPasExpr): boolean; +var + C: TClass; +begin + C:=Expr.ClassType; + Result:=(C=TNilExpr) + or (C=TBoolConstExpr) + or (C=TPrimitiveExpr); +end; + +procedure TResExprEvaluator.EmitRangeCheckConst(id: int64; const aValue, + MinVal, MaxVal: String; PosEl: TPasElement); +begin + LogMsg(id,mtWarning,nRangeCheckEvaluatingConstantsVMinMax, + sRangeCheckEvaluatingConstantsVMinMax,[aValue,MinVal,MaxVal],PosEl); +end; + +procedure TResExprEvaluator.EmitRangeCheckConst(id: int64; + const aValue: String; MinVal, MaxVal: int64; PosEl: TPasElement); +begin + EmitRangeCheckConst(id,aValue,IntToStr(MinVal),IntToStr(MaxVal),PosEl); +end; + +{ TResolveData } + +procedure TResolveData.SetElement(AValue: TPasElement); +begin + if FElement=AValue then Exit; + if Element<>nil then + Element.Release; + FElement:=AValue; + if Element<>nil then + Element.AddRef; +end; + +constructor TResolveData.Create; +begin + +end; + +destructor TResolveData.Destroy; +begin + {$IFDEF VerbosePasResolverMem} + writeln('TResolveData.Destroy START ',ClassName); + {$ENDIF} + Element:=nil; + Owner:=nil; + Next:=nil; + inherited Destroy; + {$IFDEF VerbosePasResolverMem} + writeln('TResolveData.Destroy END ',ClassName); + {$ENDIF} +end; + +{ TResEvalValue } + +function TResEvalValue.Clone: TResEvalValue; +begin + Result:=TResEvalValueClass(ClassType).Create; + Result.Kind:=Kind; + Result.IdentEl:=IdentEl; +end; + +function TResEvalValue.AsDebugString: string; +begin + str(Kind,Result); + Result:=Result+'='+AsString; +end; + +function TResEvalValue.AsString: string; +begin + case Kind of + revkNone: Result:=''; + revkNil: Result:='nil'; + revkSetEmpty: Result:='[]'; + else + str(Kind,Result); + end; +end; + +{ TResEvalUInt } + +constructor TResEvalUInt.Create; +begin + inherited Create; + Kind:=revkUInt; +end; + +function TResEvalUInt.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalUInt(Result).UInt:=UInt; +end; + +function TResEvalUInt.AsString: string; +begin + Result:=IntToStr(UInt); +end; + +{ TResEvalInt } + +constructor TResEvalInt.Create; +begin + inherited Create; + Kind:=revkInt; +end; + +function TResEvalInt.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalInt(Result).Int:=Int; +end; + +function TResEvalInt.AsString: string; +begin + case Kind of + revkBool: if Int=0 then Result:='false' else Result:='true'; + revkInt: Result:=IntToStr(Int); + end; +end; + +{ TResEvalFloat } + +constructor TResEvalFloat.Create; +begin + inherited Create; + Kind:=revkFloat; +end; + +function TResEvalFloat.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalFloat(Result).FloatValue:=FloatValue; +end; + +function TResEvalFloat.AsString: string; +begin + str(FloatValue,Result); +end; + +{ TResEvalString } + +constructor TResEvalString.Create; +begin + inherited Create; + Kind:=revkString; +end; + +function TResEvalString.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalString(Result).S:=S; +end; + +function TResEvalString.AsString: string; +begin + Result:=RawStrToCaption(S,60); +end; + +{ TResEvalUTF16 } + +constructor TResEvalUTF16.Create; +begin + inherited Create; + Kind:=revkUnicodeString; +end; + +function TResEvalUTF16.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalUTF16(Result).S:=S; +end; + +function TResEvalUTF16.AsString: string; +begin + Result:=String(UnicodeStrToCaption(S,60)); +end; + +{ TResEvalEnum } + +constructor TResEvalEnum.Create; +begin + inherited Create; + Kind:=revkEnum; +end; + +function TResEvalEnum.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalEnum(Result).Index:=Index; +end; + +function TResEvalEnum.AsDebugString: string; +begin + str(Kind,Result); + Result:=Result+'='+IdentEl.Name+'='+IntToStr(Index); +end; + +function TResEvalEnum.AsString: string; +begin + Result:=IdentEl.Name; +end; + +{ TResEvalRangeInt } + +constructor TResEvalRangeInt.Create; +begin + inherited Create; + Kind:=revkRangeInt; +end; + +function TResEvalRangeInt.Clone: TResEvalValue; +begin + Result:=inherited Clone; + TResEvalRangeInt(Result).ElKind:=ElKind; + TResEvalRangeInt(Result).RangeStart:=RangeStart; + TResEvalRangeInt(Result).RangeEnd:=RangeEnd; +end; + +function TResEvalRangeInt.AsString: string; +begin + Result:=ElementAsString(RangeStart)+'..'+ElementAsString(RangeEnd); +end; + +function TResEvalRangeInt.ElementAsString(El: int64): string; +begin + case ElKind of + revrikBool: if El=0 then Result:='false' else Result:='true'; + revrikEnum: Result:=TPasEnumValue(TPasEnumType(IdentEl).Values[El]).Name; + revrikInt: Result:=IntToStr(El); + revrikChar: + if ((El>=32) and (El<=38)) or ((El>=40) and (El<=126)) then + Result:=''''+Chr(El)+'''' + else + Result:='#'+IntToStr(El); + end; +end; + +{ TResEvalSetInt } + +constructor TResEvalSetInt.Create; +begin + inherited Create; + Kind:=revkSetOfInt; +end; + +function TResEvalSetInt.Clone: TResEvalValue; +var + RS: TResEvalSetInt; + i: Integer; +begin + Result:=inherited Clone; + TResEvalSetInt(Result).ElKind:=ElKind; + RS:=TResEvalSetInt(Result); + SetLength(RS.Ranges,length(Ranges)); + for i:=0 to length(Ranges)-1 do + RS.Ranges[i]:=Ranges[i]; +end; + +function TResEvalSetInt.AsString: string; +var + i: Integer; +begin + Result:='['; + for i:=0 to length(Ranges)-1 do + begin + if i>0 then Result:=Result+','; + Result:=Result+ElementAsString(Ranges[i].RangeStart); + if Ranges[i].RangeStart<>Ranges[i].RangeEnd then + Result:=Result+'..'+ElementAsString(Ranges[i].RangeEnd); + end; + Result:=Result+']'; +end; + +function TResEvalSetInt.ElementAsString(El: int64): string; +begin + case ElKind of + revsikEnum: Result:=TPasEnumValue(TPasEnumType(IdentEl).Values[El]).Name; + revsikInt: Result:=IntToStr(El); + revsikChar: Result:=Chr(El); + revsikWChar: Result:=String(WideChar(El)); + end; +end; + +end. + diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 5804351133..572b595902 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -135,17 +135,22 @@ Works: - nil, assigned(), typecast, class, classref, dynarray, procvar - emit hints platform, deprecated, experimental, library, unimplemented - dotted unitnames +- eval: + - nil, true, false ToDo: - range checking: - - nil, - - true, false - integer ranges - boolean ranges - enum ranges - char ranges - - +, -, *, div, mod, /, shl, shr, or, and, xor, not, + - +, -, *, div, mod, /, shl, shr, or, and, xor - ord(), low(), high(), pred(), succ(), length() + - string[index] + - arr[index] + - call(param) + - indexedprop[param] + - a:=value - @@ - fail to write a loop var inside the loop - warn: create class with abstract methods @@ -204,148 +209,12 @@ interface uses Classes, SysUtils, Math, contnrs, - PasTree, PParser, PScanner; + PasTree, PScanner, PParser, PasResolveEval; const ParserMaxEmbeddedColumn = 2048; ParserMaxEmbeddedRow = $7fffffff div ParserMaxEmbeddedColumn; -// message numbers -const - nIdentifierNotFound = 3001; - nNotYetImplemented = 3002; - nIllegalQualifier = 3003; - nSyntaxErrorExpectedButFound = 3004; - nWrongNumberOfParametersForCallTo = 3005; - nIncompatibleTypeArgNo = 3006; - nIncompatibleTypeArgNoVarParamMustMatchExactly = 3007; - nVariableIdentifierExpected = 3008; - nDuplicateIdentifier = 3009; - nXExpectedButYFound = 3010; - nAncestorCycleDetected = 3011; - nCantUseForwardDeclarationAsAncestor = 3012; - nCantDetermineWhichOverloadedFunctionToCall = 3013; - nForwardTypeNotResolved = 3014; - nForwardProcNotResolved = 3015; - nInvalidXModifierY = 3016; - nAbstractMethodsMustNotHaveImplementation = 3017; - nCallingConventionMismatch = 3018; - nResultTypeMismatchExpectedButFound = 3019; - nFunctionHeaderMismatchForwardVarName = 3020; - nFunctionHidesIdentifier = 3021; - nNoMethodInAncestorToOverride = 3022; - nInheritedOnlyWorksInMethods = 3023; - nInheritedNeedsAncestor = 3024; - nNoPropertyFoundToOverride = 3025; - nExprTypeMustBeClassOrRecordTypeGot = 3026; - nPropertyNotWritable = 3027; - nIncompatibleTypesGotExpected = 3028; - nTypesAreNotRelated = 3029; - nAbstractMethodsCannotBeCalledDirectly = 3030; - nMissingParameterX = 3031; - nCannotAccessThisMemberFromAX = 3032; - nInOperatorExpectsSetElementButGot = 3033; - nWrongNumberOfParametersForTypeCast = 3034; - nIllegalTypeConversionTo = 3035; - nConstantExpressionExpected = 3036; - nLeftSideOfIsOperatorExpectsAClassButGot = 3037; - nNotReadable = 3038; - nClassPropertyAccessorMustBeStatic = 3039; - nClassPropertyAccessorMustNotBeStatic = 3040; - nOnlyOneDefaultPropertyIsAllowed = 3041; - nWrongNumberOfParametersForArray = 3042; - nCantAssignValuesToAnAddress = 3043; - nIllegalExpression = 3044; - nCantAccessPrivateMember = 3045; - nMustBeInsideALoop = 3046; - nExpectXArrayElementsButFoundY = 3047; - nCannotCreateADescendantOfTheSealedClass = 3048; - nAncestorIsNotExternal = 3049; - nVirtualMethodXHasLowerVisibility = 3050; // FPC 3250 - nExternalClassInstanceCannotAccessStaticX = 3051; - nXModifierMismatchY = 3052; - nSymbolCannotBePublished = 3053; - nCannotTypecastAType = 3054; - nTypeIdentifierExpected = 3055; - nCannotNestAnonymousX = 3056; - nFoundCallCandidateX = 3057; - nSymbolXIsNotPortable = 3058; - nSymbolXIsExperimental = 3059; - nSymbolXIsNotImplemented = 3060; - nSymbolXBelongsToALibrary = 3061; - nSymbolXIsDeprecated = 3062; - nSymbolXIsDeprecatedY = 3063; - nRangeCheckError = 3064; - nHighRangeLimitLTLowRangeLimit = 3065; - -// resourcestring patterns of messages -resourcestring - sIdentifierNotFound = 'identifier not found "%s"'; - sNotYetImplemented = 'not yet implemented: %s'; - sIllegalQualifier = 'illegal qualifier "%s"'; - sSyntaxErrorExpectedButFound = 'Syntax error, "%s" expected but "%s" found'; - sWrongNumberOfParametersForCallTo = 'Wrong number of parameters specified for call to "%s"'; - sIncompatibleTypeArgNo = 'Incompatible type arg no. %s: Got "%s", expected "%s"'; - sIncompatibleTypeArgNoVarParamMustMatchExactly = 'Incompatible type arg no. %s: Got "%s", expected "%s". Var param must match exactly.'; - sVariableIdentifierExpected = 'Variable identifier expected'; - sDuplicateIdentifier = 'Duplicate identifier "%s" at %s'; - sXExpectedButYFound = '%s expected, but %s found'; - sAncestorCycleDetected = 'Ancestor cycle detected'; - sCantUseForwardDeclarationAsAncestor = 'Can''t use forward declaration "%s" as ancestor'; - sCantDetermineWhichOverloadedFunctionToCall = 'Can''t determine which overloaded function to call'; - sForwardTypeNotResolved = 'Forward type not resolved "%s"'; - sForwardProcNotResolved = 'Forward %s not resolved "%s"'; - sInvalidXModifierY = 'Invalid %s modifier %s'; - sAbstractMethodsMustNotHaveImplementation = 'Abstract method must not have an implementation.'; - sCallingConventionMismatch = 'Calling convention mismatch'; - sResultTypeMismatchExpectedButFound = 'Result type mismatch, expected %s, but found %s'; - sFunctionHeaderMismatchForwardVarName = 'function header "%s" doesn''t match forward : var name changes %s => %s'; - sFunctionHidesIdentifier = 'function hides identifier "%s" at "%s"'; - sNoMethodInAncestorToOverride = 'There is no method in an ancestor class to be overridden "%s"'; - sInheritedOnlyWorksInMethods = 'Inherited works only in methods'; - sInheritedNeedsAncestor = 'inherited needs an ancestor'; - sNoPropertyFoundToOverride = 'No property found to override'; - sExprTypeMustBeClassOrRecordTypeGot = 'Expression type must be class or record type, got %s'; - sPropertyNotWritable = 'No member is provided to access property'; - sIncompatibleTypesGotExpected = 'Incompatible types: got "%s" expected "%s"'; - sTypesAreNotRelated = 'Types are not related'; - sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly'; - sMissingParameterX = 'Missing parameter %s'; - sCannotAccessThisMemberFromAX = 'Cannot access this member from a %s'; - sInOperatorExpectsSetElementButGot = 'the in-operator expects a set element, but got %s'; - sWrongNumberOfParametersForTypeCast = 'wrong number of parameters for type cast to %s'; - sIllegalTypeConversionTo = 'Illegal type conversion: "%s" to "%s"'; - sConstantExpressionExpected = 'Constant expression expected'; - sLeftSideOfIsOperatorExpectsAClassButGot = 'left side of is-operator expects a class, but got %s'; - sNotReadable = 'not readable'; - sClassPropertyAccessorMustBeStatic = 'class property accessor must be static'; - sClassPropertyAccessorMustNotBeStatic = 'class property accessor must not be static'; - sOnlyOneDefaultPropertyIsAllowed = 'Only one default property is allowed'; - sWrongNumberOfParametersForArray = 'Wrong number of parameters for array'; - sCantAssignValuesToAnAddress = 'Can''t assign values to an address'; - sIllegalExpression = 'Illegal expression'; - sCantAccessPrivateMember = 'Can''t access %s member %s'; - sMustBeInsideALoop = '%s must be inside a loop'; - sExpectXArrayElementsButFoundY = 'Expect %s array elements, but found %s'; - sCannotCreateADescendantOfTheSealedClass = 'Cannot create a descendant of the sealed class "%s"'; - sAncestorIsNotExternal = 'Ancestor "%s" is not external'; - sVirtualMethodXHasLowerVisibility = 'Virtual method "%s" has a lower visibility (%s) than parent class %s (%s)'; - sExternalClassInstanceCannotAccessStaticX = 'External class instance cannot access static %s'; - sXModifierMismatchY = '%s modifier "%s" mismatch'; - sSymbolCannotBePublished = 'Symbol cannot be published'; - sCannotTypecastAType = 'Cannot type cast a type'; - sTypeIdentifierExpected = 'Type identifier expected'; - sCannotNestAnonymousX = 'Cannot nest anonymous %s'; - sFoundCallCandidateX = 'Found call candidate %s'; - sSymbolXIsNotPortable = 'Symbol "%s" is not portable'; - sSymbolXIsExperimental = 'Symbol "%s" is experimental'; - sSymbolXIsNotImplemented = 'Symbol "%s" is implemented'; - sSymbolXBelongsToALibrary = 'Symbol "%s" belongs to a library'; - sSymbolXIsDeprecated = 'Symbol "%s" is deprecated'; - sSymbolXIsDeprecatedY = 'Symbol "%s" is deprecated: %s'; - sRangeCheckError = 'Range check error'; - sHighRangeLimitLTLowRangeLimit = 'High range limit < low range limit'; - type TResolverBaseType = ( btNone, // undefined @@ -578,20 +447,6 @@ type end; type - { TResolveData - base class for data stored in TPasElement.CustomData } - - TResolveData = Class(TPasElementBase) - private - FElement: TPasElement; - procedure SetElement(AValue: TPasElement); - public - Owner: TObject; // e.g. a TPasResolver - Next: TResolveData; // TPasResolver uses this for its memory chain - constructor Create; virtual; - destructor Destroy; override; - property Element: TPasElement read FElement write SetElement;// Element.CustomData=Self - end; - TResolveDataClass = class of TResolveData; { TUnresolvedPendingRef } @@ -956,86 +811,6 @@ type end; PPasResolvedElement = ^TPasResolverResult; - { TResEvalValue } - - TREVKind = ( - revkNone, - revkCustom, - revkNil, - revkBool, - revkInt, - revkUInt, - revkExtended, - revkString, - revkUnicodeString, - revkEnum, - revkSet - ); - TResEvalSimpleValue = record - case TREVKind of - revkBool: (Bool: boolean); - revkInt: (Int: int64); - revkUInt: (UInt: qword); - revkExtended: (Ext: extended); - end; - - TResEvalValue = class(TResolveData) - public - Kind: TREVKind; - Value: TResEvalSimpleValue; - IdentEl: TPasElement; - Expr: TPasExpr; - function Clone: TResEvalValue; virtual; - function AsString: string; virtual; - end; - TResEvalValueClass = class of TResEvalValue; - - { TResEvalString - Kind=revkComplex } - - TResEvalString = class(TResEvalValue) - public - S: String; - function Clone: TResEvalValue; override; - function AsString: string; override; - end; - - { TResEvalUTF16 - Kind=revkComplex } - - TResEvalUTF16 = class(TResEvalValue) - public - S: UnicodeString; - function Clone: TResEvalValue; override; - function AsString: string; override; - end; - - { TResEvalEnum - Kind=revkComplex, Value.Int, IdentEl is TPasEnumValue } - - TResEvalEnum = class(TResEvalValue) - public - function AsString: string; override; - end; - - TResEvalSetItem = record - RangeStart, RangeEnd: int64;// ToDo: qword - end; - TResEvalSetItems = array of TResEvalSetItem; - - { TResEvalSet - Kind=revkComplex, IdentEl is TPasEnumType } - - TResEvalSet = class(TResEvalValue) - public - Ranges: TResEvalSetItems; - function Clone: TResEvalValue; override; - function AsString: string; override; - end; - - TResEvalFlag = ( - refStore, // store result in CustomData - refConst, // computing a const, error is a value is not const - refSet // computing a set, allow ranges - ); - TResEvalFlags = set of TResEvalFlag; - type TPasResolverComputeFlag = ( rcSkipTypeAlias, @@ -1125,6 +900,8 @@ type FBaseTypeString: TResolverBaseType; FDefaultNameSpace: String; FDefaultScope: TPasDefaultScope; + FDynArrayMaxIndex: int64; + FDynArrayMinIndex: int64; FLastCreatedData: array[TResolveDataListKind] of TResolveData; FLastElement: TPasElement; FLastMsg: string; @@ -1303,7 +1080,13 @@ type function CheckRaiseTypeArgNo(id: int64; ArgNo: integer; Param: TPasExpr; const ParamResolved: TPasResolverResult; Expected: string; RaiseOnError: boolean): integer; protected - function Eval(Expr: TPasExpr; Flags: TResEvalFlags; ErrorEl: TPasElement = nil): TResEvalValue; + fExprEvaluator: TResExprEvaluator; + procedure OnExprEvalLog(Sender: TResExprEvaluator; const id: int64; + MsgType: TMessageType; MsgNumber: integer; const Fmt: String; + Args: array of const; PosEl: TPasElement); + function OnExprEvalIdentifier(Sender: TResExprEvaluator; + Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue; + function Eval(Expr: TPasExpr; Flags: TResEvalFlags; Store: boolean = true): TResEvalValue; protected // custom types (added by descendant resolvers) function CheckAssignCompatibilityCustom( @@ -1485,7 +1268,7 @@ type function CheckCallPropertyCompatibility(PropEl: TPasProperty; Params: TParamsExpr; RaiseOnError: boolean): integer; function CheckCallArrayCompatibility(ArrayEl: TPasArrayType; - Params: TParamsExpr; RaiseOnError: boolean): integer; + Params: TParamsExpr; RaiseOnError: boolean; EmitHints: boolean = false): integer; function CheckParamCompatibility(Expr: TPasExpr; Param: TPasArgument; ParamNo: integer; RaiseOnError: boolean; SetReferenceFlags: boolean = false): integer; function CheckAssignCompatibilityUserType( @@ -1585,6 +1368,8 @@ type property BaseTypeExtended: TResolverBaseType read FBaseTypeExtended write FBaseTypeExtended; property BaseTypeString: TResolverBaseType read FBaseTypeString write FBaseTypeString; property BaseTypeLength: TResolverBaseType read FBaseTypeLength write FBaseTypeLength; + property DynArrayMinIndex: int64 read FDynArrayMinIndex write FDynArrayMinIndex; + property DynArrayMaxIndex: int64 read FDynArrayMaxIndex write FDynArrayMaxIndex; // parsed values property DefaultNameSpace: String read FDefaultNameSpace; property RootElement: TPasModule read FRootElement; @@ -1610,7 +1395,6 @@ type property LastSourcePos: TPasSourcePos read FLastSourcePos write FLastSourcePos; end; -function GetObjName(o: TObject): string; function GetTreeDbg(El: TPasElement; Indent: integer = 0): string; function GetResolverResultDbg(const T: TPasResolverResult): string; function GetClassAncestorsDbg(El: TPasClassType): string; @@ -1626,8 +1410,6 @@ procedure SetResolverValueExpr(out ResolvedType: TPasResolverResult; BaseType: TResolverBaseType; TypeEl: TPasType; ExprEl: TPasExpr; Flags: TPasResolverResultFlags); overload; -procedure ReleaseEvalValue(var Value: TResEvalValue); - function ProcNeedsImplProc(Proc: TPasProcedure): boolean; function ChompDottedIdentifier(const Identifier: string): string; function FirstDottedIdentifier(const Identifier: string): string; @@ -1639,20 +1421,9 @@ function IsValidIdent(const Ident: string; AllowDots: Boolean = False; StrictDot function dbgs(const Flags: TPasResolverComputeFlags): string; overload; function dbgs(const a: TResolvedRefAccess): string; function dbgs(const Flags: TResolvedReferenceFlags): string; overload; -function dbgs(const Flags: TResEvalFlags): string; overload; implementation -function GetObjName(o: TObject): string; -begin - if o=nil then - Result:='nil' - else if o is TPasElement then - Result:=TPasElement(o).Name+':'+o.ClassName - else - Result:=o.ClassName; -end; - function GetTreeDbg(El: TPasElement; Indent: integer): string; procedure LineBreak(SubIndent: integer); @@ -1893,14 +1664,6 @@ begin ResolvedType.Flags:=Flags; end; -procedure ReleaseEvalValue(var Value: TResEvalValue); -begin - if Value=nil then exit; - if Value.Element<>nil then exit; - Value.Free; - Value:=nil; -end; - function ProcNeedsImplProc(Proc: TPasProcedure): boolean; begin Result:=true; @@ -2027,106 +1790,6 @@ begin Result:='['+Result+']'; end; -function dbgs(const Flags: TResEvalFlags): string; -var - s: string; - f: TResEvalFlag; -begin - Result:=''; - for f in Flags do - if f in Flags then - begin - if Result<>'' then Result:=Result+','; - str(f,s); - Result:=Result+s; - end; - Result:='['+Result+']'; -end; - -{ TResEvalEnum } - -function TResEvalEnum.AsString: string; -begin - Result:=inherited AsString+'='+IdentEl.Name+'='+IntToStr(Value.Int); -end; - -{ TResEvalSet } - -function TResEvalSet.Clone: TResEvalValue; -var - RS: TResEvalSet; - i: Integer; -begin - Result:=inherited Clone; - RS:=TResEvalSet(Result); - SetLength(RS.Ranges,length(Ranges)); - for i:=0 to length(Ranges)-1 do - RS.Ranges[i]:=Ranges[i]; -end; - -function TResEvalSet.AsString: string; -var - i: Integer; -begin - Result:=inherited AsString+'['; - for i:=0 to length(Ranges)-1 do - begin - if i>0 then Result:=Result+','; - Result:=Result+IntToStr(Ranges[i].RangeStart); - if Ranges[i].RangeStart<>Ranges[i].RangeEnd then - Result:=Result+'..'+IntToStr(Ranges[i].RangeEnd); - end; - Result:=Result+']'; -end; - -{ TResEvalUTF16 } - -function TResEvalUTF16.Clone: TResEvalValue; -begin - Result:=inherited Clone; - TResEvalUTF16(Result).S:=S; -end; - -function TResEvalUTF16.AsString: string; -begin - Result:=inherited AsString+'='''+String(S)+''''; -end; - -{ TResEvalString } - -function TResEvalString.Clone: TResEvalValue; -begin - Result:=inherited Clone; - TResEvalString(Result).S:=S; -end; - -function TResEvalString.AsString: string; -begin - Result:=inherited AsString+'='''+S+''''; -end; - -{ TResEvalValue } - -function TResEvalValue.Clone: TResEvalValue; -begin - Result:=TResEvalValueClass(ClassType).Create; - Result.Kind:=Kind; - Result.Value:=Value; - Result.IdentEl:=IdentEl; - Result.Expr:=Expr; -end; - -function TResEvalValue.AsString: string; -begin - str(Kind,Result); - case Kind of - revkBool: Result:=Result+'='+BoolToStr(Value.Bool,true); - revkInt: Result:=Result+'='+IntToStr(Value.Int); - revkUInt: Result:=Result+'='+IntToStr(Value.UInt); - revkExtended: Result:=Result+'='+FloatToStr(Value.Ext); - end; -end; - { TPasPropertyScope } destructor TPasPropertyScope.Destroy; @@ -2562,37 +2225,6 @@ begin Result:=false; end; -{ TResolveData } - -procedure TResolveData.SetElement(AValue: TPasElement); -begin - if FElement=AValue then Exit; - if Element<>nil then - Element.Release; - FElement:=AValue; - if Element<>nil then - Element.AddRef; -end; - -constructor TResolveData.Create; -begin - -end; - -destructor TResolveData.Destroy; -begin - {$IFDEF VerbosePasResolverMem} - writeln('TResolveData.Destroy START ',ClassName); - {$ENDIF} - Element:=nil; - Owner:=nil; - Next:=nil; - inherited Destroy; - {$IFDEF VerbosePasResolverMem} - writeln('TResolveData.Destroy END ',ClassName); - {$ENDIF} -end; - { TPasScope } class function TPasScope.IsStoredInElement: boolean; @@ -3729,7 +3361,7 @@ procedure TPasResolver.FinishConstRangeExpr(Left, Right: TPasExpr; out LeftResol RightResolved: TPasResolverResult); {$IFDEF EnablePasResRangeCheck} var - LeftValue, RightValue: TResEvalValue; + RgValue: TResEvalValue; {$ENDIF} begin {$IFDEF VerbosePasResEval} @@ -3741,61 +3373,8 @@ begin CheckSetLitElCompatible(Left,Right,LeftResolved,RightResolved); {$IFDEF EnablePasResRangeCheck} - // check value - LeftValue:=nil; - RightValue:=nil; - try - LeftValue:=Eval(Left,[refStore,refConst]); - RightValue:=Eval(Right,[refStore,refConst]); - {$IFDEF VerbosePasResEval} - writeln('TPasResolver.FinishConstRangeExpr Left=',LeftValue.AsString,' Right=',RightValue.AsString); - {$ENDIF} - case LeftValue.Kind of - revkInt,revkUInt: - begin - if not (RightValue.Kind in [revkInt,revkUInt]) then - RaiseRangeCheck(20170518222812,Right); - if LeftValue.Kind=revkInt then - begin - if RightValue.Kind=revkInt then - begin - if LeftValue.Value.Int>RightValue.Value.Int then - RaiseMsg(20170518222939,nHighRangeLimitLTLowRangeLimit, - sHighRangeLimitLTLowRangeLimit,[],Right); - end - else - begin - if LeftValue.Value.Int>RightValue.Value.UInt then - RaiseMsg(20170519000235,nHighRangeLimitLTLowRangeLimit, - sHighRangeLimitLTLowRangeLimit,[],Right); - end; - end - else - begin - if RightValue.Kind=revkInt then - begin - if LeftValue.Value.UInt>RightValue.Value.Int then - RaiseMsg(20170519000238,nHighRangeLimitLTLowRangeLimit, - sHighRangeLimitLTLowRangeLimit,[],Right); - end - else - begin - if LeftValue.Value.UInt>RightValue.Value.UInt then - RaiseMsg(20170519000240,nHighRangeLimitLTLowRangeLimit, - sHighRangeLimitLTLowRangeLimit,[],Right); - end; - end; - end; - else - {$IFDEF EnablePasResRangeCheck} - writeln('TPasResolver.FinishConstRangeExpr Left=',GetObjName(Left),' LeftValue.Kind=',LeftValue.Kind); - RaiseNotYetImplemented(20170518221103,Left); - {$ENDIF} - end; - finally - ReleaseEvalValue(LeftValue); - ReleaseEvalValue(RightValue); - end; + RgValue:=Eval(Left.Parent as TBinaryExpr,[refConst]); + ReleaseEvalValue(RgValue); {$ENDIF} end; @@ -6036,7 +5615,7 @@ begin begin if ResolvedValue.IdentEl is TPasType then RaiseMsg(20170216152215,nIllegalQualifier,sIllegalQualifier,['['],Params); - CheckCallArrayCompatibility(TPasArrayType(ResolvedValue.TypeEl),Params,true); + CheckCallArrayCompatibility(TPasArrayType(ResolvedValue.TypeEl),Params,true,true); for i:=0 to length(Params.Params)-1 do AccessExpr(Params.Params[i],rraRead); exit; @@ -7705,196 +7284,135 @@ begin Result:=cIncompatible; end; -function TPasResolver.Eval(Expr: TPasExpr; Flags: TResEvalFlags; - ErrorEl: TPasElement): TResEvalValue; -// Important: Caller must free result if (Result<>nil) and (Result.Element=nil) +procedure TPasResolver.OnExprEvalLog(Sender: TResExprEvaluator; + const id: int64; MsgType: TMessageType; MsgNumber: integer; + const Fmt: String; Args: array of const; PosEl: TPasElement); +begin + if MsgType<=mtError then + RaiseMsg(id,MsgNumber,Fmt,Args,PosEl) + else + LogMsg(id,MsgType,MsgNumber,Fmt,Args,PosEl); + if Sender=nil then ; +end; + +function TPasResolver.OnExprEvalIdentifier(Sender: TResExprEvaluator; + Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue; var - C: TClass; - Int: int64; - UInt: QWord; - Ext: Extended; - Code: integer; Ref: TResolvedReference; Decl: TPasElement; + C: TClass; + BaseTypeData: TResElDataBaseType; begin Result:=nil; - if Expr.CustomData is TResEvalValue then + if not (Expr.CustomData is TResolvedReference) then + RaiseNotYetImplemented(20170518203134,Expr); + Ref:=TResolvedReference(Expr.CustomData); + Decl:=Ref.Declaration; + C:=Decl.ClassType; + if C=TPasConst then begin - Result:=TResEvalValue(Expr.CustomData); - exit; - end; - if ErrorEl=nil then - ErrorEl:=Expr; - if (refStore in Flags) and (Expr.CustomData=nil) then - begin - Result:=Eval(Expr,Flags-[refStore],ErrorEl); - if Result.Element<>nil then - exit; // already stored - AddResolveData(Expr,Result,lkModule); - exit; - end; - - {$IFDEF VerbosePasResEval} - writeln('TPasResolver.Eval Expr=',GetObjName(Expr),' Flags=',dbgs(Flags)); - {$ENDIF} - C:=Expr.ClassType; - if C=TPrimitiveExpr then - begin - case TPrimitiveExpr(Expr).Kind of - pekIdent: + if (TPasConst(Decl).Expr<>nil) + and (TPasConst(Decl).IsConst or (TPasConst(Decl).VarType=nil)) then + begin + Result:=fExprEvaluator.Eval(TPasConst(Decl).Expr,Flags); + if Result<>nil then begin - if not (Expr.CustomData is TResolvedReference) then - RaiseNotYetImplemented(20170518203134,Expr); - Ref:=TResolvedReference(Expr.CustomData); - Decl:=Ref.Declaration; - C:=Decl.ClassType; - if C=TPasConst then - begin - if (TPasConst(Decl).Expr<>nil) - and (TPasConst(Decl).IsConst or (TPasConst(Decl).VarType=nil)) then - begin - Result:=Eval(TPasConst(Decl).Expr,Flags,ErrorEl); - Result.IdentEl:=Decl; - exit; - end; - if refConst in Flags then - RaiseConstantExprExp(20170518214928,ErrorEl); - end - else if Decl is TPasType then - begin - Decl:=ResolveAliasType(TPasType(Decl)); - C:=Decl.ClassType; - if C=TPasRangeType then - begin - if refSet in Flags then - begin - Result:=Eval(TPasRangeType(Decl).RangeExpr,Flags,ErrorEl); - Result.IdentEl:=Ref.Declaration; - exit; - end; - end; - end; - if refConst in Flags then - RaiseConstantExprExp(20170518213616,ErrorEl); - end; - pekNumber: - begin - // try int64 - val(TPrimitiveExpr(Expr).Value,Int,Code); - if Code=0 then - begin - Result:=TResEvalValue.Create; - Result.Kind:=revkInt; - Result.Value.Int:=Int; - Result.Expr:=Expr; - exit; - end; - // try qword - val(TPrimitiveExpr(Expr).Value,UInt,Code); - if Code=0 then - begin - Result:=TResEvalValue.Create; - Result.Kind:=revkUInt; - Result.Value.UInt:=UInt; - Result.Expr:=Expr; - exit; - end; - // try extended - val(TPrimitiveExpr(Expr).Value,Ext,Code); - if Code=0 then - begin - Result:=TResEvalValue.Create; - Result.Kind:=revkExtended; - Result.Value.Ext:=Ext; - Result.Expr:=Expr; - exit; - end; - RaiseRangeCheck(20170518202252,Expr); - end; - pekString: - begin - Result:=TResEvalString.Create; - Result.Kind:=revkString; - Result.Expr:=Expr; - TResEvalString(Result).S:=TPrimitiveExpr(Expr).Value; + Result.IdentEl:=Decl; exit; end; - else - RaiseNotYetImplemented(20170518200951,Expr); - end; - end - else if C=TNilExpr then - begin - Result:=TResEvalValue.Create; - Result.Kind:=revkNil; - Result.Expr:=Expr; - end - else if C=TBoolConstExpr then - begin - Result:=TResEvalValue.Create; - Result.Kind:=revkBool; - Result.Expr:=Expr; - Result.Value.Bool:=TBoolConstExpr(Expr).Value; - end - else if C=TUnaryExpr then - begin - Result:=Eval(TUnaryExpr(Expr).Operand,Flags,ErrorEl); - if Result=nil then exit; - case TUnaryExpr(Expr).OpCode of - eopAdd: ; - eopSubtract: - case Result.Kind of - revkInt: - begin - if Result.Value.Int=0 then exit; - if Result.Element<>nil then - Result:=Result.Clone; - Result.Value.Int:=-Result.Value.Int; - end; - revkUInt: - begin - if Result.Value.UInt=0 then exit; - if Result.Element<>nil then - Result:=Result.Clone; - Result.Value.UInt:=-Result.Value.UInt; - end - else - begin - if Result.Element=nil then - Result.Free; - RaiseNotYetImplemented(20170518230738,Expr); - end; - end; - eopNot: - case Result.Kind of - revkBool: - begin - if Result.Element<>nil then - Result:=Result.Clone; - Result.Value.Bool:=not Result.Value.Bool; - end - else - begin - if Result.Element=nil then - Result.Free; - RaiseNotYetImplemented(20170518232804,Expr); - end; - end; - eopAddress: - begin - if Result.Element=nil then - Result.Free; - // @ operator requires a compiler -> return nil - Result:=TResEvalString.Create; - Result.Kind:=revkNil; - Result.Expr:=Expr; - end - else - RaiseNotYetImplemented(20170518232823,Expr); end; + if refConst in Flags then + RaiseConstantExprExp(20170518214928,Expr); end - else if refConst in Flags then - RaiseConstantExprExp(20170518213800,ErrorEl); + else if C.InheritsFrom(TPasType) then + begin + Decl:=ResolveAliasType(TPasType(Decl)); + C:=Decl.ClassType; + if C=TPasRangeType then + begin + Result:=fExprEvaluator.Eval(TPasRangeType(Decl).RangeExpr,Flags); + if Result<>nil then + begin + Result.IdentEl:=Ref.Declaration; + exit; + end; + end + else if C=TPasUnresolvedSymbolRef then + begin + if (Decl.CustomData is TResElDataBaseType) then + begin + BaseTypeData:=TResElDataBaseType(Decl.CustomData); + case BaseTypeData.BaseType of + btChar: + begin + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikChar; + TResEvalRangeInt(Result).RangeStart:=0; + if BaseTypeChar=btChar then + TResEvalRangeInt(Result).RangeEnd:=$ff + else + TResEvalRangeInt(Result).RangeEnd:=$ffff; + end; + btAnsiChar: + begin + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikChar; + TResEvalRangeInt(Result).RangeStart:=0; + TResEvalRangeInt(Result).RangeEnd:=$ff + end; + btWideChar: + begin + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikChar; + TResEvalRangeInt(Result).RangeStart:=0; + TResEvalRangeInt(Result).RangeEnd:=$ffff; + end; + btBoolean,btByteBool,btWordBool,btQWordBool: + begin + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikBool; + TResEvalRangeInt(Result).RangeStart:=0; + TResEvalRangeInt(Result).RangeEnd:=1; + end; + btByte, + btShortInt, + btWord, + btSmallInt, + btLongWord, + btLongint, + btInt64, + btComp, + btIntSingle, + btUIntSingle, + btIntDouble, + btUIntDouble: + begin + Result:=TResEvalRangeInt.Create; + TResEvalRangeInt(Result).ElKind:=revrikInt; + GetIntegerRange(BaseTypeData.BaseType, + TResEvalRangeInt(Result).RangeStart,TResEvalRangeInt(Result).RangeEnd); + end; + end; + end; + end; + end; + if refConst in Flags then + RaiseConstantExprExp(20170518213616,Expr); +end; + +function TPasResolver.Eval(Expr: TPasExpr; Flags: TResEvalFlags; + Store: boolean): TResEvalValue; +// Important: Caller must free result if (Result<>nil) and (Result.Element=nil) +// use utility function ReleaseEvalValue(Result) +begin + Result:=fExprEvaluator.Eval(Expr,Flags); + if Result=nil then exit; + + if Store + and (Expr.CustomData=nil) + and (Result.Element=nil) + and (not fExprEvaluator.IsSimpleExpr(Expr)) then + AddResolveData(Expr,Result,lkModule); end; function TPasResolver.CheckAssignCompatibilityCustom(const LHS, @@ -8877,8 +8395,13 @@ begin FBaseTypeString:=btAnsiString; FBaseTypeExtended:=btDouble; FBaseTypeLength:=btInt64; + FDynArrayMinIndex:=0; + FDynArrayMaxIndex:=High(int64); FScopeClass_Class:=TPasClassScope; FScopeClass_WithExpr:=TPasWithExprScope; + fExprEvaluator:=TResExprEvaluator.Create; + fExprEvaluator.OnLog:=@OnExprEvalLog; + fExprEvaluator.OnEvalIdentifier:=@OnExprEvalIdentifier; PushScope(FDefaultScope); end; @@ -9549,6 +9072,7 @@ begin writeln('TPasResolver.Destroy FPendingForwards...'); {$ENDIF} FreeAndNil(FPendingForwards); + FreeAndNil(fExprEvaluator); inherited Destroy; {$IFDEF VerbosePasResolverMem} writeln('TPasResolver.Destroy END ',ClassName); @@ -10304,7 +9828,7 @@ begin end; function TPasResolver.CheckCallArrayCompatibility(ArrayEl: TPasArrayType; - Params: TParamsExpr; RaiseOnError: boolean): integer; + Params: TParamsExpr; RaiseOnError: boolean; EmitHints: boolean): integer; var ArgNo: Integer; Param: TPasExpr; @@ -10325,6 +9849,9 @@ var RangeResolved: TPasResolverResult; bt: TResolverBaseType; NextType: TPasType; + ParamValue: TResEvalValue; + RangeExpr: TPasExpr; + TypeFits: Boolean; begin ArgNo:=0; repeat @@ -10335,6 +9862,20 @@ begin if (not (rrfReadable in ParamResolved.Flags)) or not (ParamResolved.BaseType in btAllInteger) then exit(CheckRaiseTypeArgNo(20170216152417,ArgNo,Param,ParamResolved,'integer',RaiseOnError)); + if EmitHints then + begin + ParamValue:=Eval(Param,[refAutoConst]); + if ParamValue<>nil then + try // has const value -> check range + if (ParamValue.Kind<>revkInt) + or (TResEvalInt(ParamValue).IntDynArrayMaxIndex) then + fExprEvaluator.EmitRangeCheckConst(20170520202212,ParamValue.AsString, + DynArrayMinIndex,DynArrayMaxIndex,Param); + finally + ReleaseEvalValue(ParamValue); + end; + end; end else begin @@ -10342,7 +9883,8 @@ begin for DimNo:=0 to length(ArrayEl.Ranges)-1 do begin GetNextParam; - ComputeElement(ArrayEl.Ranges[DimNo],RangeResolved,[]); + RangeExpr:=ArrayEl.Ranges[DimNo]; + ComputeElement(RangeExpr,RangeResolved,[]); bt:=RangeResolved.BaseType; if bt=btRange then bt:=RangeResolved.SubType; @@ -10352,22 +9894,28 @@ begin RaiseIncompatibleTypeRes(20170216152421,nIncompatibleTypeArgNo, [IntToStr(ArgNo)],ParamResolved,RangeResolved,Param); end; + TypeFits:=false; if (bt in btAllBooleans) and (ParamResolved.BaseType in btAllBooleans) then - continue + TypeFits:=true else if (bt in btAllInteger) and (ParamResolved.BaseType in btAllInteger) then - continue + TypeFits:=true else if (bt in btAllChars) and (ParamResolved.BaseType in btAllChars) then - continue + TypeFits:=true else if (bt=btContext) and (ParamResolved.BaseType=btContext) then begin if (RangeResolved.TypeEl.ClassType=TPasEnumType) and (RangeResolved.TypeEl=ParamResolved.TypeEl) then - continue; + TypeFits:=true end; - // incompatible - if not RaiseOnError then exit(cIncompatible); - RaiseIncompatibleTypeRes(20170216152422,nIncompatibleTypeArgNo, - [IntToStr(ArgNo)],ParamResolved,RangeResolved,Param); + if not TypeFits then + begin + // incompatible + if not RaiseOnError then exit(cIncompatible); + RaiseIncompatibleTypeRes(20170216152422,nIncompatibleTypeArgNo, + [IntToStr(ArgNo)],ParamResolved,RangeResolved,Param); + end; + if EmitHints then + fExprEvaluator.IsInRange(Param,RangeExpr,true); end; end; if ArgNo=length(Params.Params) then exit(cExact); diff --git a/packages/fcl-passrc/src/pasuseanalyzer.pas b/packages/fcl-passrc/src/pasuseanalyzer.pas index a58020dda5..1d54b42d6f 100644 --- a/packages/fcl-passrc/src/pasuseanalyzer.pas +++ b/packages/fcl-passrc/src/pasuseanalyzer.pas @@ -49,7 +49,11 @@ unit PasUseAnalyzer; interface uses - Classes, SysUtils, AVL_Tree, PasResolver, PasTree, PScanner; + Classes, SysUtils, AVL_Tree, PasTree, PScanner, + {$IFDEF VerbosePasAnalyzer} + PasResolveEval + {$ENDIF} + PasResolver; const nPAUnitNotUsed = 5023; diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 5789b0e578..8cb0dfdc93 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -337,6 +337,7 @@ type function CurTokenText: String; Function CurComments : TStrings; function CurSourcePos: TPasSourcePos; + function HasToken: boolean; Function SavedComments : String; procedure NextToken; // read next non whitespace, non space procedure ChangeToken(tk: TToken); @@ -866,10 +867,23 @@ end; function TPasParser.CurSourcePos: TPasSourcePos; begin - if FTokenRingStart=FTokenRingEnd then - Result:=Default(TPasSourcePos) + if HasToken then + Result:=FTokenRing[FTokenRingCur].SourcePos else - Result:=FTokenRing[FTokenRingCur].SourcePos; + begin + if Scanner<>nil then + Result:=Scanner.CurSourcePos + else + Result:=Default(TPasSourcePos); + end; +end; + +function TPasParser.HasToken: boolean; +begin + if FTokenRingStart=FTokenRingStart) and (FTokenRingCur=FTokenRingStart) or (FTokenRingCur j', - PasResolver.nFunctionHeaderMismatchForwardVarName); + nFunctionHeaderMismatchForwardVarName); end; procedure TTestResolver.TestProcOverloadIsNotFunc; @@ -4441,7 +4463,7 @@ begin Add('procedure {#A_Impl}ProcA(i: longint);'); Add('begin'); Add('end;'); - CheckResolverException(sDuplicateIdentifier,PasResolver.nDuplicateIdentifier); + CheckResolverException(sDuplicateIdentifier,nDuplicateIdentifier); end; procedure TTestResolver.TestProcCallMissingParams; @@ -4453,7 +4475,7 @@ begin Add('begin'); Add(' Proc1;'); CheckResolverException('Wrong number of parameters specified for call to "Proc1"', - PasResolver.nWrongNumberOfParametersForCallTo); + nWrongNumberOfParametersForCallTo); end; procedure TTestResolver.TestProcArgDefaultValue; @@ -4475,7 +4497,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('Incompatible types: got "Longint" expected "String"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestProcPassConstToVar; @@ -4488,7 +4510,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('Variable identifier expected', - PasResolver.nVariableIdentifierExpected); + nVariableIdentifierExpected); end; procedure TTestResolver.TestBuiltInProcCallMissingParams; @@ -4497,7 +4519,7 @@ begin Add('begin'); Add(' length;'); CheckResolverException('Wrong number of parameters specified for call to "function Length(const String or Array): sizeint"', - PasResolver.nWrongNumberOfParametersForCallTo); + nWrongNumberOfParametersForCallTo); end; procedure TTestResolver.TestAssignFunctionResult; @@ -4528,7 +4550,7 @@ begin Add('begin'); Add(' {@i}i:={@P}P();'); CheckResolverException('Incompatible types: got "Procedure/Function" expected "Longint"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestFunctionResultInCondition; @@ -5081,7 +5103,7 @@ begin Add(' procedure ProcA;'); Add(' end;'); Add('begin'); - CheckResolverException(sForwardProcNotResolved,PasResolver.nForwardProcNotResolved); + CheckResolverException(sForwardProcNotResolved,nForwardProcNotResolved); end; procedure TTestResolver.TestClass_MethodUnresolvedUnit; @@ -5095,7 +5117,7 @@ begin Add(' procedure ProcA;'); Add(' end;'); Add('implementation'); - CheckResolverException(sForwardProcNotResolved,PasResolver.nForwardProcNotResolved); + CheckResolverException(sForwardProcNotResolved,nForwardProcNotResolved); end; procedure TTestResolver.TestClass_MethodAbstract; @@ -5117,7 +5139,7 @@ begin Add(' procedure ProcA; abstract;'); Add(' end;'); Add('begin'); - CheckResolverException('Invalid procedure modifier abstract without virtual',PasResolver.nInvalidXModifierY); + CheckResolverException('Invalid procedure modifier abstract without virtual',nInvalidXModifierY); end; procedure TTestResolver.TestClass_MethodAbstractHasBodyFail; @@ -5132,7 +5154,7 @@ begin Add('end;'); Add('begin'); CheckResolverException(sAbstractMethodsMustNotHaveImplementation, - PasResolver.nAbstractMethodsMustNotHaveImplementation); + nAbstractMethodsMustNotHaveImplementation); end; procedure TTestResolver.TestClass_MethodUnresolvedWithAncestor; @@ -5146,7 +5168,7 @@ begin Add(' procedure ProcA;'); Add(' end;'); Add('begin'); - CheckResolverException(sForwardProcNotResolved,PasResolver.nForwardProcNotResolved); + CheckResolverException(sForwardProcNotResolved,nForwardProcNotResolved); end; procedure TTestResolver.TestClass_ProcFuncMismatch; @@ -5160,7 +5182,8 @@ begin Add('begin'); Add('end;'); Add('begin'); - CheckResolverException('procedure expected, but function found',PasResolver.nXExpectedButYFound); + CheckResolverException('procedure expected, but function found', + nXExpectedButYFound); end; procedure TTestResolver.TestClass_MethodOverload; @@ -5200,7 +5223,7 @@ begin Add('begin'); Add('end;'); Add('begin'); - CheckResolverException(PasResolver.sDuplicateIdentifier,PasResolver.nDuplicateIdentifier); + CheckResolverException(sDuplicateIdentifier,nDuplicateIdentifier); end; procedure TTestResolver.TestClass_MethodOverride; @@ -5519,7 +5542,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('Abstract methods cannot be called directly', - PasResolver.nAbstractMethodsCannotBeCalledDirectly); + nAbstractMethodsCannotBeCalledDirectly); end; procedure TTestResolver.TestClassCallInheritedWithParamsAbstractFail; @@ -5538,7 +5561,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('Abstract methods cannot be called directly', - PasResolver.nAbstractMethodsCannotBeCalledDirectly); + nAbstractMethodsCannotBeCalledDirectly); end; procedure TTestResolver.TestClassCallInheritedConstructor; @@ -5706,7 +5729,7 @@ begin Add('begin'); Add(' if {@o}o is {@v}v then;'); CheckResolverException('class type expected, but class found', - PasResolver.nXExpectedButYFound); + nXExpectedButYFound); end; procedure TTestResolver.TestClass_OperatorAsOnNonDescendantFail; @@ -5722,7 +5745,7 @@ begin Add(' {#v}{=A}v: TClassA;'); Add('begin'); Add(' {@o}o:={@v}v as {@TObj}TObject;'); - CheckResolverException(sTypesAreNotRelated,PasResolver.nTypesAreNotRelated); + CheckResolverException(sTypesAreNotRelated,nTypesAreNotRelated); end; procedure TTestResolver.TestClass_OperatorAsOnNonTypeFail; @@ -5739,7 +5762,7 @@ begin Add('begin'); Add(' {@o}o:={@v}v as {@o}o;'); CheckResolverException('class expected, but o found', - PasResolver.nXExpectedButYFound); + nXExpectedButYFound); end; procedure TTestResolver.TestClassAsFuncResult; @@ -5833,7 +5856,7 @@ begin Add('begin'); Add(' {@vb}vb:=TClassB({@va}va);'); CheckResolverException('Illegal type conversion: "TClassA" to "class TClassB"', - PasResolver.nIllegalTypeConversionTo); + nIllegalTypeConversionTo); end; procedure TTestResolver.TestClass_TypeCastSelf; @@ -5874,7 +5897,7 @@ begin Add('begin'); Add(' o.i:=TObject(o,o).i;'); CheckResolverException('wrong number of parameters for type cast to TObject', - PasResolver.nWrongNumberOfParametersForTypeCast); + nWrongNumberOfParametersForTypeCast); end; procedure TTestResolver.TestClass_TypeCastAssign; @@ -5907,7 +5930,7 @@ begin Add('begin'); Add(' if TObject.i=7 then ;'); CheckResolverException(sCannotAccessThisMemberFromAX, - PasResolver.nCannotAccessThisMemberFromAX); + nCannotAccessThisMemberFromAX); end; procedure TTestResolver.TestClass_FuncReturningObjectMember; @@ -5937,7 +5960,7 @@ begin Add('procedure TObject.ProcA; begin end;'); Add('begin'); CheckResolverException('Invalid procedure modifier static', - PasResolver.nInvalidXModifierY); + nInvalidXModifierY); end; procedure TTestResolver.TestClass_SelfInStaticFail; @@ -5952,7 +5975,7 @@ begin Add(' if Self=nil then ;'); Add('end;'); Add('begin'); - CheckResolverException('identifier not found "Self"',PasResolver.nIdentifierNotFound); + CheckResolverException('identifier not found "Self"',nIdentifierNotFound); end; procedure TTestResolver.TestClass_PrivateProtectedInSameUnit; @@ -6009,7 +6032,7 @@ begin Add('begin'); Add(' if o.v=3 then ;'); CheckResolverException('Can''t access private member v', - PasResolver.nCantAccessPrivateMember); + nCantAccessPrivateMember); end; procedure TTestResolver.TestClass_PrivateInDescendantFail; @@ -6037,7 +6060,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('Can''t access private member v', - PasResolver.nCantAccessPrivateMember); + nCantAccessPrivateMember); end; procedure TTestResolver.TestClass_ProtectedInDescendant; @@ -6081,7 +6104,7 @@ begin Add('begin'); Add(' if o.v=3 then ;'); CheckResolverException('Can''t access strict private member v', - PasResolver.nCantAccessPrivateMember); + nCantAccessPrivateMember); end; procedure TTestResolver.TestClass_StrictProtectedInMainBeginFail; @@ -6096,7 +6119,7 @@ begin Add('begin'); Add(' if o.v=3 then ;'); CheckResolverException('Can''t access strict protected member v', - PasResolver.nCantAccessPrivateMember); + nCantAccessPrivateMember); end; procedure TTestResolver.TestClass_Constructor_NewInstance; @@ -6183,7 +6206,7 @@ begin Add('begin'); Add(' o:=o.Create; // normal call has no result -> fail'); CheckResolverException('Incompatible types: got "Procedure/Function" expected "TObject"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestClass_Destructor_FreeInstance; @@ -6794,7 +6817,7 @@ begin Add(' TCars = class of longint;'); Add('begin'); CheckResolverException('Incompatible types: got "Longint" expected "class"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestClassOfIsOperatorFail; @@ -6808,7 +6831,7 @@ begin Add('begin'); Add(' if cars is TCars then ;'); CheckResolverException('left side of is-operator expects a class, but got "class of" type', - PasResolver.nLeftSideOfIsOperatorExpectsAClassButGot); + nLeftSideOfIsOperatorExpectsAClassButGot); end; procedure TTestResolver.TestClassOfAsOperatorFail; @@ -6823,7 +6846,7 @@ begin Add(' cars: TCars;'); Add('begin'); Add(' cars:=cars as TCars;'); - CheckResolverException('illegal qualifier "as"',PasResolver.nIllegalQualifier); + CheckResolverException('illegal qualifier "as"',nIllegalQualifier); end; procedure TTestResolver.TestClassOfIsOperator; @@ -6901,7 +6924,7 @@ begin Add('begin'); Add(' oc.Id:=3;'); CheckResolverException(sCannotAccessThisMemberFromAX, - PasResolver.nCannotAccessThisMemberFromAX); + nCannotAccessThisMemberFromAX); end; procedure TTestResolver.TestClassOfDotClassProc; @@ -6961,7 +6984,7 @@ begin Add('begin'); Add(' oc.ProcA;'); CheckResolverException(sCannotAccessThisMemberFromAX, - PasResolver.nCannotAccessThisMemberFromAX); + nCannotAccessThisMemberFromAX); end; procedure TTestResolver.TestClassOfDotClassProperty; @@ -7008,7 +7031,7 @@ begin Add('begin'); Add(' if oc.A=3 then ;'); CheckResolverException(sCannotAccessThisMemberFromAX, - PasResolver.nCannotAccessThisMemberFromAX); + nCannotAccessThisMemberFromAX); end; procedure TTestResolver.TestClass_ClassProcSelf; @@ -7048,7 +7071,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('Illegal type conversion: "Self" to "class TObject"', - PasResolver.nIllegalTypeConversionTo); + nIllegalTypeConversionTo); end; procedure TTestResolver.TestClass_ClassMembers; @@ -7285,7 +7308,7 @@ begin Add(' FB: longint;'); Add(' end;'); Add('begin'); - CheckResolverException('identifier not found "FB"',PasResolver.nIdentifierNotFound); + CheckResolverException('identifier not found "FB"',nIdentifierNotFound); end; procedure TTestResolver.TestPropertyReadAccessorVarWrongType; @@ -7298,7 +7321,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Incompatible types: got "Longint" expected "String"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestPropertyReadAccessorProcNotFunc; @@ -7310,7 +7333,7 @@ begin Add(' property B: longint read GetB;'); Add(' end;'); Add('begin'); - CheckResolverException('function expected, but procedure found',PasResolver.nXExpectedButYFound); + CheckResolverException('function expected, but procedure found',nXExpectedButYFound); end; procedure TTestResolver.TestPropertyReadAccessorFuncWrongResult; @@ -7323,7 +7346,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('function result Longint expected, but String found', - PasResolver.nXExpectedButYFound); + nXExpectedButYFound); end; procedure TTestResolver.TestPropertyReadAccessorFuncWrongArgCount; @@ -7336,7 +7359,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Wrong number of parameters specified for call to "GetB"', - PasResolver.nWrongNumberOfParametersForCallTo); + nWrongNumberOfParametersForCallTo); end; procedure TTestResolver.TestPropertyReadAccessorFunc; @@ -7367,7 +7390,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Incompatible types: got "Longint" expected "String"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestPropertyWriteAccessorFuncNotProc; @@ -7379,7 +7402,7 @@ begin Add(' property B: longint write SetB;'); Add(' end;'); Add('begin'); - CheckResolverException('procedure expected, but function found',PasResolver.nXExpectedButYFound); + CheckResolverException('procedure expected, but function found',nXExpectedButYFound); end; procedure TTestResolver.TestPropertyWriteAccessorProcWrongArgCount; @@ -7392,7 +7415,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Wrong number of parameters specified for call to "SetB"', - PasResolver.nWrongNumberOfParametersForCallTo); + nWrongNumberOfParametersForCallTo); end; procedure TTestResolver.TestPropertyWriteAccessorProcWrongArg; @@ -7405,7 +7428,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Incompatible type arg no. 1: Got "var", expected "const"', - PasResolver.nIncompatibleTypeArgNo); + nIncompatibleTypeArgNo); end; procedure TTestResolver.TestPropertyWriteAccessorProcWrongArgType; @@ -7418,7 +7441,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Incompatible type arg no. 1: Got "String", expected "Longint"', - PasResolver.nIncompatibleTypeArgNo); + nIncompatibleTypeArgNo); end; procedure TTestResolver.TestPropertyWriteAccessorProc; @@ -7468,8 +7491,8 @@ begin Add(' property B;'); Add(' end;'); Add('begin'); - CheckResolverException(PasResolver.sNoPropertyFoundToOverride, - PasResolver.nNoPropertyFoundToOverride); + CheckResolverException(sNoPropertyFoundToOverride, + nNoPropertyFoundToOverride); end; procedure TTestResolver.TestPropertyStoredAccessor; @@ -7498,7 +7521,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Incompatible types: got "Longint" expected "Boolean"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestPropertyStoredAccessorProcNotFunc; @@ -7511,7 +7534,7 @@ begin Add(' property B: longint read FB stored GetB;'); Add(' end;'); Add('begin'); - CheckResolverException('function expected, but procedure found',PasResolver.nXExpectedButYFound); + CheckResolverException('function expected, but procedure found',nXExpectedButYFound); end; procedure TTestResolver.TestPropertyStoredAccessorFuncWrongResult; @@ -7525,7 +7548,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('function: boolean expected, but function:String found', - PasResolver.nXExpectedButYFound); + nXExpectedButYFound); end; procedure TTestResolver.TestPropertyStoredAccessorFuncWrongArgCount; @@ -7539,7 +7562,7 @@ begin Add(' end;'); Add('begin'); CheckResolverException('Wrong number of parameters specified for call to "GetB"', - PasResolver.nWrongNumberOfParametersForCallTo); + nWrongNumberOfParametersForCallTo); end; procedure TTestResolver.TestPropertyArgs1; @@ -7654,7 +7677,7 @@ begin Add('begin'); Add(' obj.Items[3]:=4;'); CheckResolverException('Incompatible type arg no. 1: Got "Longint", expected "String"', - PasResolver.nIncompatibleTypeArgNo); + nIncompatibleTypeArgNo); end; procedure TTestResolver.TestProperty_Option_ClassPropertyNonStatic; @@ -7715,7 +7738,7 @@ begin Add('begin'); Add(' if o[5]=6 then;'); CheckResolverException('illegal qualifier "["', - PasResolver.nIllegalQualifier); + nIllegalQualifier); end; procedure TTestResolver.TestPropertyAssign; @@ -7750,7 +7773,7 @@ begin Add(' o: TObject;'); Add('begin'); Add(' o.B:=3;'); - CheckResolverException('No member is provided to access property',PasResolver.nPropertyNotWritable); + CheckResolverException('No member is provided to access property',nPropertyNotWritable); end; procedure TTestResolver.TestProperty_PassAsParam; @@ -7793,7 +7816,7 @@ begin Add(' o: TObject;'); Add('begin'); Add(' if o.B=3 then;'); - CheckResolverException('not readable',PasResolver.nNotReadable); + CheckResolverException('not readable',nNotReadable); end; procedure TTestResolver.TestWithBlock1; @@ -8433,6 +8456,51 @@ begin CheckResolverException('Variable identifier expected',nVariableIdentifierExpected); end; +procedure TTestResolver.TestArrayIntRange_OutOfRange; +begin + StartProgram(false); + Add([ + 'type TArr = array[1..2] of longint;', + 'var a: TArr;', + 'begin', + ' a[0]:=3;', + '']); + ParseProgram; + CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax, + 'range check error while evaluating constants (0 must be between 1 and 2)'); + CheckResolverUnexpectedHints; +end; + +procedure TTestResolver.TestArrayEnumRange_OutOfRange; +begin + StartProgram(false); + Add([ + 'type', + ' TEnum = (red,blue);', + ' TArr = array[TEnum] of longint;', + 'var a: TArr;', + 'begin', + ' a[red]:=3;', + '']); + ParseProgram; + CheckResolverUnexpectedHints; +end; + +procedure TTestResolver.TestArrayCharRange_OutOfRange; +begin + StartProgram(false); + Add([ + 'type TArr = array[''a''..''b''] of longint;', + 'var a: TArr;', + 'begin', + ' a[''0'']:=3;', + '']); + ParseProgram; + CheckResolverHint(mtWarning,nRangeCheckEvaluatingConstantsVMinMax, + 'range check error while evaluating constants (''0'' must be between ''a'' and ''b'')'); + CheckResolverUnexpectedHints; +end; + procedure TTestResolver.TestProcTypesAssignObjFPC; begin StartProgram(false); @@ -8749,7 +8817,7 @@ begin Add('begin'); Add(' n:=@ProcA;'); CheckResolverException('procedure type modifier "of Object" mismatch', - PasResolver.nXModifierMismatchY); + nXModifierMismatchY); end; procedure TTestResolver.TestAssignMethodToProcFail; @@ -8768,7 +8836,7 @@ begin Add('begin'); Add(' n:=@o.ProcA;'); CheckResolverException('procedure type modifier "of Object" mismatch', - PasResolver.nXModifierMismatchY); + nXModifierMismatchY); end; procedure TTestResolver.TestAssignProcToFunctionFail; @@ -8783,7 +8851,7 @@ begin Add(' p:=@ProcA;'); CheckResolverException( 'Incompatible types: got "procedure type" expected "function type"', - PasResolver.nIncompatibleTypesGotExpected); + nIncompatibleTypesGotExpected); end; procedure TTestResolver.TestAssignProcWrongArgsFail; @@ -8797,7 +8865,7 @@ begin Add('begin'); Add(' p:=@ProcA;'); CheckResolverException('Incompatible type arg no. 1: Got "Longint", expected "String"', - PasResolver.nIncompatibleTypeArgNo); + nIncompatibleTypeArgNo); end; procedure TTestResolver.TestAssignProcWrongArgAccessFail; @@ -8811,7 +8879,7 @@ begin Add('begin'); Add(' p:=@ProcA;'); CheckResolverException('Incompatible type arg no. 1: Got "access modifier const", expected "default"', - PasResolver.nIncompatibleTypeArgNo); + nIncompatibleTypeArgNo); end; procedure TTestResolver.TestProcType_AssignNestedProcFail; @@ -8829,7 +8897,7 @@ begin Add('end;'); Add('begin'); CheckResolverException('procedure type modifier "is nested" mismatch', - PasResolver.nXModifierMismatchY); + nXModifierMismatchY); end; procedure TTestResolver.TestArrayOfProc; diff --git a/packages/fcl-passrc/tests/tcuseanalyzer.pas b/packages/fcl-passrc/tests/tcuseanalyzer.pas index 2a234fe2b7..7b709a2b0b 100644 --- a/packages/fcl-passrc/tests/tcuseanalyzer.pas +++ b/packages/fcl-passrc/tests/tcuseanalyzer.pas @@ -9,9 +9,8 @@ unit tcuseanalyzer; interface uses - Classes, SysUtils, fpcunit, - PasTree, PScanner, PasResolver, - tcbaseparser, testregistry, strutils, tcresolver, PasUseAnalyzer; + Classes, SysUtils, fpcunit, PasTree, PScanner, PasResolver, tcbaseparser, + testregistry, strutils, tcresolver, PasUseAnalyzer, PasResolveEval; type diff --git a/packages/fcl-passrc/tests/testpassrc.lpr b/packages/fcl-passrc/tests/testpassrc.lpr index 204c4ca3b9..ad8ebc9031 100644 --- a/packages/fcl-passrc/tests/testpassrc.lpr +++ b/packages/fcl-passrc/tests/testpassrc.lpr @@ -6,7 +6,7 @@ uses Classes, consoletestrunner, tcscanner, tctypeparser, tcstatements, tcbaseparser, tcmoduleparser, tconstparser, tcvarparser, tcclasstype, tcexprparser, tcprocfunc, tcpassrcutil, tcresolver, tcgenerics, - tcuseanalyzer; + tcuseanalyzer, pasresolveeval; type