1 {
2 This file is part of the Free Component Library
3
4 Pascal source parser
5 Copyright (c) 2017 by Mattias Gaertner, mattias@freepascal.org
6
7 See the file COPYING.FPC, included in this distribution,
8 for details about the copyright.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
13
14 **********************************************************************
15
16 Abstract:
17 Evaluation of Pascal constants.
18
19 Works:
20 - Emitting range check warnings
21 - Error on overflow
22 - bool:
23 - not, =, <>, and, or, xor, low(), high(), pred(), succ(), ord()
24 - boolean(0), boolean(1)
25 - int/uint
26 - unary +, -
27 - binary: +, -, *, div, mod, ^^, =, <>, <, >, <=, >=, and, or, xor, not, shl, shr
28 - Low(), High(), Pred(), Succ(), Ord(), Lo(), Hi()
29 - typecast longint(-1), word(-2), intsingle(-1), uintsingle(1)
30 - float:
31 - typecast single(double), double(single), float(integer)
32 - +, -, /, *, =, <>, <, >, <=, >=
33 - string:
34 - #65, '', 'a', 'ab'
35 - +, =, <>, <, >, <=, >=
36 - pred(), succ(), chr(), ord(), low(char), high(char)
37 - s[]
38 - length(string)
39 - #$DC00
40 - unicodestring
41 - enum
42 - ord(), low(), high(), pred(), succ()
43 - typecast enumtype(integer)
44 - set of enum, set of char, set of bool, set of int
45 - [a,b,c..d]
46 - +, -, *, ><, =, <>, >=, <=, in
47 - error on duplicate in const set
48 - arrays
49 - length()
50 - array of int, charm enum, bool
51
52 ToDo:
53 - arrays
54 - [], [a..b], multi dim [a,b], concat with +
55 - array of record
56 - array of string
57 - error on: array[1..2] of longint = (1,2,3);
58 - anonymous enum range: type f=(a,b,c,d); g=b..c;
59 }
60 unit PasResolveEval;
61
62 {$mode objfpc}{$H+}
63
64 {$ifdef fpc}
65 {$define UsePChar}
66 {$endif}
67
68 {$IFOPT Q+}{$DEFINE OverflowCheckOn}{$ENDIF}
69 {$IFOPT R+}{$DEFINE RangeCheckOn}{$ENDIF}
70
71 interface
72
73 uses
74 Sysutils, Classes, Math, PasTree, PScanner;
75
76 // message numbers
77 const
78 nIdentifierNotFound = 3001;
79 nNotYetImplemented = 3002;
80 nIllegalQualifier = 3003;
81 nSyntaxErrorExpectedButFound = 3004;
82 nWrongNumberOfParametersForCallTo = 3005;
83 nIncompatibleTypeArgNo = 3006;
84 nIncompatibleTypeArgNoVarParamMustMatchExactly = 3007;
85 nVariableIdentifierExpected = 3008;
86 nDuplicateIdentifier = 3009;
87 nXExpectedButYFound = 3010;
88 nAncestorCycleDetected = 3011;
89 nCantUseForwardDeclarationAsAncestor = 3012;
90 nCantDetermineWhichOverloadedFunctionToCall = 3013;
91 nForwardTypeNotResolved = 3014;
92 nForwardProcNotResolved = 3015;
93 nInvalidXModifierY = 3016;
94 nAbstractMethodsMustNotHaveImplementation = 3017;
95 nCallingConventionMismatch = 3018;
96 nResultTypeMismatchExpectedButFound = 3019;
97 nFunctionHeaderMismatchForwardVarName = 3020;
98 nFunctionHidesIdentifier_NonVirtualMethod = 3021;
99 nNoMethodInAncestorToOverride = 3022;
100 nInheritedOnlyWorksInMethods = 3023;
101 nInheritedNeedsAncestor = 3024;
102 nNoPropertyFoundToOverride = 3025;
103 nExprTypeMustBeClassOrRecordTypeGot = 3026;
104 nPropertyNotWritable = 3027;
105 nIncompatibleTypesGotExpected = 3028;
106 nTypesAreNotRelatedXY = 3029;
107 nAbstractMethodsCannotBeCalledDirectly = 3030;
108 nMissingParameterX = 3031;
109 nInstanceMemberXInaccessible = 3032;
110 nInOperatorExpectsSetElementButGot = 3033;
111 nWrongNumberOfParametersForTypeCast = 3034;
112 nIllegalTypeConversionTo = 3035;
113 nConstantExpressionExpected = 3036;
114 nLeftSideOfIsOperatorExpectsAClassButGot = 3037;
115 nNotReadable = 3038;
116 nClassPropertyAccessorMustBeStatic = 3039;
117 nClassPropertyAccessorMustNotBeStatic = 3040;
118 nOnlyOneDefaultPropertyIsAllowed = 3041;
119 nWrongNumberOfParametersForArray = 3042;
120 nCantAssignValuesToAnAddress = 3043;
121 nIllegalExpression = 3044;
122 nCantAccessXMember = 3045;
123 nMustBeInsideALoop = 3046;
124 nExpectXArrayElementsButFoundY = 3047;
125 nCannotCreateADescendantOfTheSealedXY = 3048;
126 nAncestorIsNotExternal = 3049;
127 nPropertyMustHaveReadOrWrite = 3050;
128 nExternalClassInstanceCannotAccessStaticX = 3051;
129 nXModifierMismatchY = 3052;
130 nSymbolCannotBePublished = 3053;
131 nCannotTypecastAType = 3054;
132 nTypeIdentifierExpected = 3055;
133 nCannotNestAnonymousX = 3056;
134 nFoundCallCandidateX = 3057;
135 nTextAfterFinalIgnored = 3058;
136 nNoMemberIsProvidedToAccessProperty = 3059;
137 nTheUseOfXisNotAllowedInARecord = 3060;
138 nParameterlessConstructorsNotAllowedInRecords = 3061;
139 nMultipleXinTypeYNameZCAandB = 3062;
140 nXCannotHaveParameters = 3063;
141 nRangeCheckError = 3064;
142 nHighRangeLimitLTLowRangeLimit = 3065;
143 nRangeCheckEvaluatingConstantsVMinMax = 3066;
144 nIllegalChar = 3067;
145 nOverflowInArithmeticOperation = 3068;
146 nDivByZero = 3069;
147 nRangeCheckInSetConstructor = 3070;
148 nIncompatibleTypesGotParametersExpected = 3071;
149 nAddingIndexSpecifierRequiresNewX = 3072;
150 nCantFindUnitX = 3073;
151 nCannotFindEnumeratorForType = 3074;
152 nPreviousDeclMissesOverload = 3075;
153 nOverloadedProcMissesOverload = 3076;
154 nMethodHidesMethodOfBaseType = 3077;
155 nContextExpectedXButFoundY = 3078;
156 nContextXInvalidY = 3079;
157 nIdentifierXIsNotAnInstanceField = 3080;
158 nXIsNotSupported = 3081;
159 nOperatorIsNotOverloadedAOpB = 3082;
160 nIllegalQualifierAfter = 3084;
161 nIllegalQualifierInFrontOf = 3085;
162 nIllegalQualifierWithin = 3086;
163 nClassXNotFoundInThisModule = 3087;
164 nClassMethodsMustBeStaticInX = 3088;
165 nCannotMixMethodResolutionAndDelegationAtX = 3089;
166 nImplementsDoesNotSupportArrayProperty = 3101;
167 nImplementsDoesNotSupportIndex = 3102;
168 nImplementsUsedOnUnimplIntf = 3103;
169 nDuplicateImplementsForIntf = 3103;
170 nImplPropMustHaveReadSpec = 3104;
171 nDoesNotImplementInterface = 3105;
172 nTypeCycleFound = 3106;
173 nTypeXIsNotYetCompletelyDefined = 3107;
174 nDuplicateCaseValueXatY = 3108;
175 nMissingFieldsX = 3109;
176 nCantAssignValuesToConstVariable = 3110;
177 nIllegalAssignmentToForLoopVar = 3111;
178 nFunctionHidesIdentifier_NonProc = 3112;
179 nTypeXCannotBeExtendedByATypeHelper = 3113;
180 nTypeXCannotBeExtendedByARecordHelper = 3114;
181 nDerivedXMustExtendASubClassY = 3115;
182 nDefaultPropertyNotAllowedInHelperForX = 3116;
183 nHelpersCannotBeUsedAsTypes = 3117;
184 nMessageHandlersInvalidParams = 3118;
185 nImplictConversionUnicodeToAnsi = 3119;
186 nWrongTypeXInArrayConstructor = 3120;
187 nUnknownCustomAttributeX = 3121;
188 nAttributeIgnoredBecauseAbstractX = 3122;
189 nCreatingAnInstanceOfAbstractClassY = 3123;
190 nIllegalExpressionAfterX = 3124;
191 nMethodHidesNonVirtualMethodExactly = 3125;
192 nDuplicatePublishedMethodXAtY = 3126;
193 nConstraintXSpecifiedMoreThanOnce = 3127;
194 nConstraintXAndConstraintYCannotBeTogether = 3128;
195 nXIsNotAValidConstraint = 3129;
196 nWrongNumberOfParametersForGenericX = 3130;
197 nGenericsWithoutSpecializationAsType = 3131;
198 nDeclOfXDiffersFromPrevAtY = 3132;
199 nTypeParamXIsMissingConstraintY = 3133;
200 nTypeParamXIsNotCompatibleWithY = 3134;
201 nTypeParamXMustSupportIntfY = 3135;
202 nTypeParamsNotAllowedOnX = 3136;
203 nXMethodsCannotHaveTypeParams = 3137;
204 nImplMustNotRepeatConstraints = 3138;
205 nCouldNotInferTypeArgXForMethodY = 3139;
206 nInferredTypeXFromDiffArgsMismatchFromMethodY = 3140;
207 nParamOfThisTypeCannotHaveDefVal = 3141;
208 nClassTypesAreNotRelatedXY = 3142;
209 nDirectiveXNotAllowedHere = 3143;
210
211 // using same IDs as FPC
212 nVirtualMethodXHasLowerVisibility = 3250; // was 3050
213 nConstructingClassXWithAbstractMethodY = 4046; // was 3080
214 nNoMatchingImplForIntfMethodXFound = 5042; // was 3088
215 nSymbolXIsDeprecated = 5043; // was 3062
216 nSymbolXBelongsToALibrary = 5065; // was 3061
217 nSymbolXIsDeprecatedY = 5066; // 3063
218 nSymbolXIsNotPortable = 5076; // was 3058
219 nSymbolXIsNotImplemented = 5078; // was 3060
220 nSymbolXIsExperimental = 5079; // was 3059
221
222 // resourcestring patterns of messages
223 resourcestring
224 sIdentifierNotFound = 'identifier not found "%s"';
225 sNotYetImplemented = 'not yet implemented: %s';
226 sIllegalQualifier = 'illegal qualifier "%s"';
227 sSyntaxErrorExpectedButFound = 'Syntax error, "%s" expected but "%s" found';
228 sWrongNumberOfParametersForCallTo = 'Wrong number of parameters specified for call to "%s"';
229 sIncompatibleTypeArgNo = 'Incompatible type arg no. %s: Got "%s", expected "%s"';
230 sIncompatibleTypeArgNoVarParamMustMatchExactly = 'Incompatible type arg no. %s: Got "%s", expected "%s". Var param must match exactly.';
231 sVariableIdentifierExpected = 'Variable identifier expected';
232 sDuplicateIdentifier = 'Duplicate identifier "%s" at %s';
233 sXExpectedButYFound = '%s expected, but %s found';
234 sAncestorCycleDetected = 'Ancestor cycle detected';
235 sCantUseForwardDeclarationAsAncestor = 'Can''t use forward declaration "%s" as ancestor';
236 sCantDetermineWhichOverloadedFunctionToCall = 'Can''t determine which overloaded function to call';
237 sForwardTypeNotResolved = 'Forward type not resolved "%s"';
238 sForwardProcNotResolved = 'Forward %s not resolved "%s"';
239 sInvalidXModifierY = 'Invalid %s modifier %s';
240 sAbstractMethodsMustNotHaveImplementation = 'Abstract method must not have an implementation.';
241 sCallingConventionMismatch = 'Calling convention mismatch';
242 sResultTypeMismatchExpectedButFound = 'Result type mismatch, expected %s, but found %s';
243 sFunctionHeaderMismatchForwardVarName = 'function header "%s" doesn''t match forward : var name changes %s => %s';
244 sFunctionHidesIdentifier = 'function hides identifier at "%s". Use overload or reintroduce';
245 sNoMethodInAncestorToOverride = 'There is no method in an ancestor class to be overridden "%s"';
246 sInheritedOnlyWorksInMethods = 'Inherited works only in methods';
247 sInheritedNeedsAncestor = 'inherited needs an ancestor';
248 sNoPropertyFoundToOverride = 'No property found to override';
249 sExprTypeMustBeClassOrRecordTypeGot = 'Expression type must be class or record type, got %s';
250 sPropertyNotWritable = 'No member is provided to access property';
251 sIncompatibleTypesGotExpected = 'Incompatible types: got "%s" expected "%s"';
252 sTypesAreNotRelatedXY = 'Types are not related: "%s" and "%s"';
253 sAbstractMethodsCannotBeCalledDirectly = 'Abstract methods cannot be called directly';
254 sMissingParameterX = 'Missing parameter %s';
255 sInstanceMemberXInaccessible = 'Instance member "%s" inaccessible here';
256 sInOperatorExpectsSetElementButGot = 'the in-operator expects a set element, but got %s';
257 sWrongNumberOfParametersForTypeCast = 'wrong number of parameters for type cast to %s';
258 sIllegalTypeConversionTo = 'Illegal type conversion: "%s" to "%s"';
259 sConstantExpressionExpected = 'Constant expression expected';
260 sLeftSideOfIsOperatorExpectsAClassButGot = 'left side of is-operator expects a class, but got "%s"';
261 sNotReadable = 'not readable';
262 sClassPropertyAccessorMustBeStatic = 'class property accessor must be static';
263 sClassPropertyAccessorMustNotBeStatic = 'class property accessor must not be static';
264 sOnlyOneDefaultPropertyIsAllowed = 'Only one default property is allowed';
265 sWrongNumberOfParametersForArray = 'Wrong number of parameters for array';
266 sCantAssignValuesToAnAddress = 'Can''t assign values to an address';
267 sIllegalExpression = 'Illegal expression';
268 sCantAccessXMember = 'Can''t access %s member %s';
269 sMustBeInsideALoop = '%s must be inside a loop';
270 sExpectXArrayElementsButFoundY = 'Expect %s array elements, but found %s';
271 sCannotCreateADescendantOfTheSealedXY = 'Cannot create a descendant of the sealed %s "%s"';
272 sAncestorIsNotExternal = 'Ancestor "%s" is not external';
273 sPropertyMustHaveReadOrWrite = 'Property must have read or write accessor';
274 sVirtualMethodXHasLowerVisibility = 'Virtual method "%s" has a lower visibility (%s) than parent class %s (%s)';
275 sExternalClassInstanceCannotAccessStaticX = 'External class instance cannot access static %s';
276 sXModifierMismatchY = '%s modifier "%s" mismatch';
277 sSymbolCannotBePublished = 'Symbol cannot be published';
278 sCannotTypecastAType = 'Cannot type cast a type';
279 sTypeIdentifierExpected = 'Type identifier expected';
280 sCannotNestAnonymousX = 'Cannot nest anonymous %s';
281 sFoundCallCandidateX = 'Found call candidate %s';
282 sTextAfterFinalIgnored = 'Text after final ''end.''. ignored by compiler';
283 sNoMemberIsProvidedToAccessProperty = 'No member is provided to access property';
284 sTheUseOfXisNotAllowedInARecord = 'The use of "%s" is not allowed in a record';
285 sParameterlessConstructorsNotAllowedInRecords = 'Parameterless constructors are not allowed in records or record/type helpers';
286 sMultipleXinTypeYNameZCAandB = 'Multiple %s in %s %s: %s and %s';
287 sXCannotHaveParameters = '%s cannot have parameters';
288 sSymbolXIsNotPortable = 'Symbol "%s" is not portable';
289 sSymbolXIsExperimental = 'Symbol "%s" is experimental';
290 sSymbolXIsNotImplemented = 'Symbol "%s" is not implemented';
291 sSymbolXBelongsToALibrary = 'Symbol "%s" belongs to a library';
292 sSymbolXIsDeprecated = 'Symbol "%s" is deprecated';
293 sSymbolXIsDeprecatedY = 'Symbol "%s" is deprecated: %s';
294 sRangeCheckError = 'Range check error';
295 sHighRangeLimitLTLowRangeLimit = 'High range limit < low range limit';
296 sRangeCheckEvaluatingConstantsVMinMax = 'range check error while evaluating constants (%s is not between %s and %s)';
297 sIllegalChar = 'Illegal character';
298 sOverflowInArithmeticOperation = 'Overflow in arithmetic operation';
299 sDivByZero = 'Division by zero';
300 sRangeCheckInSetConstructor = 'range check error in set constructor or duplicate set element';
301 sIncompatibleTypesGotParametersExpected = 'Incompatible types, got %s parameters, expected %s';
302 sAddingIndexSpecifierRequiresNewX = 'adding index specifier requires new "%s" specifier';
303 sCantFindUnitX = 'can''t find unit "%s"';
304 sCannotFindEnumeratorForType = 'Cannot find an enumerator for the type "%s"';
305 sPreviousDeclMissesOverload = 'Previous declaration of "%s" at %s was not marked with "overload" directive';
306 sOverloadedProcMissesOverload = 'Overloaded procedure misses "overload" directive. Previous declaration is at %s';
307 sMethodHidesMethodOfBaseType = 'Method "%s" hides method of base type "%s" at %s';
308 sContextExpectedXButFoundY = '%s: expected "%s", but found "%s"';
309 sContextXInvalidY = '%s: invalid %s';
310 sIdentifierXIsNotAnInstanceField = 'Identifier "%s" is not an instance field';
311 sConstructingClassXWithAbstractMethodY = 'Constructing a class "%s" with abstract method "%s"';
312 sXIsNotSupported = '%s is not supported';
313 sOperatorIsNotOverloadedAOpB = 'Operator is not overloaded: "%s" %s "%s"';
314 sIllegalQualifierAfter = 'illegal qualifier "%s" after "%s"';
315 sIllegalQualifierInFrontOf = 'illegal qualifier "%s" in front of "%s"';
316 sIllegalQualifierWithin = 'illegal qualifier "%s" within "%s"';
317 sClassXNotFoundInThisModule = 'class "%s" not found in this module';
318 sNoMatchingImplForIntfMethodXFound = 'No matching implementation for interface method "%s" found';
319 sClassMethodsMustBeStaticInX = 'Class methods must be static in %s';
320 sCannotMixMethodResolutionAndDelegationAtX = 'Cannot mix method resolution and delegation at %s';
321 sImplementsDoesNotSupportArrayProperty = '"implements" does dot support array property';
322 sImplementsDoesNotSupportIndex = '"implements" does not support "index"';
323 sImplementsUsedOnUnimplIntf = 'Implements-property used on unimplemented interface: "%"';
324 sDuplicateImplementsForIntf = 'Duplicate implements for interface "%s" at %s';
325 sImplPropMustHaveReadSpec = 'Implements-property must have read specifier';
326 sDoesNotImplementInterface = '"%s" does not implement interface "%s"';
327 sTypeCycleFound = 'Type cycle found';
328 sTypeXIsNotYetCompletelyDefined = 'type "%s" is not yet completely defined';
329 sDuplicateCaseValueXatY = 'Duplicate case value "%s", other at %s';
330 sMissingFieldsX = 'Missing fields: "%s"';
331 sCantAssignValuesToConstVariable = 'Can''t assign values to const variable';
332 sIllegalAssignmentToForLoopVar = 'Illegal assignment to for-loop variable "%s"';
333 sTypeXCannotBeExtendedByATypeHelper = 'Type "%s" cannot be extended by a type helper';
334 sTypeXCannotBeExtendedByARecordHelper = 'Type "%s" cannot be extended by a record helper';
335 sDerivedXMustExtendASubClassY = 'Derived %s must extend a subclass of "%s" or the class itself';
336 sDefaultPropertyNotAllowedInHelperForX = 'Default property not allowed in helper for %s';
337 sHelpersCannotBeUsedAsTypes = 'helpers cannot be used as types';
338 sMessageHandlersInvalidParams = 'Message handlers can take only one call by ref. parameter';
339 sImplictConversionUnicodeToAnsi = 'Implicit string type conversion with potential data loss from "UnicodeString" to "AnsiString"';
340 sWrongTypeXInArrayConstructor = 'Wrong type "%s" in array constructor';
341 sUnknownCustomAttributeX = 'Unknown custom attribute "%s"';
342 sAttributeIgnoredBecauseAbstractX = 'attribute ignored because abstract %s';
343 sCreatingAnInstanceOfAbstractClassY = 'Creating an instance of abstract class "%s"';
344 sIllegalExpressionAfterX = 'illegal expression after %s';
345 sMethodHidesNonVirtualMethodExactly = 'method hides identifier at "%s". Use reintroduce';
346 sDuplicatePublishedMethodXAtY = 'Duplicate published method "%s" at %s';
347 sConstraintXSpecifiedMoreThanOnce = 'Constraint "%s" specified more than once';
348 sConstraintXAndConstraintYCannotBeTogether = '"%s" constraint and "%s" constraint cannot be specified together';
349 sXIsNotAValidConstraint = '"%s" is not a valid constraint';
350 sWrongNumberOfParametersForGenericX = 'wrong number of parameters for generic %s';
351 sGenericsWithoutSpecializationAsType = 'Generics without specialization cannot be used as a type for a %s';
352 sDeclOfXDiffersFromPrevAtY = 'Declaration of "%s" differs from previous declaration at %s';
353 sTypeParamXIsMissingConstraintY = 'Type parameter "%s" is missing constraint "%s"';
354 sTypeParamXIsNotCompatibleWithY = 'Type parameter "%s" is not compatible with type "%s"';
355 sTypeParamXMustSupportIntfY = 'Type parameter "%s" must support interface "%s"';
356 sTypeParamsNotAllowedOnX = 'Type parameters not allowed on %s';
357 sXMethodsCannotHaveTypeParams = '%s methods cannot have type parameters';
358 sImplMustNotRepeatConstraints = 'Implementations must not repeat constraints';
359 sCouldNotInferTypeArgXForMethodY = 'Could not infer generic type argument "%s" for method "%s"';
360 sInferredTypeXFromDiffArgsMismatchFromMethodY = 'Inferred type "%s" from different arguments mismatch for method "%s"';
361 sParamOfThisTypeCannotHaveDefVal = 'Parameters of this type cannot have default values';
362 sClassTypesAreNotRelatedXY = 'Class types "%s" and "%s" are not related';
363 sDirectiveXNotAllowedHere = 'Directive "%s" not allowed here';
364
365 type
366 { TResolveData - base class for data stored in TPasElement.CustomData }
367
368 TResolveData = Class(TPasElementBase)
369 private
370 FElement: TPasElement;
371 procedure SetElement(AValue: TPasElement);
372 public
373 Owner: TObject; // e.g. a TPasResolver
374 Next: TResolveData; // TPasResolver uses this for its memory chain
375 constructor Create; virtual;
376 destructor Destroy; override;
377 property Element: TPasElement read FElement write SetElement;// Element.CustomData=Self
378 end;
379 TResolveDataClass = class of TResolveData;
380
381 type
382 {$ifdef pas2js}
383 TMaxPrecInt = nativeint;
384 TMaxPrecUInt = NativeUInt;
385 TMaxPrecFloat = double;
386 {$else}
387 TMaxPrecInt = int64;
388 TMaxPrecUInt = qword;
389 TMaxPrecFloat = extended;
390 {$endif}
391 TMaxPrecCurrency = currency;
392
393 {$ifdef fpc}
394 PMaxPrecInt = ^TMaxPrecInt;
395 PMaxPrecUInt = ^TMaxPrecUInt;
396 PMaxPrecFloat = ^TMaxPrecFloat;
397 PMaxPrecCurrency = ^TMaxPrecCurrency;
398 {$endif}
399 const
400 // Note: when FPC compares int64 with qword it converts the qword to an int64,
401 // possibly resulting in a range check error -> using a qword const instead
402 HighIntAsUInt = TMaxPrecUInt(High(TMaxPrecInt));
403
404 const
405 MinSafeIntCurrency = -922337203685477; // .5808
406 MaxSafeIntCurrency = 922337203685477; // .5807
407 MinSafeIntSingle = -16777216;
408 MaxSafeIntSingle = 16777216;
409 MaskUIntSingle = $3fffff;
410 MinSafeIntDouble = -$1fffffffffffff; // -9007199254740991 54 bits (52 plus signed bit plus implicit highest bit)
411 MaxSafeIntDouble = $1fffffffffffff; // 9007199254740991
412 MaskUIntDouble = $1fffffffffffff;
413
414 type
415 { TResEvalValue }
416
417 TREVKind = (
418 revkNone,
419 revkCustom,
420 revkNil, // TResEvalValue
421 revkBool, // TResEvalBool
422 revkInt, // TResEvalInt
423 revkUInt, // TResEvalUInt
424 revkFloat, // TResEvalFloat
425 revkCurrency, // TResEvalCurrency
426 {$ifdef FPC_HAS_CPSTRING}
427 revkString, // TResEvalString rawbytestring
428 {$endif}
429 revkUnicodeString, // TResEvalUTF16
430 revkEnum, // TResEvalEnum
431 revkRangeInt, // TResEvalRangeInt: range of enum, int, char, widechar, e.g. 1..2
432 revkRangeUInt, // TResEvalRangeUInt: range of uint, e.g. 1..2
433 revkSetOfInt, // set of enum, int, char, widechar, e.g. [1,2..3]
434 revkExternal // TResEvalExternal: an external const
435 );
436 const
437 revkAllStrings = [{$ifdef FPC_HAS_CPSTRING}revkString,{$endif}revkUnicodeString];
438 type
439 TResEvalValue = class(TResolveData)
440 public
441 Kind: TREVKind;
442 IdentEl: TPasElement;
443 // Note: "Element" is used when the TResEvalValue is stored as CustomData of an Element
444 constructor CreateKind(const aKind: TREVKind);
Clonenull445 function Clone: TResEvalValue; virtual;
AsDebugStringnull446 function AsDebugString: string; virtual;
AsStringnull447 function AsString: string; virtual;
448 end;
449 TResEvalValueClass = class of TResEvalValue;
450
451 { TResEvalBool }
452
453 TResEvalBool = class(TResEvalValue)
454 public
455 B: boolean;
456 constructor Create; override;
457 constructor CreateValue(const aValue: boolean);
Clonenull458 function Clone: TResEvalValue; override;
AsStringnull459 function AsString: string; override;
460 end;
461
462 TResEvalTypedInt = (
463 reitNone,
464 reitByte,
465 reitShortInt,
466 reitWord,
467 reitSmallInt,
468 reitUIntSingle,
469 reitIntSingle,
470 reitLongWord,
471 reitLongInt,
472 reitUIntDouble,
473 reitIntDouble);
474 TResEvalTypedInts = set of TResEvalTypedInt;
475
476 const
477 reitDefaults = [reitNone,reitByte,reitShortInt,reitWord,reitSmallInt,reitLongWord,reitLongInt];
478 reitAllSigned = [reitNone,reitShortInt,reitSmallInt,reitIntSingle,reitLongInt,reitIntDouble];
479 reitAllUnsigned = [reitByte,reitWord,reitUIntSingle,reitLongWord,reitUIntDouble];
480
481 reitLow: array[TResEvalTypedInt] of TMaxPrecInt = (
482 low(TMaxPrecInt), // reitNone,
483 low(Byte), // reitByte,
484 low(ShortInt), // reitShortInt,
485 low(Word), // reitWord,
486 low(SmallInt), // reitSmallInt,
487 0, // reitUIntSingle,
488 MinSafeIntSingle, // reitIntSingle,
489 low(LongWord), // reitLongWord,
490 low(LongInt), // reitLongInt,
491 0, // reitUIntDouble,
492 MinSafeIntDouble // reitIntDouble)
493 );
494 reitHigh: array[TResEvalTypedInt] of TMaxPrecInt = (
495 high(TMaxPrecInt), // reitNone,
496 high(Byte), // reitByte,
497 high(ShortInt), // reitShortInt,
498 high(Word), // reitWord,
499 high(SmallInt), // reitSmallInt,
500 MaxSafeIntSingle, // reitUIntSingle,
501 MaxSafeIntSingle, // reitIntSingle,
502 high(LongWord), // reitLongWord,
503 high(LongInt), // reitLongInt,
504 MaxSafeIntDouble, // reitUIntDouble,
505 MaxSafeIntDouble // reitIntDouble)
506 );
507
508 type
509 { TResEvalInt }
510
511 TResEvalInt = class(TResEvalValue)
512 public
513 Int: TMaxPrecInt;
514 Typed: TResEvalTypedInt;
515 constructor Create; override;
516 constructor CreateValue(const aValue: TMaxPrecInt);
517 constructor CreateValue(const aValue: TMaxPrecInt; aTyped: TResEvalTypedInt);
Clonenull518 function Clone: TResEvalValue; override;
AsStringnull519 function AsString: string; override;
AsDebugStringnull520 function AsDebugString: string; override;
521 end;
522
523 { TResEvalUInt }
524
525 TResEvalUInt = class(TResEvalValue)
526 public
527 UInt: TMaxPrecUInt;
528 constructor Create; override;
529 constructor CreateValue(const aValue: TMaxPrecUInt);
Clonenull530 function Clone: TResEvalValue; override;
AsStringnull531 function AsString: string; override;
532 end;
533
534 { TResEvalFloat }
535
536 TResEvalFloat = class(TResEvalValue)
537 public
538 FloatValue: TMaxPrecFloat;
539 constructor Create; override;
540 constructor CreateValue(const aValue: TMaxPrecFloat);
Clonenull541 function Clone: TResEvalValue; override;
AsStringnull542 function AsString: string; override;
IsIntnull543 function IsInt(out Int: TMaxPrecInt): boolean;
544 end;
545
546 { TResEvalCurrency }
547
548 TResEvalCurrency = class(TResEvalValue)
549 public
550 Value: TMaxPrecCurrency;
551 constructor Create; override;
552 constructor CreateValue(const aValue: TMaxPrecCurrency);
Clonenull553 function Clone: TResEvalValue; override;
AsStringnull554 function AsString: string; override;
IsIntnull555 function IsInt(out Int: TMaxPrecInt): boolean;
AsIntnull556 function AsInt: TMaxPrecInt; // value * 10.000
557 end;
558
559 {$ifdef FPC_HAS_CPSTRING}
560 { TResEvalString - Kind=revkString }
561
562 TResEvalString = class(TResEvalValue)
563 public
564 S: RawByteString;
565 constructor Create; override;
566 constructor CreateValue(const aValue: RawByteString);
Clonenull567 function Clone: TResEvalValue; override;
AsStringnull568 function AsString: string; override;
569 end;
570 {$endif}
571
572 { TResEvalUTF16 - Kind=revkUnicodeString }
573
574 TResEvalUTF16 = class(TResEvalValue)
575 public
576 S: UnicodeString;
577 constructor Create; override;
578 constructor CreateValue(const aValue: UnicodeString);
Clonenull579 function Clone: TResEvalValue; override;
AsStringnull580 function AsString: string; override;
581 end;
582
583 { TResEvalEnum - Kind=revkEnum, Value.Int }
584
585 TResEvalEnum = class(TResEvalValue)
586 public
587 Index: integer; // Beware: might be outside TPasEnumType
588 ElType: TPasEnumType; // TPasEnumType
589 constructor Create; override;
590 constructor CreateValue(const aValue: integer; aIdentEl: TPasEnumValue);
GetEnumValuenull591 function GetEnumValue: TPasEnumValue;
GetEnumNamenull592 function GetEnumName: String;
Clonenull593 function Clone: TResEvalValue; override;
AsDebugStringnull594 function AsDebugString: string; override;
AsStringnull595 function AsString: string; override;
596 end;
597
598 TRESetElKind = (
599 revskNone,
600 revskEnum, // ElType is TPasEnumType
601 revskInt,
602 revskChar,
603 revskBool
604 );
605
606 { TResEvalRangeInt - Kind=revkRangeInt }
607
608 TResEvalRangeInt = class(TResEvalValue)
609 public
610 ElKind: TRESetElKind;
611 RangeStart, RangeEnd: TMaxPrecInt;
612 ElType: TPasType; // revskEnum: TPasEnumType
613 constructor Create; override;
614 constructor CreateValue(const aElKind: TRESetElKind; aElType: TPasType;
615 const aRangeStart, aRangeEnd: TMaxPrecInt); virtual;
Clonenull616 function Clone: TResEvalValue; override;
AsStringnull617 function AsString: string; override;
AsDebugStringnull618 function AsDebugString: string; override;
ElementAsStringnull619 function ElementAsString(El: TMaxPrecInt): string; virtual;
620 end;
621
622 { TResEvalRangeUInt }
623
624 TResEvalRangeUInt = class(TResEvalValue)
625 public
626 RangeStart, RangeEnd: TMaxPrecUInt;
627 constructor Create; override;
628 constructor CreateValue(const aRangeStart, aRangeEnd: TMaxPrecUInt);
Clonenull629 function Clone: TResEvalValue; override;
AsStringnull630 function AsString: string; override;
631 end;
632
633 { TResEvalSet - Kind=revkSetOfInt }
634
635 TResEvalSet = class(TResEvalRangeInt)
636 public
637 const MaxCount = $ffff;
638 type
639 TItem = record
640 RangeStart, RangeEnd: TMaxPrecInt;
641 end;
642 TItems = array of TItem;
643 public
644 Ranges: TItems; // disjunct, sorted ascending
645 constructor Create; override;
646 constructor CreateEmpty(const aElKind: TRESetElKind; aElType: TPasType = nil);
647 constructor CreateEmptySameKind(aSet: TResEvalSet);
648 constructor CreateValue(const aElKind: TRESetElKind; aElType: TPasType;
649 const aRangeStart, aRangeEnd: TMaxPrecInt); override;
Clonenull650 function Clone: TResEvalValue; override;
AsStringnull651 function AsString: string; override;
Addnull652 function Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean; // false if duplicate ignored
IndexOfRangenull653 function IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean = false): integer;
Intersectsnull654 function Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer; // returns index of first intersecting range
655 procedure ConsistencyCheck;
656 end;
657
658 { TResEvalExternal }
659
660 TResEvalExternal = class(TResEvalValue)
661 public
662 constructor Create; override;
Clonenull663 function Clone: TResEvalValue; override;
AsStringnull664 function AsString: string; override;
665 end;
666
667 TResEvalFlag = (
668 refConst, // computing a const, error if a value is not const
669 refConstExt, // as refConst, except allow external const
670 refAutoConst, // set refConst if in a const
671 refAutoConstExt // set refConstExt if in a const
672 );
673 TResEvalFlags = set of TResEvalFlag;
674
675 TResExprEvaluator = class;
676
677 TPasResEvalLogHandler = procedure(Sender: TResExprEvaluator; const id: TMaxPrecInt;
678 MsgType: TMessageType; MsgNumber: integer;
679 const Fmt: String; Args: Array of {$ifdef pas2js}jsvalue{$else}const{$endif}; PosEl: TPasElement) of object;
endernull680 TPasResEvalIdentHandler = function(Sender: TResExprEvaluator;
681 Expr: TPrimitiveExpr; Flags: TResEvalFlags): TResEvalValue of object;
endernull682 TPasResEvalParamsHandler = function(Sender: TResExprEvaluator;
683 Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue of object;
684 TPasResEvalRangeCheckElHandler = procedure(Sender: TResExprEvaluator;
685 El: TPasElement; var MsgType: TMessageType) of object;
686
687 { TResExprEvaluator }
688
689 TResExprEvaluator = class
690 private
691 FAllowedInts: TResEvalTypedInts;
692 {$ifdef FPC_HAS_CPSTRING}
693 FDefaultEncoding: TSystemCodePage;
694 {$endif}
695 FOnEvalIdentifier: TPasResEvalIdentHandler;
696 FOnEvalParams: TPasResEvalParamsHandler;
697 FOnLog: TPasResEvalLogHandler;
698 FOnRangeCheckEl: TPasResEvalRangeCheckElHandler;
699 protected
700 procedure LogMsg(const id: TMaxPrecInt; MsgType: TMessageType; MsgNumber: integer;
701 const Fmt: String; Args: Array of {$ifdef pas2js}jsvalue{$else}const{$endif}; PosEl: TPasElement); overload;
702 procedure RaiseMsg(const Id: TMaxPrecInt; MsgNumber: integer; const Fmt: String;
703 Args: Array of {$ifdef pas2js}jsvalue{$else}const{$endif}; ErrorPosEl: TPasElement);
704 procedure RaiseNotYetImplemented(id: TMaxPrecInt; El: TPasElement; Msg: string = ''); virtual;
705 procedure RaiseInternalError(id: TMaxPrecInt; const Msg: string = '');
706 procedure RaiseConstantExprExp(id: TMaxPrecInt; ErrorEl: TPasElement);
707 procedure RaiseRangeCheck(id: TMaxPrecInt; ErrorEl: TPasElement);
708 procedure RaiseOverflowArithmetic(id: TMaxPrecInt; ErrorEl: TPasElement);
709 procedure RaiseDivByZero(id: TMaxPrecInt; ErrorEl: TPasElement);
EvalUnaryExprnull710 function EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags): TResEvalValue;
EvalBinaryExprnull711 function EvalBinaryExpr(Expr: TBinaryExpr; Flags: TResEvalFlags): TResEvalValue;
EvalBinaryRangeExprnull712 function EvalBinaryRangeExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryAddExprnull713 function EvalBinaryAddExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinarySubExprnull714 function EvalBinarySubExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryMulExprnull715 function EvalBinaryMulExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryDivideExprnull716 function EvalBinaryDivideExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryDivExprnull717 function EvalBinaryDivExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryModExprnull718 function EvalBinaryModExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryPowerExprnull719 function EvalBinaryPowerExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryShiftExprnull720 function EvalBinaryShiftExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryBoolOpExprnull721 function EvalBinaryBoolOpExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryNEqualExprnull722 function EvalBinaryNEqualExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryLessGreaterExprnull723 function EvalBinaryLessGreaterExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinaryInExprnull724 function EvalBinaryInExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalBinarySymmetricaldifferenceExprnull725 function EvalBinarySymmetricaldifferenceExpr(Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
EvalParamsExprnull726 function EvalParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
EvalArrayParamsExprnull727 function EvalArrayParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalValue;
EvalSetParamsExprnull728 function EvalSetParamsExpr(Expr: TParamsExpr; Flags: TResEvalFlags): TResEvalSet;
EvalSetExprnull729 function EvalSetExpr(Expr: TPasExpr; ExprArray: TPasExprArray; Flags: TResEvalFlags): TResEvalSet;
EvalArrayValuesExprnull730 function EvalArrayValuesExpr(Expr: TArrayValues; Flags: TResEvalFlags): TResEvalSet;
EvalPrimitiveExprStringnull731 function EvalPrimitiveExprString(Expr: TPrimitiveExpr): TResEvalValue; virtual;
732 procedure PredBool(Value: TResEvalBool; ErrorEl: TPasElement);
733 procedure SuccBool(Value: TResEvalBool; ErrorEl: TPasElement);
734 procedure PredInt(Value: TResEvalInt; ErrorEl: TPasElement);
735 procedure SuccInt(Value: TResEvalInt; ErrorEl: TPasElement);
736 procedure PredUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
737 procedure SuccUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
738 {$ifdef FPC_HAS_CPSTRING}
739 procedure PredString(Value: TResEvalString; ErrorEl: TPasElement);
740 procedure SuccString(Value: TResEvalString; ErrorEl: TPasElement);
741 {$endif}
742 procedure PredUnicodeString(Value: TResEvalUTF16; ErrorEl: TPasElement);
743 procedure SuccUnicodeString(Value: TResEvalUTF16; ErrorEl: TPasElement);
744 procedure PredEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
745 procedure SuccEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
CreateResEvalIntnull746 function CreateResEvalInt(UInt: TMaxPrecUInt): TResEvalValue; virtual;
747 public
748 constructor Create;
Evalnull749 function Eval(Expr: TPasExpr; Flags: TResEvalFlags): TResEvalValue;
IsInRangenull750 function IsInRange(Expr, RangeExpr: TPasExpr; EmitHints: boolean): boolean;
IsInRangenull751 function IsInRange(Value: TResEvalValue; ValueExpr: TPasExpr;
752 RangeValue: TResEvalValue; RangeExpr: TPasExpr; EmitHints: boolean): boolean;
IsSetCompatiblenull753 function IsSetCompatible(Value: TResEvalValue; ValueExpr: TPasExpr;
754 RangeValue: TResEvalValue; EmitHints: boolean): boolean;
IsConstnull755 function IsConst(Expr: TPasExpr): boolean;
IsSimpleExprnull756 function IsSimpleExpr(Expr: TPasExpr): boolean; // true = no need to store result
757 procedure EmitRangeCheckConst(id: TMaxPrecInt; const aValue, MinVal, MaxVal: String;
758 PosEl: TPasElement; MsgType: TMessageType = mtWarning); virtual;
759 procedure EmitRangeCheckConst(id: TMaxPrecInt; const aValue: String;
760 MinVal, MaxVal: TMaxPrecInt; PosEl: TPasElement; MsgType: TMessageType = mtWarning);
ChrValuenull761 function ChrValue(Value: TResEvalValue; ErrorEl: TPasElement): TResEvalValue; virtual;
OrdValuenull762 function OrdValue(Value: TResEvalValue; ErrorEl: TPasElement): TResEvalValue; virtual;
StringToOrdnull763 function StringToOrd(Value: TResEvalValue; PosEl: TPasElement): longword; virtual;
764 procedure PredValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
765 procedure SuccValue(Value: TResEvalValue; ErrorEl: TPasElement); virtual;
EvalStrFuncnull766 function EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags): TResEvalValue; virtual;
EvalStringAddExprnull767 function EvalStringAddExpr(Expr, LeftExpr, RightExpr: TPasExpr;
768 LeftValue, RightValue: TResEvalValue): TResEvalValue; virtual;
LoHiValuenull769 function LoHiValue(Value: TResEvalValue; ShiftSize: Integer; Mask: LongWord;
770 ErrorEl: TPasElement): TResEvalValue; virtual;
EnumTypeCastnull771 function EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
772 Flags: TResEvalFlags): TResEvalEnum; virtual;
773 {$ifdef FPC_HAS_CPSTRING}
CheckValidUTF8null774 function CheckValidUTF8(const s: RawByteString; ErrorEl: TPasElement): boolean;
GetCodePagenull775 function GetCodePage(const s: RawByteString): TSystemCodePage;
GetRawByteStringnull776 function GetRawByteString(const s: UnicodeString; CodePage: TSystemCodePage; ErrorEl: TPasElement): RawByteString;
GetUTF8Strnull777 function GetUTF8Str(const s: RawByteString; ErrorEl: TPasElement): String;
GetUnicodeStrnull778 function GetUnicodeStr(const s: RawByteString; ErrorEl: TPasElement): UnicodeString;
GetWideCharnull779 function GetWideChar(const s: RawByteString; out w: WideChar): boolean;
780 {$endif}
781 property OnLog: TPasResEvalLogHandler read FOnLog write FOnLog;
782 property OnEvalIdentifier: TPasResEvalIdentHandler read FOnEvalIdentifier write FOnEvalIdentifier;
783 property OnEvalParams: TPasResEvalParamsHandler read FOnEvalParams write FOnEvalParams;
784 property OnRangeCheckEl: TPasResEvalRangeCheckElHandler read FOnRangeCheckEl write FOnRangeCheckEl;
785 property AllowedInts: TResEvalTypedInts read FAllowedInts write FAllowedInts;
786 {$ifdef FPC_HAS_CPSTRING}
787 property DefaultStringCodePage: TSystemCodePage read FDefaultEncoding write FDefaultEncoding;
788 {$endif}
789 end;
790 TResExprEvaluatorClass = class of TResExprEvaluator;
791
792 procedure ReleaseEvalValue(var Value: TResEvalValue);
NumberIsFloatnull793 function NumberIsFloat(const Value: string): boolean;
794
795 {$ifdef FPC_HAS_CPSTRING}
RawStrToCaptionnull796 function RawStrToCaption(const r: RawByteString; MaxLength: integer): string;
797 {$endif}
UnicodeStrToCaptionnull798 function UnicodeStrToCaption(const u: UnicodeString; MaxLength: integer): Unicodestring;
CodePointToStringnull799 function CodePointToString(CodePoint: longword): String;
CodePointToUnicodeStringnull800 function CodePointToUnicodeString(u: longword): UnicodeString;
801
GetObjNamenull802 function GetObjName(o: TObject): string;
GetObjPathnull803 function GetObjPath(o: TObject): string;
GetGenericParamCommasnull804 function GetGenericParamCommas(Cnt: integer): string;
GetElementNameAndParamsnull805 function GetElementNameAndParams(El: TPasElement; MaxLvl: integer = 3): string;
GetTypeParamNamesnull806 function GetTypeParamNames(Templates: TFPList; MaxLvl: integer = 3): string;
dbgsnull807 function dbgs(const Flags: TResEvalFlags): string; overload;
dbgsnull808 function dbgs(v: TResEvalValue): string; overload;
LastPosnull809 function LastPos(c: char; const s: string): sizeint;
810
811 implementation
812
813 procedure ReleaseEvalValue(var Value: TResEvalValue);
814 begin
815 if Value=nil then exit;
816 if Value.Element<>nil then exit;
817 Value.{$ifdef pas2js}Destroy{$else}Free{$endif};
818 Value:=nil;
819 end;
820
NumberIsFloatnull821 function NumberIsFloat(const Value: string): boolean;
822 var
823 i: Integer;
824 begin
825 if Value='' then exit(false);
826 if Value[1] in ['$','%','&'] then exit(false);
827 for i:=2 to length(Value) do
828 if Value[i] in ['.','E','e'] then exit(true);
829 Result:=false;
830 end;
831
832 {$ifdef FPC_HAS_CPSTRING}
RawStrToCaptionnull833 function RawStrToCaption(const r: RawByteString; MaxLength: integer): string;
834 var
835 s: RawByteString;
836 p: PAnsiChar;
837 InLit: boolean;
838 Len: integer;
839
840 procedure AddHash(o: integer);
841 var
842 h: String;
843 begin
844 if (Result<>'') and InLit then
845 begin
846 Result:=Result+'''';
847 inc(Len);
848 InLit:=false;
849 end;
850 h:='#'+IntToStr(o);
851 inc(Len,length(h));
852 if Len<=MaxLength then
853 Result:=Result+h;
854 end;
855
856 procedure AddLit(const Lit: string; CaptionLen: integer);
857 begin
858 if not InLit then
859 begin
860 Result:=Result+'''';
861 inc(Len);
862 InLit:=true;
863 end;
864 Result:=Result+Lit;
865 inc(Len,CaptionLen);
866 end;
867
868 var
869 l: SizeInt;
870 CP: TSystemCodePage;
871 EndP: PAnsiChar;
872 begin
873 Result:='';
874 s:=r;
875 CP:=StringCodePage(s);
876 if (CP<>CP_ACP) and (CP<>CP_UTF8) then
877 SetCodePage(s, CP_ACP, true);
878 p:=PAnsiChar(s);
879 EndP:=p+length(s);
880 Len:=0;
881 InLit:=false;
882 while Len<MaxLength do
883 case p^ of
884 #0:
885 begin
886 if p-PAnsiChar(s)=length(s) then
887 break;
888 AddHash(0);
889 inc(p);
890 end;
891 '''':
892 begin
893 AddLit('''''',2);
894 inc(p);
895 end;
896 #1..#31,#127..#192:
897 begin
898 AddHash(ord(p^));
899 inc(p);
900 end
901 else
902 begin
903 l:=Utf8CodePointLen(p,EndP-p,true);
904 if l<=0 then
905 begin
906 // invalid
907 AddHash(ord(p^));
908 inc(p);
909 end
910 else
911 begin
912 AddLit(copy(s,p-PAnsiChar(s)+1,l),1);
913 inc(p,l);
914 end;
915 end;
916 end;
917 if InLit then
918 Result:=Result+'''';
919 end;
920 {$endif}
921
UnicodeStrToCaptionnull922 function UnicodeStrToCaption(const u: UnicodeString; MaxLength: integer
923 ): Unicodestring;
924 var
925 InLit: boolean;
926 Len: integer;
927
928 procedure AddHash(o: integer);
929 var
930 h: UnicodeString;
931 begin
932 if (Result<>'') and InLit then
933 begin
934 Result:=Result+'''';
935 inc(Len);
936 InLit:=false;
937 end;
938 h:='#'+UnicodeString(IntToStr(o));
939 inc(Len,length(h));
940 if Len<=MaxLength then
941 Result:=Result+h;
942 end;
943
944 procedure AddLit(const Lit: Unicodestring; CaptionLen: integer);
945 begin
946 if not InLit then
947 begin
948 Result:=Result+'''';
949 inc(Len);
950 InLit:=true;
951 end;
952 Result:=Result+Lit;
953 inc(Len,CaptionLen);
954 end;
955
956 var
957 p: integer;
958 begin
959 Result:='';
960 p:=1;
961 Len:=0;
962 InLit:=false;
963 while (Len<MaxLength) and (p<=length(u)) do
964 case u[p] of
965 '''':
966 begin
967 AddLit('''''',2);
968 inc(p);
969 end;
970 #0..#31,#127..#255,#$D800..#$ffff:
971 begin
972 AddHash(ord(u[p]));
973 inc(p);
974 end
975 else
976 begin
977 AddLit(u[p],1);
978 inc(p);
979 end;
980 end;
981 if InLit then
982 Result:=Result+'''';
983 end;
984
CodePointToStringnull985 function CodePointToString(CodePoint: longword): String;
986 begin
987 case CodePoint of
988 0..$7f:
989 begin
990 Result:=char(byte(CodePoint));
991 end;
992 $80..$7ff:
993 begin
994 Result:=char(byte($c0 or (CodePoint shr 6)))
995 +char(byte($80 or (CodePoint and $3f)));
996 end;
997 $800..$ffff:
998 begin
999 Result:=char(byte($e0 or (CodePoint shr 12)))
1000 +char(byte((CodePoint shr 6) and $3f) or $80)
1001 +char(byte(CodePoint and $3f) or $80);
1002 end;
1003 $10000..$10ffff:
1004 begin
1005 Result:=char(byte($f0 or (CodePoint shr 18)))
1006 +char(byte((CodePoint shr 12) and $3f) or $80)
1007 +char(byte((CodePoint shr 6) and $3f) or $80)
1008 +char(byte(CodePoint and $3f) or $80);
1009 end;
1010 else
1011 Result:='';
1012 end;
1013 end;
1014
CodePointToUnicodeStringnull1015 function CodePointToUnicodeString(u: longword): UnicodeString;
1016 begin
1017 if u < $10000 then
1018 // Note: codepoints $D800 - $DFFF are reserved
1019 Result:=WideChar(u)
1020 else
1021 Result:=WideChar($D800+((u - $10000) shr 10))+WideChar($DC00+((u - $10000) and $3ff));
1022 end;
1023
GetObjNamenull1024 function GetObjName(o: TObject): string;
1025 var
1026 GenType: TPasGenericType;
1027 begin
1028 if o=nil then
1029 Result:='nil'
1030 else if o is TPasElement then
1031 begin
1032 Result:=TPasElement(o).Name;
1033 if o is TPasGenericType then
1034 begin
1035 GenType:=TPasGenericType(o);
1036 if (GenType.GenericTemplateTypes<>nil)
1037 and (GenType.GenericTemplateTypes.Count>0) then
1038 Result:=Result+GetGenericParamCommas(GenType.GenericTemplateTypes.Count);
1039 end;
1040 Result:=Result+':'+o.ClassName;
1041 end
1042 else
1043 Result:=o.ClassName;
1044 end;
1045
GetObjPathnull1046 function GetObjPath(o: TObject): string;
1047 var
1048 El: TPasElement;
1049 GenType: TPasGenericType;
1050 begin
1051 if o is TPasElement then
1052 begin
1053 El:=TPasElement(o);
1054 Result:=':'+El.ClassName;
1055 while El<>nil do
1056 begin
1057 if El<>o then
1058 Result:='.'+Result;
1059 if El is TPasGenericType then
1060 begin
1061 GenType:=TPasGenericType(El);
1062 if (GenType.GenericTemplateTypes<>nil)
1063 and (GenType.GenericTemplateTypes.Count>0) then
1064 Result:=GetGenericParamCommas(GenType.GenericTemplateTypes.Count)+Result;
1065 end;
1066 if El.Name<>'' then
1067 begin
1068 if IsValidIdent(El.Name) then
1069 Result:=El.Name+Result
1070 else
1071 Result:='"'+El.Name+'"'+Result;
1072 end
1073 else
1074 Result:='['+El.ClassName+']'+Result;
1075 El:=El.Parent;
1076 end;
1077 end
1078 else
1079 Result:=GetObjName(o);
1080 end;
1081
GetGenericParamCommasnull1082 function GetGenericParamCommas(Cnt: integer): string;
1083 begin
1084 if Cnt<=0 then
1085 Result:=''
1086 else
1087 Result:='<'+StringOfChar(',',Cnt-1)+'>';
1088 end;
1089
GetElementNameAndParamsnull1090 function GetElementNameAndParams(El: TPasElement; MaxLvl: integer): string;
1091 begin
1092 if El=nil then
1093 exit('(nil)');
1094 Result:=El.Name;
1095 if El is TPasGenericType then
1096 Result:=Result+GetTypeParamNames(TPasGenericType(El).GenericTemplateTypes,MaxLvl-1);
1097 end;
1098
GetTypeParamNamesnull1099 function GetTypeParamNames(Templates: TFPList; MaxLvl: integer): string;
1100 var
1101 i: Integer;
1102 El: TPasElement;
1103 begin
1104 if (Templates=nil) or (Templates.Count=0) then
1105 exit('');
1106 if MaxLvl<=0 then
1107 exit('...');
1108 Result:='<';
1109 for i:=0 to Templates.Count-1 do
1110 begin
1111 if i>0 then
1112 Result:=Result+',';
1113 El:=TPasElement(Templates[i]);
1114 if El.Name<>'' then
1115 Result:=Result+GetElementNameAndParams(El,MaxLvl-1)
1116 else if El is TPasArrayType then
1117 Result:=Result+'array...'
1118 else
1119 Result:=Result+'...';
1120 end;
1121 Result:=Result+'>';
1122 end;
1123
dbgsnull1124 function dbgs(const Flags: TResEvalFlags): string;
1125 var
1126 s: string;
1127 f: TResEvalFlag;
1128 begin
1129 Result:='';
1130 for f in Flags do
1131 if f in Flags then
1132 begin
1133 if Result<>'' then Result:=Result+',';
1134 str(f,s);
1135 Result:=Result+s;
1136 end;
1137 Result:='['+Result+']';
1138 end;
1139
dbgsnull1140 function dbgs(v: TResEvalValue): string;
1141 begin
1142 if v=nil then
1143 Result:='nil'
1144 else
1145 Result:=v.AsDebugString;
1146 end;
1147
LastPosnull1148 function LastPos(c: char; const s: string): sizeint;
1149 var
1150 i: SizeInt;
1151 begin
1152 for i:=length(s) downto 1 do
1153 if s[i]=c then exit(i);
1154 Result:=-1;
1155 end;
1156
1157 { TResEvalExternal }
1158
1159 constructor TResEvalExternal.Create;
1160 begin
1161 inherited Create;
1162 Kind:=revkExternal;
1163 end;
1164
TResEvalExternal.Clonenull1165 function TResEvalExternal.Clone: TResEvalValue;
1166 begin
1167 Result:=inherited Clone;
1168 end;
1169
AsStringnull1170 function TResEvalExternal.AsString: string;
1171 begin
1172 Result:=inherited AsString;
1173 end;
1174
1175 { TResEvalCurrency }
1176
1177 constructor TResEvalCurrency.Create;
1178 begin
1179 inherited Create;
1180 Kind:=revkCurrency;
1181 end;
1182
1183 constructor TResEvalCurrency.CreateValue(const aValue: TMaxPrecCurrency);
1184 begin
1185 Create;
1186 Value:=aValue;
1187 end;
1188
TResEvalCurrency.Clonenull1189 function TResEvalCurrency.Clone: TResEvalValue;
1190 begin
1191 Result:=inherited Clone;
1192 TResEvalCurrency(Result).Value:=Value;
1193 end;
1194
AsStringnull1195 function TResEvalCurrency.AsString: string;
1196 begin
1197 str(Value,Result);
1198 end;
1199
TResEvalCurrency.IsIntnull1200 function TResEvalCurrency.IsInt(out Int: TMaxPrecInt): boolean;
1201 var
1202 i: TMaxPrecInt;
1203 begin
1204 i:=AsInt;
1205 Result:=(i mod 10000)=0;
1206 Int:=i div 10000;
1207 end;
1208
TResEvalCurrency.AsIntnull1209 function TResEvalCurrency.AsInt: TMaxPrecInt;
1210 begin
1211 {$ifdef pas2js}
1212 Result:=NativeInt(Value); // pas2js stores currency as a double with factor 10.000
1213 {$else}
1214 Result:=PInt64(@Value)^; // fpc stores currency as an int64 with factor 10.000
1215 {$endif};
1216 end;
1217
1218 { TResEvalBool }
1219
1220 constructor TResEvalBool.Create;
1221 begin
1222 inherited Create;
1223 Kind:=revkBool;
1224 end;
1225
1226 constructor TResEvalBool.CreateValue(const aValue: boolean);
1227 begin
1228 Create;
1229 B:=aValue;
1230 end;
1231
TResEvalBool.Clonenull1232 function TResEvalBool.Clone: TResEvalValue;
1233 begin
1234 Result:=inherited Clone;
1235 TResEvalBool(Result).B:=B;
1236 end;
1237
AsStringnull1238 function TResEvalBool.AsString: string;
1239 begin
1240 if B then
1241 Result:='true'
1242 else
1243 Result:='false';
1244 end;
1245
1246 { TResEvalRangeUInt }
1247
1248 constructor TResEvalRangeUInt.Create;
1249 begin
1250 inherited Create;
1251 Kind:=revkRangeInt;
1252 end;
1253
1254 constructor TResEvalRangeUInt.CreateValue(const aRangeStart,
1255 aRangeEnd: TMaxPrecUInt);
1256 begin
1257 Create;
1258 RangeStart:=aRangeStart;
1259 RangeEnd:=aRangeEnd;
1260 end;
1261
TResEvalRangeUInt.Clonenull1262 function TResEvalRangeUInt.Clone: TResEvalValue;
1263 begin
1264 Result:=inherited Clone;
1265 TResEvalRangeUInt(Result).RangeStart:=RangeStart;
1266 TResEvalRangeUInt(Result).RangeEnd:=RangeEnd;
1267 end;
1268
AsStringnull1269 function TResEvalRangeUInt.AsString: string;
1270 begin
1271 Result:=IntToStr(RangeStart)+'..'+IntToStr(RangeEnd);
1272 end;
1273
1274 { TResExprEvaluator }
1275
1276 procedure TResExprEvaluator.LogMsg(const id: TMaxPrecInt; MsgType: TMessageType;
1277 MsgNumber: integer; const Fmt: String;
1278 Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
1279 PosEl: TPasElement);
1280 begin
1281 OnLog(Self,id,MsgType,MsgNumber,Fmt,Args,PosEl);
1282 end;
1283
1284 procedure TResExprEvaluator.RaiseMsg(const Id: TMaxPrecInt; MsgNumber: integer;
1285 const Fmt: String; Args: array of {$ifdef pas2js}jsvalue{$else}const{$endif};
1286 ErrorPosEl: TPasElement);
1287 begin
1288 LogMsg(id,mtError,MsgNumber,Fmt,Args,ErrorPosEl);
1289 raise Exception.Create('['+IntToStr(id)+'] ('+IntToStr(MsgNumber)+') '+SafeFormat(Fmt,Args));
1290 end;
1291
1292 procedure TResExprEvaluator.RaiseNotYetImplemented(id: TMaxPrecInt; El: TPasElement;
1293 Msg: string);
1294 var
1295 s: String;
1296 begin
1297 s:=sNotYetImplemented+' ['+IntToStr(id)+']';
1298 if Msg<>'' then
1299 s:=s+' '+Msg;
1300 {$IFDEF VerbosePasResolver}
1301 writeln('TResExprEvaluator.RaiseNotYetImplemented s="',s,'" El=',GetObjName(El));
1302 {$ENDIF}
1303 RaiseMsg(id,nNotYetImplemented,s,[GetObjName(El)],El);
1304 end;
1305
1306 procedure TResExprEvaluator.RaiseInternalError(id: TMaxPrecInt; const Msg: string);
1307 begin
1308 raise Exception.Create('Internal error: ['+IntToStr(id)+'] '+Msg);
1309 end;
1310
1311 procedure TResExprEvaluator.RaiseConstantExprExp(id: TMaxPrecInt; ErrorEl: TPasElement
1312 );
1313 begin
1314 RaiseMsg(id,nConstantExpressionExpected,sConstantExpressionExpected,[],ErrorEl);
1315 end;
1316
1317 procedure TResExprEvaluator.RaiseRangeCheck(id: TMaxPrecInt; ErrorEl: TPasElement);
1318 begin
1319 RaiseMsg(id,nRangeCheckError,sRangeCheckError,[],ErrorEl);
1320 end;
1321
1322 procedure TResExprEvaluator.RaiseOverflowArithmetic(id: TMaxPrecInt;
1323 ErrorEl: TPasElement);
1324 begin
1325 RaiseMsg(id,nOverflowInArithmeticOperation,sOverflowInArithmeticOperation,[],ErrorEl);
1326 end;
1327
1328 procedure TResExprEvaluator.RaiseDivByZero(id: TMaxPrecInt; ErrorEl: TPasElement);
1329 begin
1330 RaiseMsg(id,nDivByZero,sDivByZero,[],ErrorEl);
1331 end;
1332
EvalUnaryExprnull1333 function TResExprEvaluator.EvalUnaryExpr(Expr: TUnaryExpr; Flags: TResEvalFlags
1334 ): TResEvalValue;
1335 var
1336 Int: TMaxPrecInt;
1337 UInt: TMaxPrecUInt;
1338 begin
1339 Result:=Eval(Expr.Operand,Flags);
1340 if Result=nil then exit;
1341 {$IFDEF VerbosePasResEval}
1342 writeln('TResExprEvaluator.EvalUnaryExpr ',OpcodeStrings[Expr.OpCode],' Value=',Result.AsDebugString);
1343 {$ENDIF}
1344 case Expr.OpCode of
1345 eopAdd: ;
1346 eopSubtract:
1347 case Result.Kind of
1348 revkInt:
1349 begin
1350 Int:=TResEvalInt(Result).Int;
1351 if Int=0 then exit;
1352 if Result.Element<>nil then
1353 Result:=Result.Clone;
1354 if (TResEvalInt(Result).Typed in reitAllSigned) then
1355 begin
1356 if Int=reitLow[TResEvalInt(Result).Typed] then
1357 begin
1358 // need higher precision
1359 if TResEvalInt(Result).Typed<>reitNone then
1360 // unsigned -> switch to untyped
1361 TResEvalInt(Result).Typed:=reitNone
1362 else
1363 begin
1364 // switch to float
1365 ReleaseEvalValue(Result);
1366 Result:=TResEvalFloat.CreateValue(-TMaxPrecFloat(low(TMaxPrecInt)));
1367 exit;
1368 end;
1369 end;
1370 end
1371 else
1372 begin
1373 // unsigned -> switch to untyped
1374 TResEvalInt(Result).Typed:=reitNone;
1375 end ;
1376 // negate
1377 TResEvalInt(Result).Int:=-Int;
1378 end;
1379 revkUInt:
1380 begin
1381 UInt:=TResEvalUInt(Result).UInt;
1382 if UInt=0 then exit;
1383 if UInt<=High(TMaxPrecInt) then
1384 begin
1385 ReleaseEvalValue(Result);
1386 Result:=TResEvalInt.CreateValue(-TMaxPrecInt(UInt));
1387 end
1388 else
1389 begin
1390 // switch to float
1391 ReleaseEvalValue(Result);
1392 Result:=TResEvalFloat.CreateValue(-TMaxPrecFloat(UInt));
1393 end;
1394 end;
1395 revkFloat:
1396 begin
1397 if TResEvalFloat(Result).FloatValue=0 then exit;
1398 if Result.Element<>nil then
1399 Result:=Result.Clone;
1400 TResEvalFloat(Result).FloatValue:=-TResEvalFloat(Result).FloatValue;
1401 end;
1402 revkCurrency:
1403 begin
1404 if TResEvalCurrency(Result).Value=0 then exit;
1405 if Result.Element<>nil then
1406 Result:=Result.Clone;
1407 TResEvalCurrency(Result).Value:=-TResEvalCurrency(Result).Value;
1408 end;
1409 revkExternal:
1410 exit;
1411 else
1412 begin
1413 if Result.Element=nil then
1414 Result.Free;
1415 RaiseNotYetImplemented(20170518230738,Expr);
1416 end;
1417 end;
1418 eopNot:
1419 case Result.Kind of
1420 revkBool:
1421 begin
1422 if Result.Element<>nil then
1423 Result:=Result.Clone;
1424 TResEvalBool(Result).B:=not TResEvalBool(Result).B;
1425 end;
1426 revkInt:
1427 begin
1428 if Result.Element<>nil then
1429 Result:=Result.Clone;
1430 case TResEvalInt(Result).Typed of
1431 reitByte: TResEvalInt(Result).Int:=not byte(TResEvalInt(Result).Int);
1432 reitShortInt: TResEvalInt(Result).Int:=not shortint(TResEvalInt(Result).Int);
1433 reitWord: TResEvalInt(Result).Int:=not word(TResEvalInt(Result).Int);
1434 reitSmallInt: TResEvalInt(Result).Int:=not smallint(TResEvalInt(Result).Int);
1435 reitUIntSingle: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $3fffff;
1436 reitIntSingle: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $7fffff;
1437 reitLongWord: TResEvalInt(Result).Int:=not longword(TResEvalInt(Result).Int);
1438 reitLongInt: TResEvalInt(Result).Int:=not longint(TResEvalInt(Result).Int);
1439 reitUIntDouble: TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $fffffffffffff;
1440 reitIntDouble: {$ifdef fpc}TResEvalInt(Result).Int:=(not TResEvalInt(Result).Int) and $1fffffffffffff{$endif};
1441 else TResEvalInt(Result).Int:=not TResEvalInt(Result).Int;
1442 end;
1443 end;
1444 revkUInt:
1445 begin
1446 if Result.Element<>nil then
1447 Result:=Result.Clone;
1448 TResEvalUInt(Result).UInt:=not TResEvalUInt(Result).UInt;
1449 end;
1450 revkExternal:
1451 exit;
1452 else
1453 begin
1454 if Result.Element=nil then
1455 Result.Free;
1456 RaiseNotYetImplemented(20170518232804,Expr);
1457 end;
1458 end;
1459 eopAddress:
1460 begin
1461 if Result.Element=nil then
1462 Result.Free;
1463 // @ operator requires a compiler (not just a resolver) -> return nil
1464 Result:=TResEvalValue.CreateKind(revkNil);
1465 end
1466 else
1467 RaiseNotYetImplemented(20170518232823,Expr,'operator='+OpcodeStrings[Expr.OpCode]);
1468 end;
1469 end;
1470
TResExprEvaluator.EvalBinaryExprnull1471 function TResExprEvaluator.EvalBinaryExpr(Expr: TBinaryExpr;
1472 Flags: TResEvalFlags): TResEvalValue;
1473 var
1474 LeftValue, RightValue: TResEvalValue;
1475 begin
1476 Result:=nil;
1477 if (Expr.Kind=pekBinary) and (Expr.OpCode=eopSubIdent) then
1478 begin
1479 Result:=Eval(Expr.right,Flags);
1480 exit;
1481 end;
1482 LeftValue:=nil;
1483 RightValue:=nil;
1484 try
1485 LeftValue:=Eval(Expr.left,Flags);
1486 if LeftValue=nil then exit;
1487 RightValue:=Eval(Expr.right,Flags);
1488 if RightValue=nil then exit;
1489
1490 if LeftValue.Kind=revkExternal then
1491 begin
1492 if [refConst,refConstExt]*Flags=[refConst] then
1493 RaiseConstantExprExp(20181024134508,Expr.left);
1494 Result:=LeftValue;
1495 LeftValue:=nil;
1496 exit;
1497 end;
1498 if RightValue.Kind=revkExternal then
1499 begin
1500 if [refConst,refConstExt]*Flags=[refConst] then
1501 RaiseConstantExprExp(20181024134545,Expr.right);
1502 Result:=RightValue;
1503 RightValue:=nil;
1504 exit;
1505 end;
1506
1507 case Expr.Kind of
1508 pekRange:
1509 // leftvalue..rightvalue
1510 Result:=EvalBinaryRangeExpr(Expr,LeftValue,RightValue);
1511 pekBinary:
1512 case Expr.OpCode of
1513 eopAdd:
1514 Result:=EvalBinaryAddExpr(Expr,LeftValue,RightValue);
1515 eopSubtract:
1516 Result:=EvalBinarySubExpr(Expr,LeftValue,RightValue);
1517 eopMultiply:
1518 Result:=EvalBinaryMulExpr(Expr,LeftValue,RightValue);
1519 eopDivide:
1520 Result:=EvalBinaryDivideExpr(Expr,LeftValue,RightValue);
1521 eopDiv:
1522 Result:=EvalBinaryDivExpr(Expr,LeftValue,RightValue);
1523 eopMod:
1524 Result:=EvalBinaryModExpr(Expr,LeftValue,RightValue);
1525 eopPower:
1526 Result:=EvalBinaryPowerExpr(Expr,LeftValue,RightValue);
1527 eopShl,eopShr:
1528 Result:=EvalBinaryShiftExpr(Expr,LeftValue,RightValue);
1529 eopAnd,eopOr,eopXor:
1530 Result:=EvalBinaryBoolOpExpr(Expr,LeftValue,RightValue);
1531 eopEqual,eopNotEqual:
1532 Result:=EvalBinaryNEqualExpr(Expr,LeftValue,RightValue);
1533 eopLessThan,eopGreaterThan, eopLessthanEqual,eopGreaterThanEqual:
1534 Result:=EvalBinaryLessGreaterExpr(Expr,LeftValue,RightValue);
1535 eopIn:
1536 Result:=EvalBinaryInExpr(Expr,LeftValue,RightValue);
1537 eopSymmetricaldifference:
1538 Result:=EvalBinarySymmetricaldifferenceExpr(Expr,LeftValue,RightValue);
1539 else
1540 {$IFDEF VerbosePasResolver}
1541 writeln('TResExprEvaluator.EvalBinaryExpr Kind=',Expr.Kind,' Opcode=',OpcodeStrings[Expr.OpCode],' Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1542 {$ENDIF}
1543 RaiseNotYetImplemented(20170530100823,Expr);
1544 end;
1545 else
1546 {$IFDEF VerbosePasResolver}
1547 writeln('TResExprEvaluator.EvalBinaryExpr Kind=',Expr.Kind,' Opcode=',OpcodeStrings[Expr.OpCode]);
1548 {$ENDIF}
1549 RaiseNotYetImplemented(20170530100827,Expr);
1550 end;
1551 {$IFDEF VerbosePasResEval}
1552 {AllowWriteln}
1553 if Result<>nil then
1554 writeln('TResExprEvaluator.EvalBinaryExpr Left=',LeftValue.AsDebugString,' Opcode=',OpcodeStrings[Expr.OpCode],' Right=',RightValue.AsDebugString,' Result=',Result.AsDebugString)
1555 else
1556 writeln('TResExprEvaluator.EvalBinaryExpr Left=',LeftValue.AsDebugString,' Opcode=',OpcodeStrings[Expr.OpCode],' Right=',RightValue.AsDebugString,' Result not set');
1557 {AllowWriteln-}
1558 {$ENDIF}
1559 finally
1560 ReleaseEvalValue(LeftValue);
1561 ReleaseEvalValue(RightValue);
1562 end;
1563 end;
1564
TResExprEvaluator.EvalBinaryRangeExprnull1565 function TResExprEvaluator.EvalBinaryRangeExpr(Expr: TBinaryExpr; LeftValue,
1566 RightValue: TResEvalValue): TResEvalValue;
1567 // LeftValue..RightValue
1568 var
1569 LeftInt, RightInt: TMaxPrecInt;
1570 begin
1571 case LeftValue.Kind of
1572 revkBool:
1573 if RightValue.Kind<>revkBool then
1574 RaiseRangeCheck(20170714133017,Expr.Right)
1575 else
1576 begin
1577 LeftInt:=ord(TResEvalBool(LeftValue).B);
1578 RightInt:=ord(TResEvalBool(RightValue).B);
1579 if LeftInt>RightInt then
1580 RaiseMsg(20170714133540,nHighRangeLimitLTLowRangeLimit,
1581 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1582 Result:=TResEvalRangeInt.CreateValue(revskBool,nil,LeftInt,RightInt);
1583 exit;
1584 end;
1585 revkInt:
1586 if RightValue.Kind=revkInt then
1587 begin
1588 LeftInt:=TResEvalInt(LeftValue).Int;
1589 RightInt:=TResEvalInt(RightValue).Int;
1590 if LeftInt>RightInt then
1591 RaiseMsg(20170518222939,nHighRangeLimitLTLowRangeLimit,
1592 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1593 Result:=TResEvalRangeInt.CreateValue(revskInt,nil,LeftInt,RightInt);
1594 exit;
1595 end
1596 else if RightValue.Kind=revkUInt then
1597 begin
1598 // Note: when FPC compares int64 with qword it converts the qword to an int64
1599 if TResEvalUInt(RightValue).UInt<=HighIntAsUInt then
1600 begin
1601 if TResEvalInt(LeftValue).Int>TResEvalUInt(RightValue).UInt then
1602 RaiseMsg(20170519000235,nHighRangeLimitLTLowRangeLimit,
1603 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1604 Result:=TResEvalRangeInt.CreateValue(revskInt,nil,
1605 TResEvalInt(LeftValue).Int,TMaxPrecInt(TResEvalUInt(RightValue).UInt));
1606 exit;
1607 end
1608 else if TResEvalInt(LeftValue).Int<0 then
1609 RaiseRangeCheck(20170522151629,Expr.Right)
1610 else if TMaxPrecUInt(TResEvalInt(LeftValue).Int)>TResEvalUInt(RightValue).UInt then
1611 RaiseMsg(20170522151708,nHighRangeLimitLTLowRangeLimit,
1612 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1613 Result:=TResEvalRangeUInt.CreateValue(TMaxPrecUInt(TResEvalInt(LeftValue).Int),
1614 TResEvalUInt(RightValue).UInt);
1615 exit;
1616 end
1617 else
1618 RaiseRangeCheck(20170518222812,Expr.Right);
1619 revkUInt:
1620 if RightValue.Kind=revkInt then
1621 begin
1622 // Note: when FPC compares int64 with qword it converts the qword to an int64
1623 if TResEvalUInt(LeftValue).UInt>HighIntAsUInt then
1624 begin
1625 if TResEvalInt(RightValue).Int<0 then
1626 RaiseRangeCheck(20170522152608,Expr.Right)
1627 else if TResEvalUInt(LeftValue).UInt>TMaxPrecUInt(TResEvalInt(RightValue).Int) then
1628 RaiseMsg(20170522152648,nHighRangeLimitLTLowRangeLimit,
1629 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1630 Result:=TResEvalRangeUInt.CreateValue(TResEvalUInt(LeftValue).UInt,
1631 TMaxPrecUInt(TResEvalInt(RightValue).Int));
1632 exit;
1633 end
1634 else if TResEvalUInt(LeftValue).UInt>TResEvalInt(RightValue).Int then
1635 RaiseMsg(20170522152804,nHighRangeLimitLTLowRangeLimit,
1636 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1637 Result:=TResEvalRangeInt.CreateValue(revskInt,nil,
1638 TMaxPrecInt(TResEvalUInt(LeftValue).UInt),TResEvalInt(RightValue).Int);
1639 exit;
1640 end
1641 else if RightValue.Kind=revkUInt then
1642 begin
1643 if TResEvalUInt(LeftValue).UInt>TResEvalUInt(RightValue).UInt then
1644 RaiseMsg(20170519000240,nHighRangeLimitLTLowRangeLimit,
1645 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1646 Result:=TResEvalRangeUInt.CreateValue(TResEvalUInt(LeftValue).UInt,
1647 TResEvalUInt(RightValue).UInt);
1648 exit;
1649 end
1650 else
1651 RaiseRangeCheck(20170522123106,Expr.Right);
1652 revkEnum:
1653 if (RightValue.Kind<>revkEnum) then
1654 RaiseRangeCheck(20170522153003,Expr.Right)
1655 else if (TResEvalEnum(LeftValue).ElType<>TResEvalEnum(RightValue).ElType) then
1656 begin
1657 {$IFDEF VerbosePasResolver}
1658 writeln('TResExprEvaluator.EvalBinaryRangeExpr LeftValue=',dbgs(LeftValue),',',GetObjName(TResEvalEnum(LeftValue).ElType),' RightValue=',dbgs(RightValue),',',GetObjName(TResEvalEnum(RightValue).ElType));
1659 {$ENDIF}
1660 RaiseRangeCheck(20170522123241,Expr.Right) // mismatch enumtype
1661 end
1662 else if TResEvalEnum(LeftValue).Index>TResEvalEnum(RightValue).Index then
1663 RaiseMsg(20170522123320,nHighRangeLimitLTLowRangeLimit,
1664 sHighRangeLimitLTLowRangeLimit,[],Expr.Right)
1665 else
1666 begin
1667 Result:=TResEvalRangeInt.CreateValue(revskEnum,
1668 TResEvalEnum(LeftValue).ElType as TPasEnumType,
1669 TResEvalEnum(LeftValue).Index,TResEvalEnum(RightValue).Index);
1670 exit;
1671 end;
1672 {$ifdef FPC_HAS_CPSTRING}
1673 revkString,
1674 {$endif}
1675 revkUnicodeString:
1676 begin
1677 LeftInt:=StringToOrd(LeftValue,Expr.left);
1678 if RightValue.Kind in revkAllStrings then
1679 begin
1680 RightInt:=StringToOrd(RightValue,Expr.right);
1681 if LeftInt>RightInt then
1682 RaiseMsg(20170523151508,nHighRangeLimitLTLowRangeLimit,
1683 sHighRangeLimitLTLowRangeLimit,[],Expr.Right);
1684 Result:=TResEvalRangeInt.CreateValue(revskChar,nil,LeftInt,RightInt);
1685 exit;
1686 end
1687 else
1688 RaiseRangeCheck(20170522123106,Expr.Right);
1689 end
1690 else
1691 {$IFDEF VerbosePasResolver}
1692 writeln('TResExprEvaluator.EvalBinaryRangeExpr Left=',GetObjName(Expr.Left),' LeftValue.Kind=',LeftValue.Kind);
1693 RaiseNotYetImplemented(20170518221103,Expr.Left);
1694 {$ENDIF}
1695 end;
1696 end;
1697
EvalBinaryAddExprnull1698 function TResExprEvaluator.EvalBinaryAddExpr(Expr: TBinaryExpr; LeftValue,
1699 RightValue: TResEvalValue): TResEvalValue;
1700
1701 procedure IntAddUInt(const i: TMaxPrecInt; const u: TMaxPrecUInt);
1702 var
1703 Int: TMaxPrecInt;
1704 UInt: TMaxPrecUInt;
1705 begin
1706 if (i>=0) then
1707 begin
1708 UInt:=TMaxPrecUInt(i)+u;
1709 Result:=CreateResEvalInt(UInt);
1710 end
1711 else if u<=HighIntAsUInt then
1712 begin
1713 Int:=i + TMaxPrecInt(u);
1714 Result:=TResEvalInt.CreateValue(Int);
1715 end
1716 else
1717 RaiseRangeCheck(20170601140523,Expr);
1718 end;
1719
1720 var
1721 Int: TMaxPrecInt;
1722 UInt: TMaxPrecUInt;
1723 Flo: TMaxPrecFloat;
1724 aCurrency: TMaxPrecCurrency;
1725 LeftSet, RightSet: TResEvalSet;
1726 i: Integer;
1727 begin
1728 Result:=nil;
1729 try
1730 {$Q+} // enable overflow and range checks
1731 {$R+}
1732 case LeftValue.Kind of
1733 revkInt:
1734 begin
1735 Int:=TResEvalInt(LeftValue).Int;
1736 case RightValue.Kind of
1737 revkInt: // int + int
1738 if (Int>0) and (TResEvalInt(RightValue).Int>0) then
1739 begin
1740 UInt:=TMaxPrecUInt(Int)+TMaxPrecUInt(TResEvalInt(RightValue).Int);
1741 Result:=CreateResEvalInt(UInt);
1742 end
1743 else
1744 begin
1745 Int:=Int + TResEvalInt(RightValue).Int;
1746 Result:=TResEvalInt.CreateValue(Int);
1747 end;
1748 revkUInt: // int + uint
1749 IntAddUInt(Int,TResEvalUInt(RightValue).UInt);
1750 revkFloat: // int + float
1751 Result:=TResEvalFloat.CreateValue(Int + TResEvalFloat(RightValue).FloatValue);
1752 revkCurrency: // int + currency
1753 Result:=TResEvalCurrency.CreateValue(Int + TResEvalCurrency(RightValue).Value);
1754 else
1755 {$IFDEF VerbosePasResolver}
1756 writeln('TResExprEvaluator.EvalBinaryAddExpr int+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1757 {$ENDIF}
1758 RaiseNotYetImplemented(20170525115537,Expr);
1759 end;
1760 end;
1761 revkUInt:
1762 begin
1763 UInt:=TResEvalUInt(LeftValue).UInt;
1764 case RightValue.Kind of
1765 revkInt: // uint + int
1766 IntAddUInt(UInt,TResEvalInt(RightValue).Int);
1767 revkUInt: // uint + uint
1768 begin
1769 UInt:=UInt+TResEvalUInt(RightValue).UInt;
1770 Result:=TResEvalUInt.CreateValue(UInt);
1771 end;
1772 revkFloat: // uint + float
1773 Result:=TResEvalFloat.CreateValue(UInt + TResEvalFloat(RightValue).FloatValue);
1774 revkCurrency: // uint + currency
1775 Result:=TResEvalCurrency.CreateValue(UInt + TResEvalCurrency(RightValue).Value);
1776 else
1777 {$IFDEF VerbosePasResolver}
1778 writeln('TResExprEvaluator.EvalBinaryAddExpr uint+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1779 {$ENDIF}
1780 RaiseNotYetImplemented(20170601141031,Expr);
1781 end;
1782 end;
1783 revkFloat:
1784 begin
1785 Flo:=TResEvalFloat(LeftValue).FloatValue;
1786 case RightValue.Kind of
1787 revkInt: // float + int
1788 Result:=TResEvalFloat.CreateValue(Flo + TResEvalInt(RightValue).Int);
1789 revkUInt: // float + uint
1790 Result:=TResEvalFloat.CreateValue(Flo + TResEvalUInt(RightValue).UInt);
1791 revkFloat: // float + float
1792 Result:=TResEvalFloat.CreateValue(Flo + TResEvalFloat(RightValue).FloatValue);
1793 revkCurrency: // float + Currency
1794 Result:=TResEvalCurrency.CreateValue(Flo + TResEvalCurrency(RightValue).Value);
1795 else
1796 {$IFDEF VerbosePasResolver}
1797 writeln('TResExprEvaluator.EvalBinaryAddExpr float+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1798 {$ENDIF}
1799 RaiseNotYetImplemented(20170711145637,Expr);
1800 end;
1801 end;
1802 revkCurrency:
1803 begin
1804 aCurrency:=TResEvalCurrency(LeftValue).Value;
1805 case RightValue.Kind of
1806 revkInt: // currency + int
1807 Result:=TResEvalFloat.CreateValue(aCurrency + TResEvalInt(RightValue).Int);
1808 revkUInt: // currency + uint
1809 Result:=TResEvalFloat.CreateValue(aCurrency + TResEvalUInt(RightValue).UInt);
1810 revkFloat: // currency + float
1811 Result:=TResEvalFloat.CreateValue(aCurrency + TResEvalFloat(RightValue).FloatValue);
1812 revkCurrency: // currency + currency
1813 Result:=TResEvalCurrency.CreateValue(aCurrency + TResEvalCurrency(RightValue).Value);
1814 else
1815 {$IFDEF VerbosePasResolver}
1816 writeln('TResExprEvaluator.EvalBinaryAddExpr currency+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1817 {$ENDIF}
1818 RaiseNotYetImplemented(20180421163819,Expr);
1819 end;
1820 end;
1821 {$ifdef FPC_HAS_CPSTRING}
1822 revkString,
1823 {$endif}
1824 revkUnicodeString:
1825 Result:=EvalStringAddExpr(Expr,Expr.left,Expr.right,LeftValue,RightValue);
1826 revkSetOfInt:
1827 case RightValue.Kind of
1828 revkSetOfInt:
1829 begin
1830 // union
1831 LeftSet:=TResEvalSet(LeftValue);
1832 RightSet:=TResEvalSet(RightValue);
1833 if LeftSet.ElKind=revskNone then
1834 Result:=RightSet.Clone
1835 else if RightSet.ElKind=revskNone then
1836 Result:=LeftSet.Clone
1837 else
1838 begin
1839 Result:=RightSet.Clone;
1840 // add elements of left
1841 for i:=0 to length(LeftSet.Ranges)-1 do
1842 begin
1843 Int:=LeftSet.Ranges[i].RangeStart;
1844 while Int<=LeftSet.Ranges[i].RangeEnd do
1845 begin
1846 TResEvalSet(Result).Add(Int,Int);
1847 inc(Int);
1848 end;
1849 end;
1850 end;
1851 end;
1852 else
1853 {$IFDEF VerbosePasResolver}
1854 writeln('TResExprEvaluator.EvalBinaryMulExpr add set+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1855 {$ENDIF}
1856 RaiseNotYetImplemented(20170714114055,Expr);
1857 end
1858 else
1859 {$IFDEF VerbosePasResolver}
1860 writeln('TResExprEvaluator.EvalBinaryAddExpr ?+ Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1861 {$ENDIF}
1862 RaiseNotYetImplemented(20170525115548,Expr);
1863 end;
1864 except
1865 on EOverflow do
1866 RaiseOverflowArithmetic(20170601140130,Expr);
1867 on ERangeError do
1868 RaiseRangeCheck(20170601140132,Expr);
1869 end;
1870 end;
1871
EvalBinarySubExprnull1872 function TResExprEvaluator.EvalBinarySubExpr(Expr: TBinaryExpr; LeftValue,
1873 RightValue: TResEvalValue): TResEvalValue;
1874 var
1875 Int: TMaxPrecInt;
1876 UInt: TMaxPrecUInt;
1877 Flo: TMaxPrecFloat;
1878 aCurrency: TMaxPrecCurrency;
1879 LeftSet, RightSet: TResEvalSet;
1880 i: Integer;
1881 begin
1882 Result:=nil;
1883 case LeftValue.Kind of
1884 revkInt:
1885 begin
1886 Int:=TResEvalInt(LeftValue).Int;
1887 case RightValue.Kind of
1888 revkInt:
1889 // int - int
1890 try
1891 {$Q+}
1892 Int:=Int - TResEvalInt(RightValue).Int;
1893 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1894 Result:=TResEvalInt.CreateValue(Int);
1895 except
1896 on E: EOverflow do
1897 if (Int>0) and (TResEvalInt(RightValue).Int<0) then
1898 begin
1899 UInt:=TMaxPrecUInt(Int)+TMaxPrecUInt(-TResEvalInt(RightValue).Int);
1900 Result:=CreateResEvalInt(UInt);
1901 end
1902 else
1903 RaiseOverflowArithmetic(20170525230247,Expr);
1904 end;
1905 revkUInt:
1906 // int - uint
1907 try
1908 {$Q+}
1909 Int:=Int - TResEvalUInt(RightValue).UInt;
1910 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1911 Result:=TResEvalInt.CreateValue(Int);
1912 except
1913 on E: EOverflow do
1914 RaiseOverflowArithmetic(20170711151201,Expr);
1915 end;
1916 revkFloat:
1917 // int - float
1918 try
1919 {$Q+}
1920 Flo:=TMaxPrecFloat(Int) - TResEvalFloat(RightValue).FloatValue;
1921 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1922 Result:=TResEvalFloat.CreateValue(Flo);
1923 except
1924 on E: EOverflow do
1925 RaiseOverflowArithmetic(20170711151313,Expr);
1926 end;
1927 revkCurrency:
1928 // int - currency
1929 try
1930 {$Q+}
1931 aCurrency:=TMaxPrecCurrency(Int) - TResEvalCurrency(RightValue).Value;
1932 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1933 Result:=TResEvalCurrency.CreateValue(aCurrency);
1934 except
1935 on E: EOverflow do
1936 RaiseOverflowArithmetic(20180421164011,Expr);
1937 end;
1938 else
1939 {$IFDEF VerbosePasResolver}
1940 writeln('TResExprEvaluator.EvalBinarySubExpr sub int-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1941 {$ENDIF}
1942 RaiseNotYetImplemented(20170525230028,Expr);
1943 end;
1944 end;
1945 revkUInt:
1946 begin
1947 UInt:=TResEvalUInt(LeftValue).UInt;
1948 case RightValue.Kind of
1949 revkInt:
1950 // uint - int
1951 try
1952 {$Q+}
1953 UInt:=UInt - TResEvalInt(RightValue).Int;
1954 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1955 Result:=TResEvalUInt.CreateValue(UInt);
1956 except
1957 on E: EOverflow do
1958 RaiseOverflowArithmetic(20170711151405,Expr);
1959 end;
1960 revkUInt:
1961 // uint - uint
1962 try
1963 {$Q+}
1964 UInt:=UInt - TResEvalUInt(RightValue).UInt;
1965 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1966 Result:=TResEvalUInt.CreateValue(UInt);
1967 except
1968 on E: EOverflow do
1969 RaiseOverflowArithmetic(20170711151419,Expr);
1970 end;
1971 revkFloat:
1972 // uint - float
1973 try
1974 {$Q+}
1975 Flo:=TMaxPrecFloat(UInt) - TResEvalFloat(RightValue).FloatValue;
1976 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1977 Result:=TResEvalFloat.CreateValue(Flo);
1978 except
1979 on E: EOverflow do
1980 RaiseOverflowArithmetic(20170711151428,Expr);
1981 end;
1982 revkCurrency:
1983 // uint - currency
1984 try
1985 {$Q+}
1986 aCurrency:=TMaxPrecCurrency(UInt) - TResEvalCurrency(RightValue).Value;
1987 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
1988 Result:=TResEvalCurrency.CreateValue(aCurrency);
1989 except
1990 on E: EOverflow do
1991 RaiseOverflowArithmetic(20180421164005,Expr);
1992 end;
1993 else
1994 {$IFDEF VerbosePasResolver}
1995 writeln('TResExprEvaluator.EvalBinarySubExpr sub uint-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
1996 {$ENDIF}
1997 RaiseNotYetImplemented(20170711151435,Expr);
1998 end;
1999 end;
2000 revkFloat:
2001 begin
2002 Flo:=TResEvalFloat(LeftValue).FloatValue;
2003 case RightValue.Kind of
2004 revkInt:
2005 // float - int
2006 try
2007 {$Q+}
2008 Flo:=Flo - TResEvalInt(RightValue).Int;
2009 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2010 Result:=TResEvalFloat.CreateValue(Flo);
2011 except
2012 on E: EOverflow do
2013 RaiseOverflowArithmetic(20170711151519,Expr);
2014 end;
2015 revkUInt:
2016 // float - uint
2017 try
2018 {$Q+}
2019 Flo:=Flo - TResEvalUInt(RightValue).UInt;
2020 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2021 Result:=TResEvalFloat.CreateValue(Flo);
2022 except
2023 on E: EOverflow do
2024 RaiseOverflowArithmetic(20170711151538,Expr);
2025 end;
2026 revkFloat:
2027 // float - float
2028 try
2029 {$Q+}
2030 Flo:=Flo - TResEvalFloat(RightValue).FloatValue;
2031 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2032 Result:=TResEvalFloat.CreateValue(Flo);
2033 except
2034 on E: EOverflow do
2035 RaiseOverflowArithmetic(20170711151552,Expr);
2036 end;
2037 revkCurrency:
2038 // float - currency
2039 try
2040 {$Q+}
2041 aCurrency:=Flo - TResEvalCurrency(RightValue).Value;
2042 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2043 Result:=TResEvalCurrency.CreateValue(aCurrency);
2044 except
2045 on E: EOverflow do
2046 RaiseOverflowArithmetic(20180421164054,Expr);
2047 end;
2048 else
2049 {$IFDEF VerbosePasResolver}
2050 writeln('TResExprEvaluator.EvalBinarySubExpr sub float-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2051 {$ENDIF}
2052 RaiseNotYetImplemented(20170711151600,Expr);
2053 end;
2054 end;
2055 revkCurrency:
2056 begin
2057 aCurrency:=TResEvalCurrency(LeftValue).Value;
2058 case RightValue.Kind of
2059 revkInt:
2060 // currency - int
2061 try
2062 {$Q+}
2063 aCurrency:=aCurrency - TResEvalInt(RightValue).Int;
2064 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2065 Result:=TResEvalCurrency.CreateValue(aCurrency);
2066 except
2067 on E: EOverflow do
2068 RaiseOverflowArithmetic(20180421164200,Expr);
2069 end;
2070 revkUInt:
2071 // currency - uint
2072 try
2073 {$Q+}
2074 aCurrency:=aCurrency - TResEvalUInt(RightValue).UInt;
2075 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2076 Result:=TResEvalCurrency.CreateValue(aCurrency);
2077 except
2078 on E: EOverflow do
2079 RaiseOverflowArithmetic(20180421164218,Expr);
2080 end;
2081 revkFloat:
2082 // currency - float
2083 try
2084 {$Q+}
2085 aCurrency:=aCurrency - TResEvalFloat(RightValue).FloatValue;
2086 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2087 Result:=TResEvalCurrency.CreateValue(aCurrency);
2088 except
2089 on E: EOverflow do
2090 RaiseOverflowArithmetic(20180421164250,Expr);
2091 end;
2092 revkCurrency:
2093 // currency - currency
2094 try
2095 {$Q+}
2096 aCurrency:=aCurrency - TResEvalCurrency(RightValue).Value;
2097 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2098 Result:=TResEvalCurrency.CreateValue(aCurrency);
2099 except
2100 on E: EOverflow do
2101 RaiseOverflowArithmetic(20180421164258,Expr);
2102 end;
2103 else
2104 {$IFDEF VerbosePasResolver}
2105 writeln('TResExprEvaluator.EvalBinarySubExpr sub currency-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2106 {$ENDIF}
2107 RaiseNotYetImplemented(20180421164312,Expr);
2108 end;
2109 end;
2110 revkSetOfInt:
2111 case RightValue.Kind of
2112 revkSetOfInt:
2113 begin
2114 // difference
2115 LeftSet:=TResEvalSet(LeftValue);
2116 RightSet:=TResEvalSet(RightValue);
2117 if LeftSet.ElKind=revskNone then
2118 Result:=TResEvalSet.CreateEmptySameKind(RightSet)
2119 else
2120 begin
2121 Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
2122 // add elements, which exists only in LeftSet
2123 for i:=0 to length(LeftSet.Ranges)-1 do
2124 begin
2125 Int:=LeftSet.Ranges[i].RangeStart;
2126 while Int<=LeftSet.Ranges[i].RangeEnd do
2127 begin
2128 if RightSet.IndexOfRange(Int)<0 then
2129 TResEvalSet(Result).Add(Int,Int);
2130 inc(Int);
2131 end;
2132 end;
2133 end;
2134 end;
2135 else
2136 {$IFDEF VerbosePasResolver}
2137 writeln('TResExprEvaluator.EvalBinarySubExpr sub set-? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2138 {$ENDIF}
2139 RaiseNotYetImplemented(20170714114101,Expr);
2140 end;
2141 else
2142 {$IFDEF VerbosePasResolver}
2143 writeln('TResExprEvaluator.EvalBinarySubExpr sub ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2144 {$ENDIF}
2145 RaiseNotYetImplemented(20170525225946,Expr);
2146 end;
2147 end;
2148
EvalBinaryMulExprnull2149 function TResExprEvaluator.EvalBinaryMulExpr(Expr: TBinaryExpr; LeftValue,
2150 RightValue: TResEvalValue): TResEvalValue;
2151 var
2152 Int: TMaxPrecInt;
2153 UInt: TMaxPrecUInt;
2154 Flo: TMaxPrecFloat;
2155 aCurrency: TMaxPrecCurrency;
2156 LeftSet, RightSet: TResEvalSet;
2157 i: Integer;
2158 begin
2159 Result:=nil;
2160 case LeftValue.Kind of
2161 revkInt:
2162 begin
2163 Int:=TResEvalInt(LeftValue).Int;
2164 case RightValue.Kind of
2165 revkInt:
2166 // int * int
2167 try
2168 {$Q+}
2169 Int:=Int * TResEvalInt(RightValue).Int;
2170 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2171 Result:=TResEvalInt.CreateValue(Int);
2172 except
2173 on E: EOverflow do
2174 if (Int>0) and (TResEvalInt(RightValue).Int>0) then
2175 try
2176 // try uint*uint
2177 {$Q+}
2178 UInt:=TMaxPrecUInt(Int) * TMaxPrecUInt(TResEvalInt(RightValue).Int);
2179 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2180 Result:=CreateResEvalInt(UInt);
2181 except
2182 on E: EOverflow do
2183 RaiseOverflowArithmetic(20170530101616,Expr);
2184 end
2185 else
2186 RaiseOverflowArithmetic(20170525230247,Expr);
2187 end;
2188 revkUInt:
2189 // int * uint
2190 try
2191 {$Q+}
2192 Int:=Int * TResEvalUInt(RightValue).UInt;
2193 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2194 Result:=TResEvalInt.CreateValue(Int);
2195 except
2196 RaiseOverflowArithmetic(20170711164445,Expr);
2197 end;
2198 revkFloat:
2199 // int * float
2200 try
2201 {$Q+}
2202 Flo:=Int * TResEvalFloat(RightValue).FloatValue;
2203 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2204 Result:=TResEvalFloat.CreateValue(Flo);
2205 except
2206 RaiseOverflowArithmetic(20170711164541,Expr);
2207 end;
2208 revkCurrency:
2209 // int * currency
2210 try
2211 {$Q+}
2212 aCurrency:=Int * TResEvalCurrency(RightValue).Value;
2213 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2214 Result:=TResEvalCurrency.CreateValue(aCurrency);
2215 except
2216 RaiseOverflowArithmetic(20180421164426,Expr);
2217 end;
2218 else
2219 {$IFDEF VerbosePasResolver}
2220 writeln('TResExprEvaluator.EvalBinaryMulExpr mul int*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2221 {$ENDIF}
2222 RaiseNotYetImplemented(20170525230028,Expr);
2223 end;
2224 end;
2225 revkUInt:
2226 begin
2227 UInt:=TResEvalUInt(LeftValue).UInt;
2228 case RightValue.Kind of
2229 revkInt:
2230 // uint * int
2231 if TResEvalInt(RightValue).Int>=0 then
2232 try
2233 {$Q+}
2234 UInt:=UInt * TResEvalInt(RightValue).Int;
2235 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2236 Result:=TResEvalUInt.CreateValue(UInt);
2237 except
2238 on E: EOverflow do
2239 RaiseOverflowArithmetic(20170711164714,Expr);
2240 end
2241 else
2242 try
2243 {$Q+}
2244 Int:=UInt * TResEvalInt(RightValue).Int;
2245 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2246 Result:=TResEvalInt.CreateValue(Int);
2247 except
2248 on E: EOverflow do
2249 RaiseOverflowArithmetic(20170711164736,Expr);
2250 end;
2251 revkUInt:
2252 // uint * uint
2253 try
2254 {$Q+}
2255 UInt:=UInt * TResEvalUInt(RightValue).UInt;
2256 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2257 Result:=TResEvalUInt.CreateValue(UInt);
2258 except
2259 RaiseOverflowArithmetic(20170711164751,Expr);
2260 end;
2261 revkFloat:
2262 // uint * float
2263 try
2264 {$Q+}
2265 Flo:=UInt * TResEvalFloat(RightValue).FloatValue;
2266 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2267 Result:=TResEvalFloat.CreateValue(Flo);
2268 except
2269 RaiseOverflowArithmetic(20170711164800,Expr);
2270 end;
2271 revkCurrency:
2272 // uint * currency
2273 try
2274 {$Q+}
2275 aCurrency:=UInt * TResEvalCurrency(RightValue).Value;
2276 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2277 Result:=TResEvalCurrency.CreateValue(aCurrency);
2278 except
2279 RaiseOverflowArithmetic(20180421164500,Expr);
2280 end;
2281 else
2282 {$IFDEF VerbosePasResolver}
2283 writeln('TResExprEvaluator.EvalBinaryMulExpr mul uint*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2284 {$ENDIF}
2285 RaiseNotYetImplemented(20170711164810,Expr);
2286 end;
2287 end;
2288 revkFloat:
2289 begin
2290 Flo:=TResEvalFloat(LeftValue).FloatValue;
2291 case RightValue.Kind of
2292 revkInt:
2293 // float * int
2294 try
2295 {$Q+}
2296 Flo:=Flo * TResEvalInt(RightValue).Int;
2297 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2298 Result:=TResEvalFloat.CreateValue(Flo);
2299 except
2300 on E: EOverflow do
2301 RaiseOverflowArithmetic(20170711164920,Expr);
2302 end;
2303 revkUInt:
2304 // float * uint
2305 try
2306 {$Q+}
2307 Flo:=Flo * TResEvalUInt(RightValue).UInt;
2308 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2309 Result:=TResEvalFloat.CreateValue(Flo);
2310 except
2311 RaiseOverflowArithmetic(20170711164940,Expr);
2312 end;
2313 revkFloat:
2314 // float * float
2315 try
2316 {$Q+}
2317 Flo:=Flo * TResEvalFloat(RightValue).FloatValue;
2318 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2319 Result:=TResEvalFloat.CreateValue(Flo);
2320 except
2321 RaiseOverflowArithmetic(20170711164955,Expr);
2322 end;
2323 revkCurrency:
2324 // float * currency
2325 try
2326 {$Q+}
2327 Flo:=Flo * TResEvalCurrency(RightValue).Value;
2328 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2329 Result:=TResEvalFloat.CreateValue(Flo);
2330 except
2331 RaiseOverflowArithmetic(20180421164542,Expr);
2332 end;
2333 else
2334 {$IFDEF VerbosePasResolver}
2335 writeln('TResExprEvaluator.EvalBinaryMulExpr mul float*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2336 {$ENDIF}
2337 RaiseNotYetImplemented(20170711165004,Expr);
2338 end;
2339 end;
2340 revkCurrency:
2341 begin
2342 aCurrency:=TResEvalCurrency(LeftValue).Value;
2343 case RightValue.Kind of
2344 revkInt:
2345 // currency * int
2346 try
2347 {$Q+}
2348 aCurrency:=aCurrency * TResEvalInt(RightValue).Int;
2349 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2350 Result:=TResEvalCurrency.CreateValue(aCurrency);
2351 except
2352 on E: EOverflow do
2353 RaiseOverflowArithmetic(20180421164636,Expr);
2354 end;
2355 revkUInt:
2356 // currency * uint
2357 try
2358 {$Q+}
2359 aCurrency:=aCurrency * TResEvalUInt(RightValue).UInt;
2360 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2361 Result:=TResEvalCurrency.CreateValue(aCurrency);
2362 except
2363 RaiseOverflowArithmetic(20180421164654,Expr);
2364 end;
2365 revkFloat:
2366 // currency * float
2367 try
2368 {$Q+}
2369 Flo:=aCurrency * TResEvalFloat(RightValue).FloatValue;
2370 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2371 Result:=TResEvalFloat.CreateValue(Flo);
2372 except
2373 RaiseOverflowArithmetic(20180421164718,Expr);
2374 end;
2375 revkCurrency:
2376 // currency * currency
2377 try
2378 {$Q+}
2379 aCurrency:=aCurrency * TResEvalCurrency(RightValue).Value;
2380 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
2381 Result:=TResEvalCurrency.CreateValue(aCurrency);
2382 except
2383 RaiseOverflowArithmetic(20180421164806,Expr);
2384 end;
2385 else
2386 {$IFDEF VerbosePasResolver}
2387 writeln('TResExprEvaluator.EvalBinaryMulExpr mul currency*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2388 {$ENDIF}
2389 RaiseNotYetImplemented(20180421164817,Expr);
2390 end;
2391 end;
2392 revkSetOfInt:
2393 case RightValue.Kind of
2394 revkSetOfInt:
2395 begin
2396 // intersect
2397 LeftSet:=TResEvalSet(LeftValue);
2398 RightSet:=TResEvalSet(RightValue);
2399 if LeftSet.ElKind=revskNone then
2400 Result:=TResEvalSet.CreateEmptySameKind(RightSet)
2401 else
2402 begin
2403 Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
2404 // add elements, which exists in both
2405 for i:=0 to length(LeftSet.Ranges)-1 do
2406 begin
2407 Int:=LeftSet.Ranges[i].RangeStart;
2408 while Int<=LeftSet.Ranges[i].RangeEnd do
2409 begin
2410 if RightSet.IndexOfRange(Int)>=0 then
2411 TResEvalSet(Result).Add(Int,Int);
2412 inc(Int);
2413 end;
2414 end;
2415 end;
2416 end;
2417 else
2418 {$IFDEF VerbosePasResolver}
2419 writeln('TResExprEvaluator.EvalBinaryMulExpr mul set*? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2420 {$ENDIF}
2421 RaiseNotYetImplemented(20170714110420,Expr);
2422 end
2423 else
2424 {$IFDEF VerbosePasResolver}
2425 writeln('TResExprEvaluator.EvalBinaryMulExpr mul ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2426 {$ENDIF}
2427 RaiseNotYetImplemented(20170525225946,Expr);
2428 end;
2429 end;
2430
EvalBinaryDivideExprnull2431 function TResExprEvaluator.EvalBinaryDivideExpr(Expr: TBinaryExpr; LeftValue,
2432 RightValue: TResEvalValue): TResEvalValue;
2433 var
2434 Int: TMaxPrecInt;
2435 UInt: TMaxPrecUInt;
2436 Flo: TMaxPrecFloat;
2437 aCurrency: TMaxPrecCurrency;
2438 begin
2439 Result:=nil;
2440 case LeftValue.Kind of
2441 revkInt:
2442 begin
2443 Int:=TResEvalInt(LeftValue).Int;
2444 case RightValue.Kind of
2445 revkInt:
2446 // int / int
2447 if TResEvalInt(RightValue).Int=0 then
2448 RaiseDivByZero(20170711143925,Expr)
2449 else
2450 Result:=TResEvalFloat.CreateValue(Int / TResEvalInt(RightValue).Int);
2451 revkUInt:
2452 // int / uint
2453 if TResEvalUInt(RightValue).UInt=0 then
2454 RaiseDivByZero(20170711144013,Expr)
2455 else
2456 Result:=TResEvalFloat.CreateValue(Int / TResEvalUInt(RightValue).UInt);
2457 revkFloat:
2458 begin
2459 // int / float
2460 try
2461 Flo:=Int / TResEvalFloat(RightValue).FloatValue;
2462 except
2463 RaiseMsg(20170711144525,nDivByZero,sDivByZero,[],Expr);
2464 end;
2465 Result:=TResEvalFloat.CreateValue(Flo);
2466 end;
2467 revkCurrency:
2468 begin
2469 // int / currency
2470 try
2471 aCurrency:=Int / TResEvalCurrency(RightValue).Value;
2472 except
2473 RaiseMsg(20180421164915,nDivByZero,sDivByZero,[],Expr);
2474 end;
2475 Result:=TResEvalCurrency.CreateValue(aCurrency);
2476 end;
2477 else
2478 {$IFDEF VerbosePasResolver}
2479 writeln('TResExprEvaluator.EvalBinaryDivideExpr int / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2480 {$ENDIF}
2481 RaiseNotYetImplemented(20170711144057,Expr);
2482 end;
2483 end;
2484 revkUInt:
2485 begin
2486 UInt:=TResEvalUInt(LeftValue).UInt;
2487 case RightValue.Kind of
2488 revkInt:
2489 // uint / int
2490 if TResEvalInt(RightValue).Int=0 then
2491 RaiseDivByZero(20170711144103,Expr)
2492 else
2493 Result:=TResEvalFloat.CreateValue(UInt / TResEvalInt(RightValue).Int);
2494 revkUInt:
2495 // uint / uint
2496 if TResEvalUInt(RightValue).UInt=0 then
2497 RaiseDivByZero(20170711144203,Expr)
2498 else
2499 Result:=TResEvalFloat.CreateValue(UInt / TResEvalUInt(RightValue).UInt);
2500 revkFloat:
2501 begin
2502 // uint / float
2503 try
2504 Flo:=UInt / TResEvalFloat(RightValue).FloatValue;
2505 except
2506 RaiseMsg(20170711144912,nDivByZero,sDivByZero,[],Expr);
2507 end;
2508 Result:=TResEvalFloat.CreateValue(Flo);
2509 end;
2510 revkCurrency:
2511 begin
2512 // uint / currency
2513 try
2514 aCurrency:=UInt / TResEvalCurrency(RightValue).Value;
2515 except
2516 RaiseMsg(20180421164959,nDivByZero,sDivByZero,[],Expr);
2517 end;
2518 Result:=TResEvalCurrency.CreateValue(aCurrency);
2519 end;
2520 else
2521 {$IFDEF VerbosePasResolver}
2522 writeln('TResExprEvaluator.EvalBinaryDivideExpr uint / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2523 {$ENDIF}
2524 RaiseNotYetImplemented(20170711144239,Expr);
2525 end;
2526 end;
2527 revkFloat:
2528 begin
2529 Flo:=TResEvalFloat(LeftValue).FloatValue;
2530 case RightValue.Kind of
2531 revkInt:
2532 // float / int
2533 if TResEvalInt(RightValue).Int=0 then
2534 RaiseDivByZero(20170711144954,Expr)
2535 else
2536 Result:=TResEvalFloat.CreateValue(Flo / TResEvalInt(RightValue).Int);
2537 revkUInt:
2538 // float / uint
2539 if TResEvalUInt(RightValue).UInt=0 then
2540 RaiseDivByZero(20170711145023,Expr)
2541 else
2542 Result:=TResEvalFloat.CreateValue(Flo / TResEvalUInt(RightValue).UInt);
2543 revkFloat:
2544 begin
2545 // float / float
2546 try
2547 Flo:=Flo / TResEvalFloat(RightValue).FloatValue;
2548 except
2549 RaiseMsg(20170711145040,nDivByZero,sDivByZero,[],Expr);
2550 end;
2551 Result:=TResEvalFloat.CreateValue(Flo);
2552 end;
2553 revkCurrency:
2554 begin
2555 // float / currency
2556 try
2557 aCurrency:=Flo / TResEvalCurrency(RightValue).Value;
2558 except
2559 RaiseMsg(20180421165058,nDivByZero,sDivByZero,[],Expr);
2560 end;
2561 Result:=TResEvalCurrency.CreateValue(aCurrency);
2562 end;
2563 else
2564 {$IFDEF VerbosePasResolver}
2565 writeln('TResExprEvaluator.EvalBinaryDivideExpr float / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2566 {$ENDIF}
2567 RaiseNotYetImplemented(20170711145050,Expr);
2568 end;
2569 end;
2570 revkCurrency:
2571 begin
2572 aCurrency:=TResEvalCurrency(LeftValue).Value;
2573 case RightValue.Kind of
2574 revkInt:
2575 // currency / int
2576 if TResEvalInt(RightValue).Int=0 then
2577 RaiseDivByZero(20180421165154,Expr)
2578 else
2579 Result:=TResEvalCurrency.CreateValue(aCurrency / TResEvalInt(RightValue).Int);
2580 revkUInt:
2581 // currency / uint
2582 if TResEvalUInt(RightValue).UInt=0 then
2583 RaiseDivByZero(20180421165205,Expr)
2584 else
2585 Result:=TResEvalCurrency.CreateValue(aCurrency / TResEvalUInt(RightValue).UInt);
2586 revkFloat:
2587 begin
2588 // currency / float
2589 try
2590 aCurrency:=aCurrency / TResEvalFloat(RightValue).FloatValue;
2591 except
2592 RaiseMsg(20180421165237,nDivByZero,sDivByZero,[],Expr);
2593 end;
2594 Result:=TResEvalCurrency.CreateValue(aCurrency);
2595 end;
2596 revkCurrency:
2597 begin
2598 // currency / currency
2599 try
2600 aCurrency:=aCurrency / TResEvalCurrency(RightValue).Value;
2601 except
2602 RaiseMsg(20180421165252,nDivByZero,sDivByZero,[],Expr);
2603 end;
2604 Result:=TResEvalCurrency.CreateValue(aCurrency);
2605 end;
2606 else
2607 {$IFDEF VerbosePasResolver}
2608 writeln('TResExprEvaluator.EvalBinaryDivideExpr currency / ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2609 {$ENDIF}
2610 RaiseNotYetImplemented(20180421165301,Expr);
2611 end;
2612 end;
2613 else
2614 {$IFDEF VerbosePasResolver}
2615 writeln('TResExprEvaluator.EvalBinaryDivExpr div ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2616 {$ENDIF}
2617 RaiseNotYetImplemented(20170530102352,Expr);
2618 end;
2619 end;
2620
TResExprEvaluator.EvalBinaryDivExprnull2621 function TResExprEvaluator.EvalBinaryDivExpr(Expr: TBinaryExpr; LeftValue,
2622 RightValue: TResEvalValue): TResEvalValue;
2623 var
2624 Int: TMaxPrecInt;
2625 UInt: TMaxPrecUInt;
2626 begin
2627 Result:=nil;
2628 case LeftValue.Kind of
2629 revkInt:
2630 case RightValue.Kind of
2631 revkInt:
2632 // int div int
2633 if TResEvalInt(RightValue).Int=0 then
2634 RaiseDivByZero(20170530102619,Expr)
2635 else
2636 begin
2637 Int:=TResEvalInt(LeftValue).Int div TResEvalInt(RightValue).Int;
2638 Result:=TResEvalInt.CreateValue(Int);
2639 end;
2640 revkUInt:
2641 // int div uint
2642 if TResEvalUInt(RightValue).UInt=0 then
2643 RaiseDivByZero(20170530102745,Expr)
2644 else
2645 begin
2646 if TResEvalUInt(RightValue).UInt>HighIntAsUInt then
2647 Int:=0
2648 else
2649 Int:=TResEvalInt(LeftValue).Int div TResEvalUInt(RightValue).UInt;
2650 Result:=TResEvalInt.CreateValue(Int);
2651 end;
2652 else
2653 {$IFDEF VerbosePasResolver}
2654 writeln('TResExprEvaluator.EvalBinaryDivExpr int div ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2655 {$ENDIF}
2656 RaiseNotYetImplemented(20170530102403,Expr);
2657 end;
2658 revkUInt:
2659 case RightValue.Kind of
2660 revkInt:
2661 // uint div int
2662 if TResEvalInt(RightValue).Int=0 then
2663 RaiseDivByZero(20170530103026,Expr)
2664 else if TResEvalUInt(LeftValue).UInt<=HighIntAsUInt then
2665 begin
2666 Int:=TMaxPrecInt(TResEvalUInt(LeftValue).UInt) div TResEvalInt(RightValue).Int;
2667 Result:=TResEvalInt.CreateValue(Int);
2668 end
2669 else if TResEvalInt(RightValue).Int>0 then
2670 begin
2671 UInt:=TResEvalUInt(LeftValue).UInt div TMaxPrecUInt(TResEvalInt(RightValue).Int);
2672 Result:=CreateResEvalInt(UInt);
2673 end
2674 else
2675 RaiseOverflowArithmetic(20170530104315,Expr);
2676 revkUInt:
2677 // uint div uint
2678 if TResEvalInt(RightValue).Int=0 then
2679 RaiseDivByZero(20170530103026,Expr)
2680 else
2681 begin
2682 UInt:=TResEvalUInt(LeftValue).UInt div TResEvalUInt(RightValue).UInt;
2683 Result:=CreateResEvalInt(UInt);
2684 end;
2685 else
2686 {$IFDEF VerbosePasResolver}
2687 writeln('TResExprEvaluator.EvalBinaryDivExpr uint div ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2688 {$ENDIF}
2689 RaiseNotYetImplemented(20170530102403,Expr);
2690 end;
2691 else
2692 {$IFDEF VerbosePasResolver}
2693 writeln('TResExprEvaluator.EvalBinaryDivExpr div ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2694 {$ENDIF}
2695 RaiseNotYetImplemented(20170530102352,Expr);
2696 end;
2697 end;
2698
EvalBinaryModExprnull2699 function TResExprEvaluator.EvalBinaryModExpr(Expr: TBinaryExpr; LeftValue,
2700 RightValue: TResEvalValue): TResEvalValue;
2701 var
2702 Int: TMaxPrecInt;
2703 UInt: TMaxPrecUInt;
2704 begin
2705 Result:=nil;
2706 case LeftValue.Kind of
2707 revkInt:
2708 case RightValue.Kind of
2709 revkInt:
2710 // int mod int
2711 if TResEvalInt(RightValue).Int=0 then
2712 RaiseDivByZero(20170530104638,Expr)
2713 else
2714 begin
2715 Int:=TResEvalInt(LeftValue).Int mod TResEvalInt(RightValue).Int;
2716 Result:=TResEvalInt.CreateValue(Int);
2717 end;
2718 revkUInt:
2719 // int mod uint
2720 if TResEvalUInt(RightValue).UInt=0 then
2721 RaiseDivByZero(20170530104758,Expr)
2722 else
2723 begin
2724 if TResEvalInt(LeftValue).Int<0 then
2725 UInt:=TMaxPrecUInt(-TResEvalInt(LeftValue).Int) mod TResEvalUInt(RightValue).UInt
2726 else
2727 UInt:=TMaxPrecUInt(TResEvalInt(LeftValue).Int) mod TResEvalUInt(RightValue).UInt;
2728 Result:=CreateResEvalInt(UInt);
2729 end;
2730 else
2731 {$IFDEF VerbosePasResolver}
2732 writeln('TResExprEvaluator.EvalBinaryModExpr int mod ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2733 {$ENDIF}
2734 RaiseNotYetImplemented(20170530110057,Expr);
2735 end;
2736 revkUInt:
2737 case RightValue.Kind of
2738 revkInt:
2739 // uint mod int
2740 if TResEvalInt(RightValue).Int=0 then
2741 RaiseDivByZero(20170530110110,Expr)
2742 else if TResEvalUInt(LeftValue).UInt<=HighIntAsUInt then
2743 begin
2744 Int:=TMaxPrecInt(TResEvalUInt(LeftValue).UInt) mod TResEvalInt(RightValue).Int;
2745 Result:=TResEvalInt.CreateValue(Int);
2746 end
2747 else if TResEvalInt(RightValue).Int>0 then
2748 begin
2749 UInt:=TResEvalUInt(LeftValue).UInt mod TMaxPrecUInt(TResEvalInt(RightValue).Int);
2750 Result:=CreateResEvalInt(UInt);
2751 end
2752 else
2753 RaiseOverflowArithmetic(20170530110602,Expr);
2754 revkUInt:
2755 // uint div uint
2756 if TResEvalInt(RightValue).Int=0 then
2757 RaiseDivByZero(20170530110609,Expr)
2758 else
2759 begin
2760 UInt:=TResEvalUInt(LeftValue).UInt mod TResEvalUInt(RightValue).UInt;
2761 Result:=CreateResEvalInt(UInt);
2762 end;
2763 else
2764 {$IFDEF VerbosePasResolver}
2765 writeln('TResExprEvaluator.EvalBinaryModExpr uint mod ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2766 {$ENDIF}
2767 RaiseNotYetImplemented(20170530110633,Expr);
2768 end;
2769 else
2770 {$IFDEF VerbosePasResolver}
2771 writeln('TResExprEvaluator.EvalBinaryModExpr mod ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2772 {$ENDIF}
2773 RaiseNotYetImplemented(20170530110644,Expr);
2774 end;
2775 end;
2776
EvalBinaryShiftExprnull2777 function TResExprEvaluator.EvalBinaryShiftExpr(Expr: TBinaryExpr; LeftValue,
2778 RightValue: TResEvalValue): TResEvalValue;
2779 var
2780 Int: TMaxPrecInt;
2781 UInt: TMaxPrecUInt;
2782 ShiftLeft: Boolean;
2783 begin
2784 Result:=nil;
2785 ShiftLeft:=Expr.OpCode=eopShl;
2786 case LeftValue.Kind of
2787 revkInt:
2788 case RightValue.Kind of
2789 revkInt:
2790 // int shl int
2791 begin
2792 if (TResEvalInt(RightValue).Int<0) or (TResEvalInt(RightValue).Int>63) then
2793 EmitRangeCheckConst(20170530203840,IntToStr(TResEvalInt(RightValue).Int),0,63,Expr);
2794 if ShiftLeft then
2795 Int:=TResEvalInt(LeftValue).Int shl byte(TResEvalInt(RightValue).Int)
2796 else
2797 Int:=TResEvalInt(LeftValue).Int shr byte(TResEvalInt(RightValue).Int);
2798 Result:=TResEvalInt.CreateValue(Int);
2799 end;
2800 revkUInt:
2801 // int shl uint
2802 begin
2803 if (TResEvalUInt(RightValue).UInt>63) then
2804 EmitRangeCheckConst(20170530203840,IntToStr(TResEvalUInt(RightValue).UInt),0,63,Expr);
2805 if ShiftLeft then
2806 Int:=TResEvalInt(LeftValue).Int shl byte(TResEvalUInt(RightValue).UInt)
2807 else
2808 Int:=TResEvalInt(LeftValue).Int shr byte(TResEvalUInt(RightValue).UInt);
2809 Result:=TResEvalInt.CreateValue(Int);
2810 end;
2811 else
2812 {$IFDEF VerbosePasResolver}
2813 writeln('TResExprEvaluator.EvalBinaryModExpr int shl/shr ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2814 {$ENDIF}
2815 RaiseNotYetImplemented(20170530205332,Expr);
2816 end;
2817 revkUInt:
2818 case RightValue.Kind of
2819 revkInt:
2820 // uint shl int
2821 begin
2822 if (TResEvalInt(RightValue).Int<0) or (TResEvalInt(RightValue).Int>63) then
2823 EmitRangeCheckConst(20170530205414,IntToStr(TResEvalInt(RightValue).Int),0,63,Expr);
2824 if ShiftLeft then
2825 UInt:=TResEvalUInt(LeftValue).UInt shl byte(TResEvalInt(RightValue).Int)
2826 else
2827 UInt:=TResEvalUInt(LeftValue).UInt shr byte(TResEvalInt(RightValue).Int);
2828 Result:=CreateResEvalInt(UInt);
2829 end;
2830 revkUInt:
2831 // uint shl uint
2832 begin
2833 if (TResEvalUInt(RightValue).UInt>63) then
2834 EmitRangeCheckConst(20170530205601,IntToStr(TResEvalUInt(RightValue).UInt),0,63,Expr);
2835 if ShiftLeft then
2836 UInt:=TResEvalUInt(LeftValue).UInt shl byte(TResEvalUInt(RightValue).UInt)
2837 else
2838 UInt:=TResEvalUInt(LeftValue).UInt shr byte(TResEvalUInt(RightValue).UInt);
2839 Result:=CreateResEvalInt(UInt);
2840 end;
2841 else
2842 {$IFDEF VerbosePasResolver}
2843 writeln('TResExprEvaluator.EvalBinaryShiftExpr uint shl/shr ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2844 {$ENDIF}
2845 RaiseNotYetImplemented(20170530205640,Expr);
2846 end;
2847 else
2848 {$IFDEF VerbosePasResolver}
2849 writeln('TResExprEvaluator.EvalBinaryShiftExpr shl/shr ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2850 {$ENDIF}
2851 RaiseNotYetImplemented(20170530205646,Expr);
2852 end;
2853 end;
2854
TResExprEvaluator.EvalBinaryBoolOpExprnull2855 function TResExprEvaluator.EvalBinaryBoolOpExpr(Expr: TBinaryExpr; LeftValue,
2856 RightValue: TResEvalValue): TResEvalValue;
2857 // AND, OR, XOR
2858 begin
2859 Result:=nil;
2860 case LeftValue.Kind of
2861 revkBool:
2862 case RightValue.Kind of
2863 revkBool:
2864 begin
2865 // logical and/or/xor
2866 Result:=TResEvalBool.Create;
2867 case Expr.OpCode of
2868 eopAnd: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B and TResEvalBool(RightValue).B;
2869 eopOr: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B or TResEvalBool(RightValue).B;
2870 eopXor: TResEvalBool(Result).B:=TResEvalBool(LeftValue).B xor TResEvalBool(RightValue).B;
2871 end;
2872 end;
2873 else
2874 {$IFDEF VerbosePasResolver}
2875 writeln('TResExprEvaluator.EvalBinaryBoolOpExpr bool ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2876 {$ENDIF}
2877 RaiseNotYetImplemented(20170531011502,Expr);
2878 end;
2879 revkInt:
2880 case RightValue.Kind of
2881 revkInt:
2882 begin
2883 // bitwise and/or/xor
2884 Result:=TResEvalInt.Create;
2885 case Expr.OpCode of
2886 eopAnd: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int and TResEvalInt(RightValue).Int;
2887 eopOr: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int or TResEvalInt(RightValue).Int;
2888 eopXor: TResEvalInt(Result).Int:=TResEvalInt(LeftValue).Int xor TResEvalInt(RightValue).Int;
2889 end;
2890 end;
2891 else
2892 {$IFDEF VerbosePasResolver}
2893 writeln('TResExprEvaluator.EvalBinaryBoolOpExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2894 {$ENDIF}
2895 RaiseNotYetImplemented(20170530211140,Expr);
2896 end;
2897 revkUInt:
2898 case RightValue.Kind of
2899 revkUInt:
2900 begin
2901 // bitwise and/or/xor
2902 Result:=TResEvalUInt.Create;
2903 case Expr.OpCode of
2904 eopAnd: TResEvalUInt(Result).UInt:=TResEvalUInt(LeftValue).UInt and TResEvalUInt(RightValue).UInt;
2905 eopOr: TResEvalUInt(Result).UInt:=TResEvalUInt(LeftValue).UInt or TResEvalUInt(RightValue).UInt;
2906 eopXor: TResEvalUInt(Result).UInt:=TResEvalUInt(LeftValue).UInt xor TResEvalUInt(RightValue).UInt;
2907 end;
2908 end;
2909 else
2910 {$IFDEF VerbosePasResolver}
2911 writeln('TResExprEvaluator.EvalBinaryBoolOpExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2912 {$ENDIF}
2913 RaiseNotYetImplemented(20170530211140,Expr);
2914 end;
2915 else
2916 {$IFDEF VerbosePasResolver}
2917 writeln('TResExprEvaluator.EvalBinaryBoolOpExpr ',Expr.OpCode,' ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2918 {$ENDIF}
2919 RaiseNotYetImplemented(20170530205938,Expr);
2920 end;
2921 end;
2922
EvalBinaryNEqualExprnull2923 function TResExprEvaluator.EvalBinaryNEqualExpr(Expr: TBinaryExpr; LeftValue,
2924 RightValue: TResEvalValue): TResEvalValue;
2925 var
2926 UInt: TMaxPrecUInt;
2927 LeftSet, RightSet: TResEvalSet;
2928 i: Integer;
2929 begin
2930 Result:=TResEvalBool.Create;
2931 try
2932 {$Q+}
2933 {$R+}
2934 case LeftValue.Kind of
2935 revkBool:
2936 case RightValue.Kind of
2937 revkBool:
2938 TResEvalBool(Result).B:=TResEvalBool(LeftValue).B=TResEvalBool(RightValue).B;
2939 else
2940 {$IFDEF VerbosePasResolver}
2941 writeln('TResExprEvaluator.EvalBinaryNEqualExpr bool ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2942 {$ENDIF}
2943 Result.Free;
2944 RaiseNotYetImplemented(20170531011937,Expr);
2945 end;
2946 revkInt:
2947 case RightValue.Kind of
2948 revkInt:
2949 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalInt(RightValue).Int;
2950 revkUInt:
2951 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalUInt(RightValue).UInt;
2952 revkFloat:
2953 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalFloat(RightValue).FloatValue;
2954 revkCurrency:
2955 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int=TResEvalCurrency(RightValue).Value;
2956 else
2957 {$IFDEF VerbosePasResolver}
2958 writeln('TResExprEvaluator.EvalBinaryNEqualExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2959 {$ENDIF}
2960 Result.Free;
2961 RaiseNotYetImplemented(20170531012412,Expr);
2962 end;
2963 revkUInt:
2964 begin
2965 UInt:=TResEvalUInt(LeftValue).UInt;
2966 case RightValue.Kind of
2967 revkInt:
2968 TResEvalBool(Result).B:=(UInt<=HighIntAsUInt)
2969 and (TMaxPrecInt(UInt)=TResEvalInt(RightValue).Int);
2970 revkUInt:
2971 TResEvalBool(Result).B:=UInt=TResEvalUInt(RightValue).UInt;
2972 revkFloat:
2973 TResEvalBool(Result).B:=UInt=TResEvalFloat(RightValue).FloatValue;
2974 revkCurrency:
2975 TResEvalBool(Result).B:=UInt=TResEvalCurrency(RightValue).Value;
2976 else
2977 {$IFDEF VerbosePasResolver}
2978 writeln('TResExprEvaluator.EvalBinaryNEqualExpr uint ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2979 {$ENDIF}
2980 Result.Free;
2981 RaiseNotYetImplemented(20170601122803,Expr);
2982 end;
2983 end;
2984 revkFloat:
2985 case RightValue.Kind of
2986 revkInt:
2987 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalInt(RightValue).Int;
2988 revkUInt:
2989 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalUInt(RightValue).UInt;
2990 revkFloat:
2991 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalFloat(RightValue).FloatValue;
2992 revkCurrency:
2993 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue=TResEvalCurrency(RightValue).Value;
2994 else
2995 {$IFDEF VerbosePasResolver}
2996 writeln('TResExprEvaluator.EvalBinaryNEqualExpr float ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
2997 {$ENDIF}
2998 Result.Free;
2999 RaiseNotYetImplemented(20170601122806,Expr);
3000 end;
3001 revkCurrency:
3002 case RightValue.Kind of
3003 revkInt:
3004 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalInt(RightValue).Int;
3005 revkUInt:
3006 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalUInt(RightValue).UInt;
3007 revkFloat:
3008 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalFloat(RightValue).FloatValue;
3009 revkCurrency:
3010 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value=TResEvalCurrency(RightValue).Value;
3011 else
3012 {$IFDEF VerbosePasResolver}
3013 writeln('TResExprEvaluator.EvalBinaryNEqualExpr currency ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3014 {$ENDIF}
3015 Result.Free;
3016 RaiseNotYetImplemented(20180421165438,Expr);
3017 end;
3018 {$ifdef FPC_HAS_CPSTRING}
3019 revkString:
3020 case RightValue.Kind of
3021 revkString:
3022 if GetCodePage(TResEvalString(LeftValue).S)=GetCodePage(TResEvalString(RightValue).S) then
3023 TResEvalBool(Result).B:=TResEvalString(LeftValue).S=TResEvalString(RightValue).S
3024 else
3025 TResEvalBool(Result).B:=GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left)
3026 =GetUnicodeStr(TResEvalString(RightValue).S,Expr.right);
3027 revkUnicodeString:
3028 TResEvalBool(Result).B:=GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left)
3029 =TResEvalUTF16(RightValue).S;
3030 else
3031 {$IFDEF VerbosePasResolver}
3032 writeln('TResExprEvaluator.EvalBinaryNEqualExpr string ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3033 {$ENDIF}
3034 Result.Free;
3035 RaiseNotYetImplemented(20170711175409,Expr);
3036 end;
3037 {$endif}
3038 revkUnicodeString:
3039 case RightValue.Kind of
3040 {$ifdef FPC_HAS_CPSTRING}
3041 revkString:
3042 TResEvalBool(Result).B:=TResEvalUTF16(LeftValue).S
3043 =GetUnicodeStr(TResEvalString(RightValue).S,Expr.right);
3044 {$endif}
3045 revkUnicodeString:
3046 TResEvalBool(Result).B:=TResEvalUTF16(LeftValue).S
3047 =TResEvalUTF16(RightValue).S;
3048 else
3049 {$IFDEF VerbosePasResolver}
3050 writeln('TResExprEvaluator.EvalBinaryNEqualExpr string ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3051 {$ENDIF}
3052 Result.Free;
3053 RaiseNotYetImplemented(20170711175409,Expr);
3054 end;
3055 revkSetOfInt:
3056 case RightValue.Kind of
3057 revkSetOfInt:
3058 begin
3059 LeftSet:=TResEvalSet(LeftValue);
3060 RightSet:=TResEvalSet(RightValue);
3061 if LeftSet.ElKind=revskNone then
3062 TResEvalBool(Result).B:=length(RightSet.Ranges)=0
3063 else if RightSet.ElKind=revskNone then
3064 TResEvalBool(Result).B:=length(LeftSet.Ranges)=0
3065 else if length(LeftSet.Ranges)<>length(RightSet.Ranges) then
3066 TResEvalBool(Result).B:=false
3067 else
3068 begin
3069 TResEvalBool(Result).B:=true;
3070 for i:=0 to length(LeftSet.Ranges)-1 do
3071 if (LeftSet.Ranges[i].RangeStart<>RightSet.Ranges[i].RangeStart)
3072 or (LeftSet.Ranges[i].RangeEnd<>RightSet.Ranges[i].RangeEnd) then
3073 begin
3074 TResEvalBool(Result).B:=false;
3075 break;
3076 end;
3077 end;
3078 end;
3079 else
3080 {$IFDEF VerbosePasResolver}
3081 writeln('TResExprEvaluator.EvalBinaryNEqualExpr ',Expr.OpCode,' set=? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3082 {$ENDIF}
3083 RaiseNotYetImplemented(20170714120756,Expr);
3084 end;
3085 else
3086 {$IFDEF VerbosePasResolver}
3087 writeln('TResExprEvaluator.EvalBinaryNEqualExpr ',Expr.OpCode,' ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3088 {$ENDIF}
3089 Result.Free;
3090 RaiseNotYetImplemented(20170531011931,Expr);
3091 end;
3092 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3093 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3094 except
3095 on EOverflow do
3096 RaiseOverflowArithmetic(20170601132729,Expr);
3097 on ERangeError do
3098 RaiseRangeCheck(20170601132740,Expr);
3099 end;
3100 if Expr.OpCode=eopNotEqual then
3101 TResEvalBool(Result).B:=not TResEvalBool(Result).B;
3102 end;
3103
TResExprEvaluator.EvalBinaryLessGreaterExprnull3104 function TResExprEvaluator.EvalBinaryLessGreaterExpr(Expr: TBinaryExpr;
3105 LeftValue, RightValue: TResEvalValue): TResEvalValue;
3106
3107 procedure CmpUnicode(const LeftUnicode, RightUnicode: UnicodeString);
3108 begin
3109 case Expr.OpCode of
3110 eopLessThan:
3111 TResEvalBool(Result).B:=LeftUnicode < RightUnicode;
3112 eopGreaterThan:
3113 TResEvalBool(Result).B:=LeftUnicode > RightUnicode;
3114 eopLessthanEqual:
3115 TResEvalBool(Result).B:=LeftUnicode <= RightUnicode;
3116 eopGreaterThanEqual:
3117 TResEvalBool(Result).B:=LeftUnicode >= RightUnicode;
3118 end;
3119 end;
3120
3121 var
3122 LeftSet, RightSet: TResEvalSet;
3123 i: Integer;
3124 Int: TMaxPrecInt;
3125 begin
3126 Result:=TResEvalBool.Create;
3127 try
3128 {$Q+}
3129 {$R+}
3130 case LeftValue.Kind of
3131 revkInt:
3132 case RightValue.Kind of
3133 revkInt:
3134 case Expr.OpCode of
3135 eopLessThan:
3136 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalInt(RightValue).Int;
3137 eopGreaterThan:
3138 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalInt(RightValue).Int;
3139 eopLessthanEqual:
3140 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalInt(RightValue).Int;
3141 eopGreaterThanEqual:
3142 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalInt(RightValue).Int;
3143 end;
3144 revkUInt:
3145 case Expr.OpCode of
3146 eopLessThan:
3147 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalUInt(RightValue).UInt;
3148 eopGreaterThan:
3149 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalUInt(RightValue).UInt;
3150 eopLessthanEqual:
3151 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalUInt(RightValue).UInt;
3152 eopGreaterThanEqual:
3153 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalUInt(RightValue).UInt;
3154 end;
3155 revkFloat:
3156 case Expr.OpCode of
3157 eopLessThan:
3158 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalFloat(RightValue).FloatValue;
3159 eopGreaterThan:
3160 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalFloat(RightValue).FloatValue;
3161 eopLessthanEqual:
3162 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalFloat(RightValue).FloatValue;
3163 eopGreaterThanEqual:
3164 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalFloat(RightValue).FloatValue;
3165 end;
3166 revkCurrency:
3167 case Expr.OpCode of
3168 eopLessThan:
3169 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int < TResEvalCurrency(RightValue).Value;
3170 eopGreaterThan:
3171 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int > TResEvalCurrency(RightValue).Value;
3172 eopLessthanEqual:
3173 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int <= TResEvalCurrency(RightValue).Value;
3174 eopGreaterThanEqual:
3175 TResEvalBool(Result).B:=TResEvalInt(LeftValue).Int >= TResEvalCurrency(RightValue).Value;
3176 end;
3177 else
3178 {$IFDEF VerbosePasResolver}
3179 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr int ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3180 {$ENDIF}
3181 Result.Free;
3182 RaiseNotYetImplemented(20170601122512,Expr);
3183 end;
3184 revkUInt:
3185 case RightValue.Kind of
3186 revkInt:
3187 case Expr.OpCode of
3188 eopLessThan:
3189 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalInt(RightValue).Int;
3190 eopGreaterThan:
3191 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalInt(RightValue).Int;
3192 eopLessthanEqual:
3193 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalInt(RightValue).Int;
3194 eopGreaterThanEqual:
3195 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalInt(RightValue).Int;
3196 end;
3197 revkUInt:
3198 case Expr.OpCode of
3199 eopLessThan:
3200 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalUInt(RightValue).UInt;
3201 eopGreaterThan:
3202 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalUInt(RightValue).UInt;
3203 eopLessthanEqual:
3204 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalUInt(RightValue).UInt;
3205 eopGreaterThanEqual:
3206 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalUInt(RightValue).UInt;
3207 end;
3208 revkFloat:
3209 case Expr.OpCode of
3210 eopLessThan:
3211 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalFloat(RightValue).FloatValue;
3212 eopGreaterThan:
3213 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalFloat(RightValue).FloatValue;
3214 eopLessthanEqual:
3215 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalFloat(RightValue).FloatValue;
3216 eopGreaterThanEqual:
3217 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalFloat(RightValue).FloatValue;
3218 end;
3219 revkCurrency:
3220 case Expr.OpCode of
3221 eopLessThan:
3222 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt < TResEvalCurrency(RightValue).Value;
3223 eopGreaterThan:
3224 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt > TResEvalCurrency(RightValue).Value;
3225 eopLessthanEqual:
3226 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt <= TResEvalCurrency(RightValue).Value;
3227 eopGreaterThanEqual:
3228 TResEvalBool(Result).B:=TResEvalUInt(LeftValue).UInt >= TResEvalCurrency(RightValue).Value;
3229 end;
3230 else
3231 {$IFDEF VerbosePasResolver}
3232 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr uint ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3233 {$ENDIF}
3234 Result.Free;
3235 RaiseNotYetImplemented(20170601133222,Expr);
3236 end;
3237 revkFloat:
3238 case RightValue.Kind of
3239 revkInt:
3240 case Expr.OpCode of
3241 eopLessThan:
3242 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalInt(RightValue).Int;
3243 eopGreaterThan:
3244 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalInt(RightValue).Int;
3245 eopLessthanEqual:
3246 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalInt(RightValue).Int;
3247 eopGreaterThanEqual:
3248 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalInt(RightValue).Int;
3249 end;
3250 revkUInt:
3251 case Expr.OpCode of
3252 eopLessThan:
3253 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalUInt(RightValue).UInt;
3254 eopGreaterThan:
3255 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalUInt(RightValue).UInt;
3256 eopLessthanEqual:
3257 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalUInt(RightValue).UInt;
3258 eopGreaterThanEqual:
3259 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalUInt(RightValue).UInt;
3260 end;
3261 revkFloat:
3262 case Expr.OpCode of
3263 eopLessThan:
3264 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalFloat(RightValue).FloatValue;
3265 eopGreaterThan:
3266 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalFloat(RightValue).FloatValue;
3267 eopLessthanEqual:
3268 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalFloat(RightValue).FloatValue;
3269 eopGreaterThanEqual:
3270 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalFloat(RightValue).FloatValue;
3271 end;
3272 revkCurrency:
3273 case Expr.OpCode of
3274 eopLessThan:
3275 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue < TResEvalCurrency(RightValue).Value;
3276 eopGreaterThan:
3277 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue > TResEvalCurrency(RightValue).Value;
3278 eopLessthanEqual:
3279 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue <= TResEvalCurrency(RightValue).Value;
3280 eopGreaterThanEqual:
3281 TResEvalBool(Result).B:=TResEvalFloat(LeftValue).FloatValue >= TResEvalCurrency(RightValue).Value;
3282 end;
3283 else
3284 {$IFDEF VerbosePasResolver}
3285 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr float ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3286 {$ENDIF}
3287 Result.Free;
3288 RaiseNotYetImplemented(20170601133421,Expr);
3289 end;
3290 revkCurrency:
3291 case RightValue.Kind of
3292 revkInt:
3293 case Expr.OpCode of
3294 eopLessThan:
3295 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalInt(RightValue).Int;
3296 eopGreaterThan:
3297 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalInt(RightValue).Int;
3298 eopLessthanEqual:
3299 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalInt(RightValue).Int;
3300 eopGreaterThanEqual:
3301 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalInt(RightValue).Int;
3302 end;
3303 revkUInt:
3304 case Expr.OpCode of
3305 eopLessThan:
3306 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalUInt(RightValue).UInt;
3307 eopGreaterThan:
3308 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalUInt(RightValue).UInt;
3309 eopLessthanEqual:
3310 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalUInt(RightValue).UInt;
3311 eopGreaterThanEqual:
3312 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalUInt(RightValue).UInt;
3313 end;
3314 revkFloat:
3315 case Expr.OpCode of
3316 eopLessThan:
3317 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalFloat(RightValue).FloatValue;
3318 eopGreaterThan:
3319 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalFloat(RightValue).FloatValue;
3320 eopLessthanEqual:
3321 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalFloat(RightValue).FloatValue;
3322 eopGreaterThanEqual:
3323 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalFloat(RightValue).FloatValue;
3324 end;
3325 revkCurrency:
3326 case Expr.OpCode of
3327 eopLessThan:
3328 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value < TResEvalCurrency(RightValue).Value;
3329 eopGreaterThan:
3330 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value > TResEvalCurrency(RightValue).Value;
3331 eopLessthanEqual:
3332 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value <= TResEvalCurrency(RightValue).Value;
3333 eopGreaterThanEqual:
3334 TResEvalBool(Result).B:=TResEvalCurrency(LeftValue).Value >= TResEvalCurrency(RightValue).Value;
3335 end;
3336 else
3337 {$IFDEF VerbosePasResolver}
3338 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr currency ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3339 {$ENDIF}
3340 Result.Free;
3341 RaiseNotYetImplemented(20180421165752,Expr);
3342 end;
3343 {$ifdef FPC_HAS_CPSTRING}
3344 revkString:
3345 case RightValue.Kind of
3346 revkString:
3347 if GetCodePage(TResEvalString(LeftValue).S)=GetCodePage(TResEvalString(RightValue).S) then
3348 case Expr.OpCode of
3349 eopLessThan:
3350 TResEvalBool(Result).B:=TResEvalString(LeftValue).S < TResEvalString(RightValue).S;
3351 eopGreaterThan:
3352 TResEvalBool(Result).B:=TResEvalString(LeftValue).S > TResEvalString(RightValue).S;
3353 eopLessthanEqual:
3354 TResEvalBool(Result).B:=TResEvalString(LeftValue).S <= TResEvalString(RightValue).S;
3355 eopGreaterThanEqual:
3356 TResEvalBool(Result).B:=TResEvalString(LeftValue).S >= TResEvalString(RightValue).S;
3357 end
3358 else
3359 CmpUnicode(GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left),
3360 GetUnicodeStr(TResEvalString(RightValue).S,Expr.right));
3361 revkUnicodeString:
3362 CmpUnicode(GetUnicodeStr(TResEvalString(LeftValue).S,Expr.left),
3363 TResEvalUTF16(RightValue).S);
3364 else
3365 {$IFDEF VerbosePasResolver}
3366 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr string ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3367 {$ENDIF}
3368 Result.Free;
3369 RaiseNotYetImplemented(20170711175629,Expr);
3370 end;
3371 {$endif}
3372 revkUnicodeString:
3373 case RightValue.Kind of
3374 {$ifdef FPC_HAS_CPSTRING}
3375 revkString:
3376 CmpUnicode(TResEvalUTF16(LeftValue).S,
3377 GetUnicodeStr(TResEvalString(RightValue).S,Expr.right));
3378 {$endif}
3379 revkUnicodeString:
3380 CmpUnicode(TResEvalUTF16(LeftValue).S,TResEvalUTF16(RightValue).S);
3381 else
3382 {$IFDEF VerbosePasResolver}
3383 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr unicodestring ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3384 {$ENDIF}
3385 Result.Free;
3386 RaiseNotYetImplemented(20170711210730,Expr);
3387 end;
3388 revkSetOfInt:
3389 case RightValue.Kind of
3390 revkSetOfInt:
3391 begin
3392 LeftSet:=TResEvalSet(LeftValue);
3393 RightSet:=TResEvalSet(RightValue);
3394 case Expr.OpCode of
3395 eopGreaterThanEqual:
3396 begin
3397 // >= -> true if all elements of RightSet are in LeftSet
3398 TResEvalBool(Result).B:=true;
3399 for i:=0 to length(RightSet.Ranges)-1 do
3400 begin
3401 Int:=RightSet.Ranges[i].RangeStart;
3402 while Int<=RightSet.Ranges[i].RangeEnd do
3403 begin
3404 if LeftSet.IndexOfRange(Int)<0 then
3405 begin
3406 TResEvalBool(Result).B:=false;
3407 break;
3408 end;
3409 inc(Int);
3410 end;
3411 end;
3412 end;
3413 eopLessthanEqual:
3414 begin
3415 // <= -> true if all elements of LeftSet are in RightSet
3416 TResEvalBool(Result).B:=true;
3417 for i:=0 to length(LeftSet.Ranges)-1 do
3418 begin
3419 Int:=LeftSet.Ranges[i].RangeStart;
3420 while Int<=LeftSet.Ranges[i].RangeEnd do
3421 begin
3422 if RightSet.IndexOfRange(Int)<0 then
3423 begin
3424 TResEvalBool(Result).B:=false;
3425 break;
3426 end;
3427 inc(Int);
3428 end;
3429 end;
3430 end
3431 else
3432 {$IFDEF VerbosePasResolver}
3433 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr set ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3434 {$ENDIF}
3435 Result.Free;
3436 RaiseNotYetImplemented(20170714122121,Expr);
3437 end;
3438 end;
3439 else
3440 {$IFDEF VerbosePasResolver}
3441 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr set ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3442 {$ENDIF}
3443 Result.Free;
3444 RaiseNotYetImplemented(20170714121925,Expr);
3445 end;
3446 else
3447 {$IFDEF VerbosePasResolver}
3448 writeln('TResExprEvaluator.EvalBinaryLowerGreaterExpr ? ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3449 {$ENDIF}
3450 Result.Free;
3451 RaiseNotYetImplemented(20170601122529,Expr);
3452 end;
3453 except
3454 on EOverflow do
3455 RaiseOverflowArithmetic(20170601132956,Expr);
3456 on ERangeError do
3457 RaiseRangeCheck(20170601132958,Expr);
3458 end;
3459 end;
3460
EvalBinaryInExprnull3461 function TResExprEvaluator.EvalBinaryInExpr(Expr: TBinaryExpr; LeftValue,
3462 RightValue: TResEvalValue): TResEvalValue;
3463 var
3464 RightSet: TResEvalSet;
3465 Int: TMaxPrecInt;
3466 begin
3467 Result:=nil;
3468 case RightValue.Kind of
3469 revkSetOfInt:
3470 begin
3471 RightSet:=TResEvalSet(RightValue);
3472 case LeftValue.Kind of
3473 revkBool:
3474 Int:=ord(TResEvalBool(LeftValue).B);
3475 revkInt:
3476 Int:=TResEvalInt(LeftValue).Int;
3477 revkUInt:
3478 // Note: when FPC compares int64 with qword it converts the qword to an int64
3479 if TResEvalUInt(LeftValue).UInt>HighIntAsUInt then
3480 RaiseMsg(20170714123700,nRangeCheckError,sRangeCheckError,[],Expr)
3481 else
3482 Int:=TResEvalUInt(LeftValue).UInt;
3483 {$ifdef FPC_HAS_CPSTRING}
3484 revkString,
3485 {$endif}
3486 revkUnicodeString:
3487 Int:=StringToOrd(LeftValue,Expr);
3488 revkEnum:
3489 Int:=TResEvalEnum(LeftValue).Index;
3490 else
3491 {$IFDEF VerbosePasResolver}
3492 writeln('TResExprEvaluator.EvalBinaryInExpr ? in Set Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3493 {$ENDIF}
3494 RaiseNotYetImplemented(20170714123412,Expr);
3495 end;
3496 Result:=TResEvalBool.CreateValue(RightSet.IndexOfRange(Int)>=0);
3497 end;
3498 else
3499 {$IFDEF VerbosePasResolver}
3500 writeln('TResExprEvaluator.EvalBinaryInExpr ? ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3501 {$ENDIF}
3502 RaiseNotYetImplemented(20170714123409,Expr);
3503 end;
3504 end;
3505
EvalBinarySymmetricaldifferenceExprnull3506 function TResExprEvaluator.EvalBinarySymmetricaldifferenceExpr(
3507 Expr: TBinaryExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
3508 var
3509 LeftSet, RightSet: TResEvalSet;
3510 i: Integer;
3511 Int: TMaxPrecInt;
3512 begin
3513 case LeftValue.Kind of
3514 revkSetOfInt:
3515 case RightValue.Kind of
3516 revkSetOfInt:
3517 begin
3518 // sym diff
3519 LeftSet:=TResEvalSet(LeftValue);
3520 RightSet:=TResEvalSet(RightValue);
3521 // elements, which exists in either, but not both
3522 if LeftSet.ElKind=revskNone then
3523 Result:=RightSet.Clone
3524 else
3525 begin
3526 Result:=TResEvalSet.CreateEmptySameKind(LeftSet);
3527 for i:=0 to length(LeftSet.Ranges)-1 do
3528 begin
3529 Int:=LeftSet.Ranges[i].RangeStart;
3530 while Int<=LeftSet.Ranges[i].RangeEnd do
3531 begin
3532 if RightSet.IndexOfRange(Int)<0 then
3533 TResEvalSet(Result).Add(Int,Int);
3534 inc(Int);
3535 end;
3536 end;
3537 for i:=0 to length(RightSet.Ranges)-1 do
3538 begin
3539 Int:=RightSet.Ranges[i].RangeStart;
3540 while Int<=RightSet.Ranges[i].RangeEnd do
3541 begin
3542 if LeftSet.IndexOfRange(Int)<0 then
3543 TResEvalSet(Result).Add(Int,Int);
3544 inc(Int);
3545 end;
3546 end;
3547 end;
3548 end
3549 else
3550 {$IFDEF VerbosePasResolver}
3551 writeln('TResExprEvaluator.EvalBinarySymmetricaldifferenceExpr Set><? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3552 {$ENDIF}
3553 RaiseNotYetImplemented(20170714114144,Expr);
3554 end;
3555 else
3556 {$IFDEF VerbosePasResolver}
3557 writeln('TResExprEvaluator.EvalBinarySymmetricaldifferenceExpr ? ',Expr.OpCode,' ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3558 {$ENDIF}
3559 RaiseNotYetImplemented(20170714114119,Expr);
3560 end;
3561 end;
3562
EvalParamsExprnull3563 function TResExprEvaluator.EvalParamsExpr(Expr: TParamsExpr;
3564 Flags: TResEvalFlags): TResEvalValue;
3565 begin
3566 Result:=OnEvalParams(Self,Expr,Flags);
3567 if Result<>nil then exit;
3568 case Expr.Kind of
3569 pekArrayParams: Result:=EvalArrayParamsExpr(Expr,Flags);
3570 pekSet: Result:=EvalSetParamsExpr(Expr,Flags);
3571 end;
3572 if Result=nil then
3573 begin
3574 if [refConst,refConstExt]*Flags<>[] then
3575 RaiseConstantExprExp(20170713124038,Expr);
3576 exit;
3577 end;
3578 end;
3579
TResExprEvaluator.EvalArrayParamsExprnull3580 function TResExprEvaluator.EvalArrayParamsExpr(Expr: TParamsExpr;
3581 Flags: TResEvalFlags): TResEvalValue;
3582 var
3583 ArrayValue, IndexValue: TResEvalValue;
3584 Int: TMaxPrecInt;
3585 Param0: TPasExpr;
3586 MaxIndex: Integer;
3587 begin
3588 Result:=nil;
3589 ArrayValue:=Eval(Expr.Value,Flags);
3590 if ArrayValue=nil then
3591 begin
3592 if [refConst,refConstExt]*Flags<>[] then
3593 RaiseConstantExprExp(20170711181321,Expr.Value);
3594 exit;
3595 end;
3596 IndexValue:=nil;
3597 try
3598 case ArrayValue.Kind of
3599 {$ifdef FPC_HAS_CPSTRING}
3600 revkString,
3601 {$endif}
3602 revkUnicodeString:
3603 begin
3604 // string[index]
3605 Param0:=Expr.Params[0];
3606 IndexValue:=Eval(Param0,Flags);
3607 if IndexValue=nil then
3608 begin
3609 if [refConst,refConstExt]*Flags<>[] then
3610 RaiseConstantExprExp(20170711181603,Param0);
3611 exit;
3612 end;
3613 case IndexValue.Kind of
3614 revkInt: Int:=TResEvalInt(IndexValue).Int;
3615 revkUInt:
3616 // Note: when FPC compares int64 with qword it converts the qword to an int64
3617 if TResEvalUInt(IndexValue).UInt>HighIntAsUInt then
3618 RaiseRangeCheck(20170711182006,Param0)
3619 else
3620 Int:=TResEvalUInt(IndexValue).UInt;
3621 else
3622 {$IFDEF VerbosePasResolver}
3623 writeln('TResExprEvaluator.EvalParamsExpr string[',IndexValue.AsDebugString,']');
3624 {$ENDIF}
3625 RaiseNotYetImplemented(20170711182100,Expr);
3626 end;
3627 {$ifdef FPC_HAS_CPSTRING}
3628 if ArrayValue.Kind=revkString then
3629 MaxIndex:=length(TResEvalString(ArrayValue).S)
3630 else
3631 {$endif}
3632 MaxIndex:=length(TResEvalUTF16(ArrayValue).S);
3633 if (Int<1) or (Int>MaxIndex) then
3634 EmitRangeCheckConst(20170711183058,IntToStr(Int),'1',IntToStr(MaxIndex),Param0,mtError);
3635 {$ifdef FPC_HAS_CPSTRING}
3636 if ArrayValue.Kind=revkString then
3637 Result:=TResEvalString.CreateValue(TResEvalString(ArrayValue).S[Int])
3638 else
3639 {$endif}
3640 Result:=TResEvalUTF16.CreateValue(TResEvalUTF16(ArrayValue).S[Int]);
3641 exit;
3642 end;
3643 else
3644 {$IFDEF VerbosePasResolver}
3645 writeln('TResExprEvaluator.EvalParamsExpr Array=',ArrayValue.AsDebugString);
3646 {$ENDIF}
3647 RaiseNotYetImplemented(20170711181507,Expr);
3648 end;
3649
3650 if [refConst,refConstExt]*Flags<>[] then
3651 RaiseConstantExprExp(20170522173150,Expr);
3652 finally
3653 ReleaseEvalValue(ArrayValue);
3654 ReleaseEvalValue(IndexValue);
3655 end;
3656 end;
3657
EvalSetParamsExprnull3658 function TResExprEvaluator.EvalSetParamsExpr(Expr: TParamsExpr;
3659 Flags: TResEvalFlags): TResEvalSet;
3660 begin
3661 {$IFDEF VerbosePasResEval}
3662 writeln('TResExprEvaluator.EvalSetParamsExpr length(Expr.Params)=',length(Expr.Params));
3663 {$ENDIF}
3664 Result:=EvalSetExpr(Expr,Expr.Params,Flags);
3665 end;
3666
EvalSetExprnull3667 function TResExprEvaluator.EvalSetExpr(Expr: TPasExpr;
3668 ExprArray: TPasExprArray; Flags: TResEvalFlags): TResEvalSet;
3669 var
3670 i: Integer;
3671 RangeStart, RangeEnd: TMaxPrecInt;
3672 Value: TResEvalValue;
3673 ok, OnlyConstElements: Boolean;
3674 El: TPasExpr;
3675 begin
3676 {$IFDEF VerbosePasResEval}
3677 writeln('TResExprEvaluator.EvalSetExpr Expr=',GetObjName(Expr),' length(ExprArray)=',length(ExprArray));
3678 {$ENDIF}
3679 Result:=TResEvalSet.Create;
3680 if Expr=nil then ;
3681 Value:=nil;
3682 OnlyConstElements:=true;
3683 ok:=false;
3684 try
3685 for i:=0 to length(ExprArray)-1 do
3686 begin
3687 El:=ExprArray[i];
3688 {$IFDEF VerbosePasResEval}
3689 writeln('TResExprEvaluator.EvalSetExpr ',i,' of ',length(ExprArray),' El=',GetObjName(El));
3690 {$ENDIF}
3691 Value:=Eval(El,Flags);
3692 if Value=nil then
3693 begin
3694 // element is not a const -> the set is not a const
3695 OnlyConstElements:=false;
3696 continue;
3697 end;
3698 {$IFDEF VerbosePasResEval}
3699 //writeln('TResExprEvaluator.EvalSetExpr ',i,' of ',length(ExprArray),' Value=',Value.AsDebugString);
3700 {$ENDIF}
3701 case Value.Kind of
3702 revkBool:
3703 begin
3704 if Result.ElKind=revskNone then
3705 Result.ElKind:=revskBool
3706 else if Result.ElKind<>revskBool then
3707 RaiseNotYetImplemented(20170714132843,El);
3708 RangeStart:=ord(TResEvalBool(Value).B);
3709 RangeEnd:=RangeStart;
3710 end;
3711 revkInt:
3712 begin
3713 if Result.ElKind=revskNone then
3714 Result.ElKind:=revskInt
3715 else if Result.ElKind<>revskInt then
3716 RaiseNotYetImplemented(20170713201208,El);
3717 RangeStart:=TResEvalInt(Value).Int;
3718 RangeEnd:=RangeStart;
3719 end;
3720 revkUInt:
3721 begin
3722 if Result.ElKind=revskNone then
3723 Result.ElKind:=revskInt
3724 else if Result.ElKind<>revskInt then
3725 RaiseNotYetImplemented(20170713201230,El)
3726 // Note: when FPC compares int64 with qword it converts the qword to an int64
3727 else if TResEvalUInt(Value).UInt>HighIntAsUInt then
3728 EmitRangeCheckConst(20170713201306,Value.AsString,
3729 '0',IntToStr(High(TMaxPrecInt)),El,mtError);
3730 RangeStart:=TResEvalUInt(Value).UInt;
3731 RangeEnd:=RangeStart;
3732 end;
3733 {$ifdef FPC_HAS_CPSTRING}
3734 revkString:
3735 begin
3736 if Result.ElKind=revskNone then
3737 Result.ElKind:=revskChar
3738 else if Result.ElKind<>revskChar then
3739 RaiseNotYetImplemented(20170713201456,El);
3740 RangeStart:=StringToOrd(Value,nil);
3741 if RangeStart>$ffff then
3742 begin
3743 // set of string (not of char)
3744 ReleaseEvalValue(TResEvalValue(Result));
3745 exit;
3746 end;
3747 RangeEnd:=RangeStart;
3748 end;
3749 {$endif}
3750 revkUnicodeString:
3751 begin
3752 if Result.ElKind=revskNone then
3753 Result.ElKind:=revskChar
3754 else if Result.ElKind<>revskChar then
3755 RaiseNotYetImplemented(20170713201516,El);
3756 if length(TResEvalUTF16(Value).S)<>1 then
3757 begin
3758 // set of string (not of char)
3759 ReleaseEvalValue(TResEvalValue(Result));
3760 exit;
3761 end;
3762 RangeStart:=ord(TResEvalUTF16(Value).S[1]);
3763 RangeEnd:=RangeStart;
3764 end;
3765 revkEnum:
3766 begin
3767 if Result.ElKind=revskNone then
3768 begin
3769 Result.ElKind:=revskEnum;
3770 Result.ElType:=Value.IdentEl.Parent as TPasEnumType;
3771 end
3772 else if Result.ElKind<>revskEnum then
3773 RaiseNotYetImplemented(20170713143559,El)
3774 else if Result.ElType<>TResEvalEnum(Value).ElType then
3775 RaiseNotYetImplemented(20170713201021,El);
3776 RangeStart:=TResEvalEnum(Value).Index;
3777 RangeEnd:=RangeStart;
3778 end;
3779 revkRangeInt:
3780 begin
3781 if Result.ElKind=revskNone then
3782 begin
3783 Result.ElKind:=TResEvalRangeInt(Value).ElKind;
3784 if Result.ElKind=revskEnum then
3785 Result.ElType:=TResEvalRangeInt(Value).ElType;
3786 end
3787 else if Result.ElKind<>TResEvalRangeInt(Value).ElKind then
3788 RaiseNotYetImplemented(20170714101910,El);
3789 RangeStart:=TResEvalRangeInt(Value).RangeStart;
3790 RangeEnd:=TResEvalRangeInt(Value).RangeEnd;
3791 end;
3792 revkRangeUInt:
3793 begin
3794 if Result.ElKind=revskNone then
3795 Result.ElKind:=revskInt
3796 else if Result.ElKind<>revskInt then
3797 RaiseNotYetImplemented(20170713202934,El)
3798 // Note: when FPC compares int64 with qword it converts the qword to an int64
3799 else if TResEvalRangeUInt(Value).RangeEnd>HighIntAsUInt then
3800 EmitRangeCheckConst(20170713203034,Value.AsString,
3801 '0',IntToStr(High(TMaxPrecInt)),El,mtError);
3802 RangeStart:=TResEvalRangeUInt(Value).RangeStart;
3803 RangeEnd:=TResEvalRangeUInt(Value).RangeEnd;
3804 end
3805 else
3806 {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
3807 writeln('TResExprEvaluator.EvalSetExpr Result.ElKind=',Result.ElKind,' Value.Kind=',Value.Kind);
3808 {$ENDIF}
3809 RaiseNotYetImplemented(20170713143422,El);
3810 end;
3811
3812 if Result.Intersects(RangeStart,RangeEnd)>=0 then
3813 begin
3814 {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
3815 writeln('TResExprEvaluator.EvalSetExpr Value=',Value.AsDebugString,' Range=',RangeStart,'..',RangeEnd,' Result=',Result.AsDebugString);
3816 {$ENDIF}
3817 RaiseMsg(20170714141326,nRangeCheckInSetConstructor,
3818 sRangeCheckInSetConstructor,[],El);
3819 end;
3820 Result.Add(RangeStart,RangeEnd);
3821 ReleaseEvalValue(Value);
3822 end;
3823 ok:=OnlyConstElements;
3824 finally
3825 ReleaseEvalValue(Value);
3826 if not ok then
3827 ReleaseEvalValue(TResEvalValue(Result));
3828 end;
3829 end;
3830
TResExprEvaluator.EvalArrayValuesExprnull3831 function TResExprEvaluator.EvalArrayValuesExpr(Expr: TArrayValues;
3832 Flags: TResEvalFlags): TResEvalSet;
3833 begin
3834 {$IFDEF VerbosePasResEval}
3835 writeln('TResExprEvaluator.EvalArrayValuesExpr length(Expr.Values)=',length(Expr.Values));
3836 {$ENDIF}
3837 Result:=EvalSetExpr(Expr,Expr.Values,Flags);
3838 end;
3839
TResExprEvaluator.EvalBinaryPowerExprnull3840 function TResExprEvaluator.EvalBinaryPowerExpr(Expr: TBinaryExpr; LeftValue,
3841 RightValue: TResEvalValue): TResEvalValue;
3842 var
3843 Int: TMaxPrecInt;
3844 Flo: TMaxPrecFloat;
3845 aCurrency: TMaxPrecCurrency;
3846 begin
3847 Result:=nil;
3848 case LeftValue.Kind of
3849 revkInt:
3850 case RightValue.Kind of
3851 revkInt:
3852 // int^^int
3853 try
3854 {$Q+}{$R+}
3855 Int:=trunc(Math.power(TResEvalInt(LeftValue).Int,TResEvalInt(RightValue).Int));
3856 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3857 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3858 Result:=TResEvalInt.CreateValue(Int);
3859 except
3860 RaiseOverflowArithmetic(20170530210533,Expr);
3861 end;
3862 revkUInt:
3863 // int^^uint
3864 try
3865 {$Q+}{$R+}
3866 Int:=trunc(Math.power(TResEvalInt(LeftValue).Int,TResEvalUInt(RightValue).UInt));
3867 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3868 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3869 Result:=TResEvalInt.CreateValue(Int);
3870 except
3871 RaiseOverflowArithmetic(20170530211028,Expr);
3872 end;
3873 revkFloat:
3874 // int^^float
3875 try
3876 {$Q+}{$R+}
3877 Flo:=Math.power(TResEvalInt(LeftValue).Int,TResEvalFloat(RightValue).FloatValue);
3878 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3879 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3880 Result:=TResEvalFloat.CreateValue(Flo);
3881 except
3882 RaiseOverflowArithmetic(20170816154223,Expr);
3883 end;
3884 revkCurrency:
3885 // int^^currency
3886 try
3887 {$Q+}{$R+}
3888 Flo:=Math.power(TResEvalInt(LeftValue).Int,TResEvalCurrency(RightValue).Value);
3889 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3890 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3891 Result:=TResEvalFloat.CreateValue(Flo);
3892 except
3893 RaiseOverflowArithmetic(20180421165906,Expr);
3894 end;
3895 else
3896 {$IFDEF VerbosePasResolver}
3897 writeln('TResExprEvaluator.EvalBinaryPowerExpr int ^^ ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3898 {$ENDIF}
3899 RaiseNotYetImplemented(20170530205640,Expr);
3900 end;
3901 revkUInt:
3902 case RightValue.Kind of
3903 revkInt:
3904 // uint^^int
3905 try
3906 {$Q+}{$R+}
3907 Int:=trunc(Math.power(TResEvalUInt(LeftValue).UInt,TResEvalInt(RightValue).Int));
3908 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3909 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3910 Result:=TResEvalInt.CreateValue(Int);
3911 except
3912 RaiseOverflowArithmetic(20170530211102,Expr);
3913 end;
3914 revkUInt:
3915 // uint^^uint
3916 try
3917 {$Q+}{$R+}
3918 Int:=trunc(Math.power(TResEvalUInt(LeftValue).UInt,TResEvalUInt(RightValue).UInt));
3919 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3920 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3921 Result:=TResEvalInt.CreateValue(Int);
3922 except
3923 RaiseOverflowArithmetic(20170530211121,Expr);
3924 end;
3925 revkFloat:
3926 // uint^^float
3927 try
3928 {$Q+}{$R+}
3929 Flo:=Math.power(TResEvalUInt(LeftValue).UInt,TResEvalFloat(RightValue).FloatValue);
3930 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3931 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3932 Result:=TResEvalFloat.CreateValue(Flo);
3933 except
3934 RaiseOverflowArithmetic(20170816154241,Expr);
3935 end;
3936 revkCurrency:
3937 // uint^^currency
3938 try
3939 {$Q+}{$R+}
3940 Flo:=Math.power(TResEvalUInt(LeftValue).UInt,TResEvalCurrency(RightValue).Value);
3941 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3942 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3943 Result:=TResEvalFloat.CreateValue(Flo);
3944 except
3945 RaiseOverflowArithmetic(20180421165948,Expr);
3946 end;
3947 else
3948 {$IFDEF VerbosePasResolver}
3949 writeln('TResExprEvaluator.EvalBinaryPowerExpr uint ^^ ? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
3950 {$ENDIF}
3951 RaiseNotYetImplemented(20170530211140,Expr);
3952 end;
3953 revkFloat:
3954 case RightValue.Kind of
3955 revkInt:
3956 // float ^^ int
3957 try
3958 {$Q+}{$R+}
3959 Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalInt(RightValue).Int);
3960 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3961 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3962 Result:=TResEvalFloat.CreateValue(Flo);
3963 except
3964 RaiseOverflowArithmetic(20170816153950,Expr);
3965 end;
3966 revkUInt:
3967 // float ^^ uint
3968 try
3969 {$Q+}{$R+}
3970 Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalUInt(RightValue).UInt);
3971 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3972 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3973 Result:=TResEvalFloat.CreateValue(Flo);
3974 except
3975 RaiseOverflowArithmetic(20170816154012,Expr);
3976 end;
3977 revkFloat:
3978 // float ^^ float
3979 try
3980 {$Q+}{$R+}
3981 Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalFloat(RightValue).FloatValue);
3982 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3983 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3984 Result:=TResEvalFloat.CreateValue(Flo);
3985 except
3986 RaiseOverflowArithmetic(20170816154012,Expr);
3987 end;
3988 revkCurrency:
3989 // float ^^ currency
3990 try
3991 {$Q+}{$R+}
3992 Flo:=Math.power(TResEvalFloat(LeftValue).FloatValue,TResEvalCurrency(RightValue).Value);
3993 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
3994 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
3995 Result:=TResEvalFloat.CreateValue(Flo);
3996 except
3997 RaiseOverflowArithmetic(20180421170016,Expr);
3998 end;
3999 end;
4000 revkCurrency:
4001 case RightValue.Kind of
4002 revkInt:
4003 // currency ^^ int
4004 try
4005 {$Q+}{$R+}
4006 aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalInt(RightValue).Int);
4007 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
4008 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
4009 Result:=TResEvalCurrency.CreateValue(aCurrency);
4010 except
4011 RaiseOverflowArithmetic(20180421170235,Expr);
4012 end;
4013 revkUInt:
4014 // currency ^^ uint
4015 try
4016 {$Q+}{$R+}
4017 aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalUInt(RightValue).UInt);
4018 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
4019 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
4020 Result:=TResEvalCurrency.CreateValue(aCurrency);
4021 except
4022 RaiseOverflowArithmetic(20180421170240,Expr);
4023 end;
4024 revkFloat:
4025 // currency ^^ float
4026 try
4027 {$Q+}{$R+}
4028 aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalFloat(RightValue).FloatValue);
4029 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
4030 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
4031 Result:=TResEvalCurrency.CreateValue(aCurrency);
4032 except
4033 RaiseOverflowArithmetic(20180421170254,Expr);
4034 end;
4035 revkCurrency:
4036 // currency ^^ currency
4037 try
4038 {$Q+}{$R+}
4039 aCurrency:=Math.power(TResEvalCurrency(LeftValue).Value,TResEvalCurrency(RightValue).Value);
4040 {$IFNDEF OverflowCheckOn}{$Q-}{$ENDIF}
4041 {$IFNDEF RangeCheckOn}{$R-}{$ENDIF}
4042 Result:=TResEvalCurrency.CreateValue(aCurrency);
4043 except
4044 RaiseOverflowArithmetic(20180421170311,Expr);
4045 end;
4046 end;
4047 else
4048 {$IFDEF VerbosePasResolver}
4049 writeln('TResExprEvaluator.EvalBinaryPowerExpr ^^ ?- Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
4050 {$ENDIF}
4051 RaiseNotYetImplemented(20170816153813,Expr);
4052 end;
4053 end;
4054
StringToOrdnull4055 function TResExprEvaluator.StringToOrd(Value: TResEvalValue;
4056 PosEl: TPasElement): longword;
4057 const
4058 Invalid = $12345678; // bigger than $ffff and smaller than $8000000
4059 var
4060 {$ifdef FPC_HAS_CPSTRING}
4061 S: RawByteString;
4062 {$endif}
4063 U: UnicodeString;
4064 begin
4065 case Value.Kind of
4066 {$ifdef FPC_HAS_CPSTRING}
4067 revkString:
4068 begin
4069 // ord(ansichar)
4070 S:=TResEvalString(Value).S;
4071 if length(S)=1 then
4072 Result:=ord(S[1])
4073 else if (length(S)=0) or (length(S)>4) then
4074 begin
4075 if PosEl<>nil then
4076 RaiseMsg(20170522221143,nXExpectedButYFound,sXExpectedButYFound,
4077 ['char','string'],PosEl)
4078 else
4079 exit(Invalid);
4080 end
4081 else
4082 begin
4083 U:=GetUnicodeStr(S,nil);
4084 if length(U)<>1 then
4085 begin
4086 if PosEl<>nil then
4087 RaiseMsg(20190124180407,nXExpectedButYFound,sXExpectedButYFound,
4088 ['char','string'],PosEl)
4089 else
4090 exit(Invalid);
4091 end;
4092 Result:=ord(U[1]);
4093 end;
4094 end;
4095 {$endif}
4096 revkUnicodeString:
4097 begin
4098 // ord(widechar)
4099 U:=TResEvalUTF16(Value).S;
4100 if length(U)<>1 then
4101 begin
4102 if PosEl<>nil then
4103 RaiseMsg(20170522221358,nXExpectedButYFound,sXExpectedButYFound,
4104 ['char','string'],PosEl)
4105 else
4106 exit(Invalid);
4107 end
4108 else
4109 Result:=ord(U[1]);
4110 end;
4111 else
4112 RaiseNotYetImplemented(20170522220959,PosEl);
4113 end;
4114 end;
4115
EvalPrimitiveExprStringnull4116 function TResExprEvaluator.EvalPrimitiveExprString(Expr: TPrimitiveExpr
4117 ): TResEvalValue;
4118 { Extracts the value from a Pascal string literal
4119
4120 S is a Pascal string literal e.g. 'Line'#10
4121 '' empty string
4122 '''' => "'"
4123 #decimal
4124 #$hex
4125 ^l l is a letter a-z
4126 }
4127
4128 procedure RangeError(id: TMaxPrecInt);
4129 begin
4130 Result.Free;
4131 RaiseRangeCheck(id,Expr);
4132 end;
4133
4134 procedure Add(h: String);
4135 begin
4136 {$ifdef FPC_HAS_CPSTRING}
4137 if Result.Kind=revkString then
4138 TResEvalString(Result).S:=TResEvalString(Result).S+h
4139 else
4140 TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+GetUnicodeStr(h,Expr);
4141 {$else}
4142 TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+h;
4143 {$endif}
4144 end;
4145
4146 procedure AddHash(u: longword; ForceUTF16: boolean);
4147 {$ifdef FPC_HAS_CPSTRING}
4148 var
4149 h: RawByteString;
4150 begin
4151 if ((u>255) or (ForceUTF16)) and (Result.Kind=revkString) then
4152 begin
4153 // switch to unicodestring
4154 h:=TResEvalString(Result).S;
4155 Result.Free;
4156 Result:=nil; // in case of exception in GetUnicodeStr
4157 Result:=TResEvalUTF16.CreateValue(GetUnicodeStr(h,Expr));
4158 end;
4159 if Result.Kind=revkString then
4160 TResEvalString(Result).S:=TResEvalString(Result).S+Chr(u)
4161 else
4162 TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+WideChar(u);
4163 end;
4164 {$else}
4165 begin
4166 TResEvalUTF16(Result).S:=TResEvalUTF16(Result).S+WideChar(u);
4167 if ForceUTF16 then ;
4168 end;
4169 {$endif}
4170
4171 var
4172 p, StartP, l: integer;
4173 c: Char;
4174 u: longword;
4175 S: String;
4176 begin
4177 Result:=nil;
4178 S:=Expr.Value;
4179 {$IFDEF VerbosePasResEval}
4180 //writeln('TResExprEvaluator.EvalPrimitiveExprString (',S,')');
4181 {$ENDIF}
4182 l:=length(S);
4183 if l=0 then
4184 RaiseInternalError(20170523113809);
4185 {$ifdef FPC_HAS_CPSTRING}
4186 Result:=TResEvalString.Create;
4187 {$else}
4188 Result:=TResEvalUTF16.Create;
4189 {$endif}
4190 p:=1;
4191 while p<=l do
4192 case S[p] of
4193 {$ifdef UsePChar}
4194 #0: break;
4195 {$endif}
4196 '''':
4197 begin
4198 inc(p);
4199 StartP:=p;
4200 repeat
4201 if p>l then
4202 RaiseInternalError(20170523113938);
4203 c:=S[p];
4204 case c of
4205 '''':
4206 begin
4207 if p>StartP then
4208 Add(copy(S,StartP,p-StartP));
4209 inc(p);
4210 StartP:=p;
4211 if (p>l) or (S[p]<>'''') then
4212 break;
4213 Add('''');
4214 inc(p);
4215 StartP:=p;
4216 end;
4217 else
4218 inc(p);
4219 end;
4220 until false;
4221 if p>StartP then
4222 Add(copy(S,StartP,p-StartP));
4223 end;
4224 '#':
4225 begin
4226 inc(p);
4227 if p>l then
4228 RaiseInternalError(20181016121354);
4229 if S[p]='$' then
4230 begin
4231 // #$hexnumber
4232 inc(p);
4233 StartP:=p;
4234 u:=0;
4235 while p<=l do
4236 begin
4237 c:=S[p];
4238 case c of
4239 '0'..'9': u:=u*16+longword(ord(c)-ord('0'));
4240 'a'..'f': u:=u*16+longword(ord(c)-ord('a'))+10;
4241 'A'..'F': u:=u*16+longword(ord(c)-ord('A'))+10;
4242 else break;
4243 end;
4244 if u>$10FFFF then
4245 RangeError(20170523115712);
4246 inc(p);
4247 end;
4248 if p=StartP then
4249 RaiseInternalError(20170207164956);
4250 if u>$ffff then
4251 begin
4252 // split into two
4253 dec(u,$10000);
4254 AddHash($D800+(u shr 10),true);
4255 AddHash($DC00+(u and $3ff),true);
4256 end
4257 else
4258 AddHash(u,p-StartP>2);
4259 end
4260 else
4261 begin
4262 // #decimalnumber
4263 StartP:=p;
4264 u:=0;
4265 while p<=l do
4266 begin
4267 c:=S[p];
4268 case c of
4269 '0'..'9': u:=u*10+longword(ord(c)-ord('0'));
4270 else break;
4271 end;
4272 if u>$ffff then
4273 RangeError(20170523123137);
4274 inc(p);
4275 end;
4276 if p=StartP then
4277 RaiseInternalError(20170523123806);
4278 AddHash(u,false);
4279 end;
4280 end;
4281 '^':
4282 begin
4283 // ^A is #1
4284 inc(p);
4285 if p>l then
4286 RaiseInternalError(20181016121520);
4287 c:=S[p];
4288 case c of
4289 'a'..'z': AddHash(ord(c)-ord('a')+1,false);
4290 'A'..'Z': AddHash(ord(c)-ord('A')+1,false);
4291 else RaiseInternalError(20170523123809);
4292 end;
4293 inc(p);
4294 end;
4295 else
4296 RaiseNotYetImplemented(20170523123815,Expr,'ord='+IntToStr(ord(S[p])));
4297 end;
4298 {$IFDEF VerbosePasResEval}
4299 //writeln('TResExprEvaluator.EvalPrimitiveExprString Result=',Result.AsString);
4300 {$ENDIF}
4301 end;
4302
TResExprEvaluator.CreateResEvalIntnull4303 function TResExprEvaluator.CreateResEvalInt(UInt: TMaxPrecUInt): TResEvalValue;
4304 begin
4305 if UInt<=HighIntAsUInt then
4306 Result:=TResEvalInt.CreateValue(TMaxPrecInt(UInt))
4307 else
4308 Result:=TResEvalUInt.CreateValue(UInt);
4309 end;
4310
4311 constructor TResExprEvaluator.Create;
4312 begin
4313 inherited Create;
4314 FAllowedInts:=ReitDefaults;
4315 {$ifdef FPC_HAS_CPSTRING}
4316 FDefaultEncoding:=CP_ACP;
4317 {$endif}
4318 end;
4319
TResExprEvaluator.Evalnull4320 function TResExprEvaluator.Eval(Expr: TPasExpr; Flags: TResEvalFlags
4321 ): TResEvalValue;
4322 var
4323 C: TClass;
4324 Code: integer;
4325 Int: TMaxPrecInt;
4326 UInt: TMaxPrecUInt;
4327 Flo: TMaxPrecFloat;
4328 begin
4329 Result:=nil;
4330 if Expr.CustomData is TResEvalValue then
4331 begin
4332 Result:=TResEvalValue(Expr.CustomData);
4333 exit;
4334 end;
4335 {$IFDEF VerbosePasResEval}
4336 writeln('TResExprEvaluator.Eval Expr=',GetObjName(Expr),' Flags=',dbgs(Flags));
4337 {$ENDIF}
4338 if refAutoConst in Flags then
4339 begin
4340 Exclude(Flags,refAutoConst);
4341 if IsConst(Expr) then
4342 Include(Flags,refConst);
4343 end;
4344 if refAutoConstExt in Flags then
4345 begin
4346 Exclude(Flags,refAutoConstExt);
4347 if IsConst(Expr) then
4348 Include(Flags,refConstExt);
4349 end;
4350
4351 C:=Expr.ClassType;
4352 if C=TPrimitiveExpr then
4353 begin
4354 case TPrimitiveExpr(Expr).Kind of
4355 pekIdent:
4356 begin
4357 Result:=OnEvalIdentifier(Self,TPrimitiveExpr(Expr),Flags);
4358 //writeln('TResExprEvaluator.Eval primitiv result=',Result<>nil,' ',dbgs(Result));
4359 end;
4360 pekNumber:
4361 begin
4362 // try TMaxPrecInt
4363 val(TPrimitiveExpr(Expr).Value,Int,Code);
4364 if Code=0 then
4365 begin
4366 {$IFDEF VerbosePasResEval}
4367 writeln('TResExprEvaluator.Eval Int=',Int,' Value="',TPrimitiveExpr(Expr).Value,'"');
4368 {$ENDIF}
4369 if (Int<0) and (Pos('-',TPrimitiveExpr(Expr).Value)<1) then
4370 // FPC str() converts $8000000000000000 to a negative int64 -> ignore
4371 else
4372 begin
4373 Result:=TResEvalInt.CreateValue(Int);
4374 exit;
4375 end;
4376 end;
4377 // try TMaxPrecUInt
4378 val(TPrimitiveExpr(Expr).Value,UInt,Code);
4379 if Code=0 then
4380 begin
4381 Result:=TResEvalUInt.CreateValue(UInt);
4382 {$IFDEF VerbosePasResEval}
4383 writeln('TResExprEvaluator.Eval UInt=',UInt,' Value="',TPrimitiveExpr(Expr).Value,'"');
4384 {$ENDIF}
4385 exit;
4386 end;
4387 // try TMaxPrecFloat
4388 val(TPrimitiveExpr(Expr).Value,Flo,Code);
4389 if Code=0 then
4390 begin
4391 Result:=TResEvalFloat.CreateValue(Flo);
4392 {$IFDEF VerbosePasResEval}
4393 writeln('TResExprEvaluator.Eval Float=',Flo,' Value="',TPrimitiveExpr(Expr).Value,'"');
4394 {$ENDIF}
4395 exit;
4396 end;
4397 {$IFDEF VerbosePasResEval}
4398 writeln('TResExprEvaluator.Eval Value="',TPrimitiveExpr(Expr).Value,'"');
4399 {$ENDIF}
4400 RaiseRangeCheck(20170518202252,Expr);
4401 end;
4402 pekString:
4403 begin
4404 Result:=EvalPrimitiveExprString(TPrimitiveExpr(Expr));
4405 exit;
4406 end;
4407 else
4408 RaiseNotYetImplemented(20170518200951,Expr);
4409 end;
4410 {$IFDEF VerbosePasResEval}
4411 writeln('TResExprEvaluator.Eval primitiv end result=',Result<>nil,' ',dbgs(Result));
4412 {$ENDIF}
4413 end
4414 else if C=TNilExpr then
4415 Result:=TResEvalValue.CreateKind(revkNil)
4416 else if C=TBoolConstExpr then
4417 Result:=TResEvalBool.CreateValue(TBoolConstExpr(Expr).Value)
4418 else if C=TUnaryExpr then
4419 Result:=EvalUnaryExpr(TUnaryExpr(Expr),Flags)
4420 else if C=TBinaryExpr then
4421 Result:=EvalBinaryExpr(TBinaryExpr(Expr),Flags)
4422 else if C=TParamsExpr then
4423 Result:=EvalParamsExpr(TParamsExpr(Expr),Flags)
4424 else if C=TArrayValues then
4425 Result:=EvalArrayValuesExpr(TArrayValues(Expr),Flags)
4426 else if [refConst,refConstExt]*Flags<>[] then
4427 RaiseConstantExprExp(20170518213800,Expr);
4428 {$IFDEF VerbosePasResEval}
4429 writeln('TResExprEvaluator.Eval END ',Expr.ClassName,' result=',Result<>nil,' ',dbgs(Result));
4430 {$ENDIF}
4431 end;
4432
TResExprEvaluator.IsInRangenull4433 function TResExprEvaluator.IsInRange(Expr, RangeExpr: TPasExpr;
4434 EmitHints: boolean): boolean;
4435 var
4436 Value, RangeValue: TResEvalValue;
4437 begin
4438 Value:=Eval(Expr,[refAutoConst]);
4439 if Value=nil then
4440 exit(true); // a variable -> ok
4441 RangeValue:=nil;
4442 try
4443 RangeValue:=Eval(RangeExpr,[]);
4444 if RangeValue=nil then
4445 RaiseNotYetImplemented(20170522171226,RangeExpr);
4446 Result:=IsInRange(Value,Expr,RangeValue,RangeExpr,EmitHints);
4447 finally
4448 ReleaseEvalValue(Value);
4449 ReleaseEvalValue(RangeValue);
4450 end;
4451 end;
4452
TResExprEvaluator.IsInRangenull4453 function TResExprEvaluator.IsInRange(Value: TResEvalValue; ValueExpr: TPasExpr;
4454 RangeValue: TResEvalValue; RangeExpr: TPasExpr; EmitHints: boolean): boolean;
4455 var
4456 RgInt: TResEvalRangeInt;
4457 RgUInt: TResEvalRangeUInt;
4458 CharIndex: LongWord;
4459 begin
4460 Result:=false;
4461 {$IFDEF VerbosePasResEval}
4462 //writeln('TResExprEvaluator.IsInRange Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
4463 {$ENDIF}
4464 case RangeValue.Kind of
4465 revkRangeInt:
4466 begin
4467 RgInt:=TResEvalRangeInt(RangeValue);
4468 case RgInt.ElKind of
4469 revskBool:
4470 if Value.Kind=revkBool then
4471 exit(true)
4472 else
4473 RaiseNotYetImplemented(20170522220104,ValueExpr);
4474 revskEnum:
4475 begin
4476 if Value.Kind<>revkEnum then
4477 RaiseInternalError(20170522172754)
4478 else if TResEvalEnum(Value).ElType<>RgInt.ElType then
4479 RaiseInternalError(20170522174028)
4480 else if (TResEvalEnum(Value).Index<RgInt.RangeStart)
4481 or (TResEvalEnum(Value).Index>RgInt.RangeEnd) then
4482 begin
4483 if EmitHints then
4484 EmitRangeCheckConst(20170522174406,Value.AsString,
4485 RgInt.ElementAsString(RgInt.RangeStart),
4486 RgInt.ElementAsString(RgInt.RangeEnd),
4487 ValueExpr);
4488 exit(false);
4489 end
4490 else
4491 exit(true);
4492 end;
4493 revskInt: // int..int
4494 if Value.Kind=revkInt then
4495 begin
4496 // int in int..int
4497 if (TResEvalInt(Value).Int<RgInt.RangeStart)
4498 or (TResEvalInt(Value).Int>RgInt.RangeEnd) then
4499 begin
4500 if EmitHints then
4501 EmitRangeCheckConst(20170522174958,Value.AsString,
4502 RgInt.ElementAsString(RgInt.RangeStart),
4503 RgInt.ElementAsString(RgInt.RangeEnd),
4504 ValueExpr);
4505 exit(false);
4506 end
4507 else
4508 exit(true);
4509 end
4510 else if Value.Kind=revkUInt then
4511 begin
4512 // uint in int..int
4513 if (TResEvalUInt(Value).UInt>HighIntAsUInt)
4514 or (TMaxPrecInt(TResEvalUInt(Value).UInt)<RgInt.RangeStart)
4515 or (TMaxPrecInt(TResEvalUInt(Value).UInt)>RgInt.RangeEnd) then
4516 begin
4517 if EmitHints then
4518 EmitRangeCheckConst(20170522215852,Value.AsString,
4519 RgInt.ElementAsString(RgInt.RangeStart),
4520 RgInt.ElementAsString(RgInt.RangeEnd),
4521 ValueExpr);
4522 exit(false);
4523 end
4524 else
4525 exit(true);
4526 end
4527 else
4528 begin
4529 {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
4530 writeln('TResExprEvaluator.IsInRange Kind=',Value.Kind,' ',Value.AsDebugString);
4531 {$ENDIF}
4532 RaiseNotYetImplemented(20170522215906,ValueExpr);
4533 end;
4534 revskChar:
4535 if Value.Kind in revkAllStrings then
4536 begin
4537 // string in char..char
4538 CharIndex:=StringToOrd(Value,ValueExpr);
4539 if (CharIndex<RgInt.RangeStart) or (CharIndex>RgInt.RangeEnd) then
4540 begin
4541 if EmitHints then
4542 EmitRangeCheckConst(20170522221709,Value.AsString,
4543 RgInt.ElementAsString(RgInt.RangeStart),
4544 RgInt.ElementAsString(RgInt.RangeEnd),
4545 ValueExpr);
4546 exit(false);
4547 end
4548 else
4549 exit(true);
4550 end
4551 else
4552 RaiseNotYetImplemented(20170522220210,ValueExpr);
4553 else
4554 RaiseInternalError(20170522172630);
4555 end;
4556 end;
4557 revkRangeUInt:
4558 if Value.Kind=revkInt then
4559 begin
4560 // int in uint..uint
4561 RgUInt:=TResEvalRangeUInt(RangeValue);
4562 if (TResEvalInt(Value).Int<0)
4563 or (TMaxPrecUInt(TResEvalInt(Value).Int)<RgUInt.RangeStart)
4564 or (TMaxPrecUInt(TResEvalInt(Value).Int)>RgUInt.RangeEnd) then
4565 begin
4566 if EmitHints then
4567 EmitRangeCheckConst(20170522172250,Value.AsString,
4568 IntToStr(RgUInt.RangeStart),
4569 IntToStr(RgUInt.RangeEnd),ValueExpr);
4570 exit(false);
4571 end
4572 else
4573 exit(true);
4574 end
4575 else if Value.Kind=revkUInt then
4576 begin
4577 // uint in uint..uint
4578 RgUInt:=TResEvalRangeUInt(RangeValue);
4579 if (TResEvalUInt(Value).UInt<RgUInt.RangeStart)
4580 or (TResEvalUInt(Value).UInt>RgUInt.RangeEnd) then
4581 begin
4582 if EmitHints then
4583 EmitRangeCheckConst(20170522172544,IntToStr(TResEvalUInt(Value).UInt),
4584 IntToStr(RgUInt.RangeStart),
4585 IntToStr(RgUInt.RangeEnd),ValueExpr);
4586 exit(false);
4587 end
4588 else
4589 exit(true);
4590 end
4591 else
4592 begin
4593 {$IFDEF VerbosePasResEval}
4594 writeln('TResExprEvaluator.IsInRange Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
4595 {$ENDIF}
4596 RaiseNotYetImplemented(20170522171551,ValueExpr);
4597 end;
4598 else
4599 {$IFDEF VerbosePasResEval}
4600 writeln('TResExprEvaluator.IsInRange Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
4601 {$ENDIF}
4602 RaiseNotYetImplemented(20170522171307,RangeExpr);
4603 end;
4604 end;
4605
IsSetCompatiblenull4606 function TResExprEvaluator.IsSetCompatible(Value: TResEvalValue;
4607 ValueExpr: TPasExpr; RangeValue: TResEvalValue; EmitHints: boolean): boolean;
4608 // checks if Value fits into a set of RangeValue
4609 var
4610 RightSet: TResEvalSet;
4611 LeftRange: TResEvalRangeInt;
4612 MinVal, MaxVal: TMaxPrecInt;
4613 begin
4614 Result:=true;
4615 case Value.Kind of
4616 revkSetOfInt:
4617 begin
4618 RightSet:=TResEvalSet(Value);
4619 if RightSet.ElKind=revskNone then
4620 exit(true); // empty set always fits
4621 case RangeValue.Kind of
4622 revkRangeInt:
4623 begin
4624 LeftRange:=TResEvalRangeInt(RangeValue);
4625 if (LeftRange.ElKind<>RightSet.ElKind)
4626 or (LeftRange.ElType<>RightSet.ElType) then
4627 begin
4628 {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
4629 writeln('TResExprEvaluator.IsSetCompatible Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
4630 {$ENDIF}
4631 RaiseNotYetImplemented(20170714201425,ValueExpr);
4632 end;
4633 if length(RightSet.Ranges)=0 then
4634 exit(true); // empty typed set fits
4635 MinVal:=RightSet.Ranges[0].RangeStart;
4636 MaxVal:=RightSet.Ranges[length(RightSet.Ranges)-1].RangeEnd;
4637 {$IFDEF VerbosePasResEval}
4638 writeln('TResExprEvaluator.IsSetCompatible Value=',dbgs(Value),' MinVal=',MinVal,' MaxVal=',MaxVal,' RangeValue=',dbgs(RangeValue));
4639 {$ENDIF}
4640 if (MinVal<LeftRange.RangeStart) then
4641 if EmitHints then
4642 EmitRangeCheckConst(20170714202813,RightSet.ElementAsString(MinVal),
4643 LeftRange.ElementAsString(LeftRange.RangeStart),
4644 LeftRange.ElementAsString(LeftRange.RangeEnd),ValueExpr,mtError)
4645 else
4646 exit(false);
4647 if (MaxVal>LeftRange.RangeEnd) then
4648 if EmitHints then
4649 EmitRangeCheckConst(20170714203134,RightSet.ElementAsString(MaxVal),
4650 LeftRange.ElementAsString(LeftRange.RangeStart),
4651 LeftRange.ElementAsString(LeftRange.RangeEnd),ValueExpr,mtError)
4652 else
4653 exit(false);
4654 end;
4655 else
4656 {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
4657 writeln('TResExprEvaluator.IsSetCompatible Value=',dbgs(Value),' RangeValue=',dbgs(RangeValue));
4658 {$ENDIF}
4659 RaiseNotYetImplemented(20170714201121,ValueExpr);
4660 end;
4661 end
4662 else
4663 {$IF defined(VerbosePasResEval) or defined(VerbosePasResolver)}
4664 writeln('TResExprEvaluator.IsSetCompatible Value=',Value.Kind,' ',dbgs(RangeValue));
4665 {$ENDIF}
4666 RaiseNotYetImplemented(20170714195815,ValueExpr);
4667 end;
4668 end;
4669
IsConstnull4670 function TResExprEvaluator.IsConst(Expr: TPasExpr): boolean;
4671 var
4672 El: TPasElement;
4673 C: TClass;
4674 begin
4675 El:=Expr;
4676 while El<>nil do
4677 begin
4678 C:=El.ClassType;
4679 if C.InheritsFrom(TPasProcedure) then exit(true);
4680 if C.InheritsFrom(TPasImplBlock) then exit(false);
4681 El:=El.Parent;
4682 end;
4683 Result:=true;
4684 end;
4685
IsSimpleExprnull4686 function TResExprEvaluator.IsSimpleExpr(Expr: TPasExpr): boolean;
4687 var
4688 C: TClass;
4689 begin
4690 C:=Expr.ClassType;
4691 Result:=(C=TNilExpr)
4692 or (C=TBoolConstExpr)
4693 or (C=TPrimitiveExpr);
4694 end;
4695
4696 procedure TResExprEvaluator.EmitRangeCheckConst(id: TMaxPrecInt; const aValue,
4697 MinVal, MaxVal: String; PosEl: TPasElement; MsgType: TMessageType);
4698 begin
4699 if Assigned(OnRangeCheckEl) then
4700 OnRangeCheckEl(Self,PosEl,MsgType);
4701 LogMsg(id,MsgType,nRangeCheckEvaluatingConstantsVMinMax,
4702 sRangeCheckEvaluatingConstantsVMinMax,[aValue,MinVal,MaxVal],PosEl);
4703 end;
4704
4705 procedure TResExprEvaluator.EmitRangeCheckConst(id: TMaxPrecInt;
4706 const aValue: String; MinVal, MaxVal: TMaxPrecInt; PosEl: TPasElement;
4707 MsgType: TMessageType);
4708 begin
4709 EmitRangeCheckConst(id,aValue,IntToStr(MinVal),IntToStr(MaxVal),PosEl,MsgType);
4710 end;
4711
TResExprEvaluator.ChrValuenull4712 function TResExprEvaluator.ChrValue(Value: TResEvalValue; ErrorEl: TPasElement
4713 ): TResEvalValue;
4714 var
4715 Int: TMaxPrecInt;
4716 begin
4717 Result:=nil;
4718 case Value.Kind of
4719 revkInt,revkUInt:
4720 begin
4721 if Value.Kind=revkUInt then
4722 begin
4723 if TResEvalUInt(Value).UInt>$ffff then
4724 EmitRangeCheckConst(20170711195605,Value.AsString,0,$ffff,ErrorEl,mtError)
4725 else
4726 Int:=TResEvalUInt(Value).UInt;
4727 end
4728 else
4729 Int:=TResEvalInt(Value).Int;
4730 if (Int<0) or (Int>$ffff) then
4731 EmitRangeCheckConst(20170711195747,Value.AsString,0,$ffff,ErrorEl,mtError);
4732 {$ifdef FPC_HAS_CPSTRING}
4733 if Int<=$ff then
4734 Result:=TResEvalString.CreateValue(chr(Int))
4735 else
4736 {$endif}
4737 Result:=TResEvalUTF16.CreateValue(WideChar(Int))
4738 end;
4739 else
4740 {$IFDEF VerbosePasResEval}
4741 writeln('TResExprEvaluator.ChrValue ',Value.AsDebugString);
4742 {$ENDIF}
4743 RaiseNotYetImplemented(20170711195440,ErrorEl);
4744 end;
4745 end;
4746
OrdValuenull4747 function TResExprEvaluator.OrdValue(Value: TResEvalValue; ErrorEl: TPasElement
4748 ): TResEvalValue;
4749 var
4750 v: longword;
4751 begin
4752 Result:=nil;
4753 v:=0;
4754 case Value.Kind of
4755 revkBool:
4756 if TResEvalBool(Value).B then
4757 v:=1
4758 else
4759 v:=0;
4760 revkInt,revkUInt:
4761 exit(Value);
4762 {$ifdef FPC_HAS_CPSTRING}
4763 revkString,
4764 {$endif}
4765 revkUnicodeString:
4766 v:=StringToOrd(Value,ErrorEl);
4767 revkEnum:
4768 v:=TResEvalEnum(Value).Index;
4769 else
4770 {$IFDEF VerbosePasResEval}
4771 writeln('TResExprEvaluator.OrdValue ',Value.AsDebugString);
4772 {$ENDIF}
4773 RaiseNotYetImplemented(20170624155932,ErrorEl);
4774 end;
4775 if v>$ffff then exit;
4776 Result:=TResEvalInt.CreateValue(v);
4777 end;
4778
4779 procedure TResExprEvaluator.PredValue(Value: TResEvalValue; ErrorEl: TPasElement
4780 );
4781 begin
4782 case Value.Kind of
4783 revkBool:
4784 PredBool(TResEvalBool(Value),ErrorEl);
4785 revkInt:
4786 PredInt(TResEvalInt(Value),ErrorEl);
4787 revkUInt:
4788 PredUInt(TResEvalUInt(Value),ErrorEl);
4789 {$ifdef FPC_HAS_CPSTRING}
4790 revkString:
4791 PredString(TResEvalString(Value),ErrorEl);
4792 {$endif}
4793 revkUnicodeString:
4794 PredUnicodeString(TResEvalUTF16(Value),ErrorEl);
4795 revkEnum:
4796 PredEnum(TResEvalEnum(Value),ErrorEl);
4797 else
4798 {$IFDEF VerbosePasResEval}
4799 writeln('TResExprEvaluator.PredValue ',Value.AsDebugString);
4800 {$ENDIF}
4801 ReleaseEvalValue(Value);
4802 RaiseNotYetImplemented(20170624135738,ErrorEl);
4803 end;
4804 end;
4805
4806 procedure TResExprEvaluator.SuccValue(Value: TResEvalValue; ErrorEl: TPasElement
4807 );
4808 begin
4809 case Value.Kind of
4810 revkBool:
4811 SuccBool(TResEvalBool(Value),ErrorEl);
4812 revkInt:
4813 SuccInt(TResEvalInt(Value),ErrorEl);
4814 revkUInt:
4815 SuccUInt(TResEvalUInt(Value),ErrorEl);
4816 {$ifdef FPC_HAS_CPSTRING}
4817 revkString:
4818 SuccString(TResEvalString(Value),ErrorEl);
4819 {$endif}
4820 revkUnicodeString:
4821 SuccUnicodeString(TResEvalUTF16(Value),ErrorEl);
4822 revkEnum:
4823 SuccEnum(TResEvalEnum(Value),ErrorEl);
4824 else
4825 {$IFDEF VerbosePasResEval}
4826 writeln('TResExprEvaluator.SuccValue ',Value.AsDebugString);
4827 {$ENDIF}
4828 ReleaseEvalValue(Value);
4829 RaiseNotYetImplemented(20170624151252,ErrorEl);
4830 end;
4831 end;
4832
EvalStrFuncnull4833 function TResExprEvaluator.EvalStrFunc(Params: TParamsExpr; Flags: TResEvalFlags
4834 ): TResEvalValue;
4835 var
4836 AllConst: Boolean;
4837
EvalFormatnull4838 function EvalFormat(Expr: TPasExpr; MinVal, MaxVal: TMaxPrecInt): TMaxPrecInt;
4839 var
4840 Value: TResEvalValue;
4841 begin
4842 Value:=Eval(Expr,Flags);
4843 if Value=nil then
4844 begin
4845 AllConst:=false;
4846 exit(-1);
4847 end;
4848 if Value.Kind<>revkInt then
4849 RaiseNotYetImplemented(20170717144010,Expr);
4850 Result:=TResEvalInt(Value).Int;
4851 if (Result<MinVal) or (Result>MaxVal) then
4852 EmitRangeCheckConst(20170717144609,IntToStr(Result),MinVal,MaxVal,Expr,mtError);
4853 end;
4854
4855 var
4856 i: Integer;
4857 Param: TPasExpr;
4858 S, ValStr: String;
4859 Value: TResEvalValue;
4860 Format1, Format2: TMaxPrecInt;
4861 begin
4862 Result:=nil;
4863 Value:=nil;
4864 AllConst:=true;
4865 S:='';
4866 for i:=0 to length(Params.Params)-1 do
4867 begin
4868 Param:=Params.Params[i];
4869 {$IFDEF VerbosePasResEval}
4870 writeln('TPasResolver.BI_StrFunc_OnEval i=',i,' of ',length(Params.Params),' Param=',GetObjName(Param));
4871 {$ENDIF}
4872 Value:=Eval(Param,Flags);
4873 if Value=nil then
4874 begin
4875 AllConst:=false;
4876 continue;
4877 end;
4878 Format1:=-1;
4879 Format2:=-1;
4880 try
4881 ValStr:='';
4882 if Param.format1<>nil then
4883 begin
4884 Format1:=EvalFormat(Param.format1,1,255);
4885 if Format1<0 then
4886 continue;
4887 if Param.format2<>nil then
4888 begin
4889 Format2:=EvalFormat(Param.format2,0,255);
4890 if Format2<0 then
4891 continue;
4892 end;
4893 end;
4894 case Value.Kind of
4895 revkBool:
4896 if Format1<0 then
4897 str(TResEvalBool(Value).B,ValStr)
4898 else
4899 str(TResEvalBool(Value).B:Format1,ValStr);
4900 revkInt:
4901 if Format1<0 then
4902 str(TResEvalInt(Value).Int,ValStr)
4903 else
4904 str(TResEvalInt(Value).Int:Format1,ValStr);
4905 revkUInt:
4906 if Format1<0 then
4907 str(TResEvalUInt(Value).UInt,ValStr)
4908 else
4909 str(TResEvalUInt(Value).UInt:Format1,ValStr);
4910 revkFloat:
4911 if Format1<0 then
4912 str(TResEvalFloat(Value).FloatValue,ValStr)
4913 else if Format2<0 then
4914 str(TResEvalFloat(Value).FloatValue:Format1,ValStr)
4915 else
4916 str(TResEvalFloat(Value).FloatValue:Format1:Format2,ValStr);
4917 revkCurrency:
4918 if Format1<0 then
4919 str(TResEvalCurrency(Value).Value,ValStr)
4920 else if Format2<0 then
4921 str(TResEvalCurrency(Value).Value:Format1,ValStr)
4922 else
4923 str(TResEvalCurrency(Value).Value:Format1:Format2,ValStr);
4924 revkEnum:
4925 begin
4926 ValStr:=TResEvalEnum(Value).AsString;
4927 if Format1>0 then
4928 ValStr:=StringOfChar(' ',Format1)+ValStr;
4929 end;
4930 else
4931 AllConst:=false;
4932 continue;
4933 end;
4934 finally
4935 ReleaseEvalValue(Value);
4936 ReleaseEvalValue(Value);
4937 ReleaseEvalValue(Value);
4938 end;
4939 S:=S+ValStr;
4940 end;
4941 if AllConst then
4942 {$ifdef FPC_HAS_CPSTRING}
4943 Result:=TResEvalString.CreateValue(S);
4944 {$else}
4945 Result:=TResEvalUTF16.CreateValue(S);
4946 {$endif}
4947 end;
4948
EvalStringAddExprnull4949 function TResExprEvaluator.EvalStringAddExpr(Expr, LeftExpr,
4950 RightExpr: TPasExpr; LeftValue, RightValue: TResEvalValue): TResEvalValue;
4951 {$ifdef FPC_HAS_CPSTRING}
4952 var
4953 LeftCP, RightCP: TSystemCodePage;
4954 {$endif}
4955 begin
4956 case LeftValue.Kind of
4957 {$ifdef FPC_HAS_CPSTRING}
4958 revkString:
4959 case RightValue.Kind of
4960 revkString:
4961 begin
4962 LeftCP:=GetCodePage(TResEvalString(LeftValue).S);
4963 RightCP:=GetCodePage(TResEvalString(RightValue).S);
4964 if (LeftCP=RightCP) then
4965 begin
4966 Result:=TResEvalString.Create;
4967 TResEvalString(Result).S:=TResEvalString(LeftValue).S+TResEvalString(RightValue).S;
4968 end
4969 else
4970 begin
4971 Result:=TResEvalUTF16.Create;
4972 TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,LeftExpr)
4973 +GetUnicodeStr(TResEvalString(RightValue).S,RightExpr);
4974 end;
4975 end;
4976 revkUnicodeString:
4977 begin
4978 Result:=TResEvalUTF16.Create;
4979 TResEvalUTF16(Result).S:=GetUnicodeStr(TResEvalString(LeftValue).S,LeftExpr)
4980 +TResEvalUTF16(RightValue).S;
4981 end;
4982 else
4983 {$IFDEF VerbosePasResolver}
4984 writeln('TResExprEvaluator.EvalBinaryAddExpr string+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
4985 {$ENDIF}
4986 RaiseNotYetImplemented(20170601141834,Expr);
4987 end;
4988 {$endif}
4989 revkUnicodeString:
4990 case RightValue.Kind of
4991 {$ifdef FPC_HAS_CPSTRING}
4992 revkString:
4993 begin
4994 Result:=TResEvalUTF16.Create;
4995 TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S
4996 +GetUnicodeStr(TResEvalString(RightValue).S,RightExpr);
4997 end;
4998 {$endif}
4999 revkUnicodeString:
5000 begin
5001 Result:=TResEvalUTF16.Create;
5002 TResEvalUTF16(Result).S:=TResEvalUTF16(LeftValue).S+TResEvalUTF16(RightValue).S;
5003 end;
5004 else
5005 {$IFDEF VerbosePasResolver}
5006 writeln('TResExprEvaluator.EvalBinaryAddExpr utf16+? Left=',LeftValue.AsDebugString,' Right=',RightValue.AsDebugString);
5007 {$ENDIF}
5008 RaiseNotYetImplemented(20170601141811,Expr);
5009 end;
5010 else
5011 {$ifndef FPC_HAS_CPSTRING}
5012 if LeftExpr=nil then ; // no Parameter "LeftExpr" not used
5013 if RightExpr=nil then ; // no Parameter "RightExpr" not used
5014 {$endif}
5015 RaiseNotYetImplemented(20181219233139,Expr);
5016 end;
5017 end;
5018
TResExprEvaluator.LoHiValuenull5019 function TResExprEvaluator.LoHiValue(Value: TResEvalValue; ShiftSize: Integer;
5020 Mask: LongWord; ErrorEl: TPasElement): TResEvalValue;
5021 var
5022 uint: LongWord;
5023 begin
5024 case Value.Kind of
5025 revkInt:
5026 {$IFDEF Pas2js}
5027 if ShiftSize=32 then
5028 uint := longword(TResEvalInt(Value).Int div $100000000)
5029 else
5030 {$ENDIF}
5031 uint := (TResEvalInt(Value).Int shr ShiftSize) and Mask;
5032 revkUInt:
5033 {$IFDEF Pas2js}
5034 if ShiftSize=32 then
5035 uint := longword(TResEvalUInt(Value).UInt div $100000000)
5036 else
5037 {$ENDIF}
5038 uint := (TResEvalUInt(Value).UInt shr ShiftSize) and Mask;
5039 else
5040 {$IFDEF VerbosePasResEval}
5041 writeln('TResExprEvaluator.LoHiValue ',Value.AsDebugString);
5042 {$ENDIF}
5043 RaiseNotYetImplemented(20190129012100,ErrorEl);
5044 end;
5045 Result := TResEvalInt.CreateValue(uint);
5046 end;
5047
TResExprEvaluator.EnumTypeCastnull5048 function TResExprEvaluator.EnumTypeCast(EnumType: TPasEnumType; Expr: TPasExpr;
5049 Flags: TResEvalFlags): TResEvalEnum;
5050 var
5051 Value: TResEvalValue;
5052 MaxIndex, Index: Integer;
5053 begin
5054 Result:=nil;
5055 Value:=Eval(Expr,Flags);
5056 if Value=nil then exit;
5057 try
5058 MaxIndex:=EnumType.Values.Count-1;
5059 case Value.Kind of
5060 revkInt:
5061 if TResEvalInt(Value).Int>High(Index) then
5062 EmitRangeCheckConst(20170713105944,
5063 IntToStr(TResEvalInt(Value).Int),'0',IntToStr(MaxIndex),Expr,mtError)
5064 else
5065 Index:=TResEvalInt(Value).Int;
5066 revkUInt:
5067 if TResEvalUInt(Value).UInt>MaxIndex then
5068 EmitRangeCheckConst(20170713105944,
5069 IntToStr(TResEvalUInt(Value).UInt),'0',IntToStr(MaxIndex),Expr,mtError)
5070 else
5071 Index:=TResEvalUInt(Value).UInt;
5072 else
5073 RaiseNotYetImplemented(20170713105625,Expr);
5074 end;
5075 if (Index<0) or (Index>MaxIndex) then
5076 EmitRangeCheckConst(20170713110232,
5077 IntToStr(Index),'0',IntToStr(MaxIndex),Expr,mtError);
5078 Result:=TResEvalEnum.CreateValue(Index,TPasEnumValue(EnumType.Values[Index]));
5079 finally
5080 ReleaseEvalValue(Value);
5081 end;
5082 end;
5083
5084 {$ifdef FPC_HAS_CPSTRING}
CheckValidUTF8null5085 function TResExprEvaluator.CheckValidUTF8(const s: RawByteString;
5086 ErrorEl: TPasElement): boolean;
5087 var
5088 p, EndP: PChar;
5089 l: SizeInt;
5090 begin
5091 p:=PChar(s);
5092 EndP:=p+length(s);
5093 while p<EndP do
5094 begin
5095 l:=Utf8CodePointLen(p,EndP-p,false);
5096 if l<=0 then
5097 if ErrorEl<>nil then
5098 RaiseMsg(20170711211841,nIllegalChar,sIllegalChar,[],ErrorEl)
5099 else
5100 exit(false);
5101 inc(p,l);
5102 end;
5103 Result:=true;
5104 end;
5105
GetCodePagenull5106 function TResExprEvaluator.GetCodePage(const s: RawByteString): TSystemCodePage;
5107 begin
5108 if s='' then exit(DefaultStringCodePage);
5109 Result:=StringCodePage(s);
5110 if (Result=CP_ACP) or (Result=CP_NONE) then
5111 begin
5112 Result:=DefaultStringCodePage;
5113 if (Result=CP_ACP) or (Result=CP_NONE) then
5114 begin
5115 Result:=System.DefaultSystemCodePage;
5116 if Result=CP_NONE then
5117 Result:=CP_ACP;
5118 end;
5119 end;
5120 end;
5121
GetRawByteStringnull5122 function TResExprEvaluator.GetRawByteString(const s: UnicodeString;
5123 CodePage: TSystemCodePage; ErrorEl: TPasElement): RawByteString;
5124 var
5125 ok: Boolean;
5126 begin
5127 Result:=UTF8Encode(s);
5128 if (CodePage=CP_UTF8)
5129 or ((DefaultSystemCodePage=CP_UTF8) and ((CodePage=CP_ACP) or (CodePage=CP_NONE))) then
5130 begin
5131 // to UTF-8
5132 SetCodePage(Result,CodePage,false);
5133 end
5134 else
5135 begin
5136 // to non UTF-8 -> possible loss
5137 ok:=false;
5138 try
5139 SetCodePage(Result,CodePage,true);
5140 ok:=true;
5141 except
5142 end;
5143 if (not ok) or (GetUnicodeStr(Result,ErrorEl)<>s) then
5144 LogMsg(20190204165110,mtWarning,nImplictConversionUnicodeToAnsi,
5145 sImplictConversionUnicodeToAnsi,[],ErrorEl);
5146 end;
5147 end;
5148
GetUTF8Strnull5149 function TResExprEvaluator.GetUTF8Str(const s: RawByteString;
5150 ErrorEl: TPasElement): String;
5151 var
5152 CP: TSystemCodePage;
5153 begin
5154 if s='' then exit('');
5155 CP:=GetCodePage(s);
5156 if CP=CP_UTF8 then
5157 begin
5158 if ErrorEl<>nil then
5159 CheckValidUTF8(s,ErrorEl);
5160 Result:=s;
5161 end
5162 else
5163 // use default conversion
5164 Result:=UTF8Encode(UnicodeString(s));
5165 end;
5166
TResExprEvaluator.GetUnicodeStrnull5167 function TResExprEvaluator.GetUnicodeStr(const s: RawByteString;
5168 ErrorEl: TPasElement): UnicodeString;
5169 var
5170 CP: TSystemCodePage;
5171 begin
5172 if s='' then exit('');
5173 CP:=GetCodePage(s);
5174 if CP=CP_UTF8 then
5175 begin
5176 if ErrorEl<>nil then
5177 CheckValidUTF8(s,ErrorEl);
5178 Result:=UTF8Decode(s);
5179 end
5180 else
5181 // use default conversion
5182 Result:=UnicodeString(s);
5183 end;
5184
TResExprEvaluator.GetWideCharnull5185 function TResExprEvaluator.GetWideChar(const s: RawByteString; out w: WideChar
5186 ): boolean;
5187 var
5188 CP: TSystemCodePage;
5189 u: UnicodeString;
5190 begin
5191 w:=#0;
5192 Result:=false;
5193 if s='' then exit;
5194 CP:=GetCodePage(s);
5195 if CP=CP_UTF8 then
5196 begin
5197 if length(s)>4 then exit;
5198 u:=UTF8Decode(s);
5199 if length(u)<>1 then exit;
5200 w:=u[1];
5201 Result:=true;
5202 end
5203 else if length(s)=1 then
5204 begin
5205 w:=s[1];
5206 Result:=true;
5207 end;
5208 end;
5209 {$endif}
5210
5211 procedure TResExprEvaluator.PredBool(Value: TResEvalBool; ErrorEl: TPasElement);
5212 begin
5213 if Value.B=false then
5214 EmitRangeCheckConst(20170624140251,Value.AsString,
5215 'true','true',ErrorEl);
5216 Value.B:=not Value.B;
5217 end;
5218
5219 procedure TResExprEvaluator.SuccBool(Value: TResEvalBool; ErrorEl: TPasElement);
5220 begin
5221 if Value.B=true then
5222 EmitRangeCheckConst(20170624142316,Value.AsString,
5223 'false','false',ErrorEl);
5224 Value.B:=not Value.B;
5225 end;
5226
5227 procedure TResExprEvaluator.PredInt(Value: TResEvalInt; ErrorEl: TPasElement);
5228 begin
5229 if Value.Int=low(TMaxPrecInt) then
5230 begin
5231 EmitRangeCheckConst(20170624142511,IntToStr(Value.Int),
5232 IntToStr(succ(low(TMaxPrecInt))),IntToStr(high(TMaxPrecInt)),ErrorEl);
5233 Value.Int:=high(Value.Int);
5234 end
5235 else
5236 dec(Value.Int);
5237 end;
5238
5239 procedure TResExprEvaluator.SuccInt(Value: TResEvalInt; ErrorEl: TPasElement);
5240 begin
5241 if Value.Int=high(TMaxPrecInt) then
5242 begin
5243 EmitRangeCheckConst(20170624142920,IntToStr(Value.Int),
5244 IntToStr(low(TMaxPrecInt)),IntToStr(pred(high(TMaxPrecInt))),ErrorEl);
5245 Value.Int:=low(Value.Int);
5246 end
5247 else
5248 inc(Value.Int);
5249 end;
5250
5251 procedure TResExprEvaluator.PredUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
5252 begin
5253 if Value.UInt=low(TMaxPrecUInt) then
5254 begin
5255 EmitRangeCheckConst(20170624143122,IntToStr(Value.UInt),
5256 IntToStr(succ(low(TMaxPrecUInt))),IntToStr(high(TMaxPrecUInt)),ErrorEl);
5257 Value.UInt:=high(Value.UInt);
5258 end
5259 else
5260 dec(Value.UInt);
5261 end;
5262
5263 procedure TResExprEvaluator.SuccUInt(Value: TResEvalUInt; ErrorEl: TPasElement);
5264 begin
5265 // Note: when FPC compares int64 with qword it converts the qword to an int64
5266 if Value.UInt=HighIntAsUInt then
5267 begin
5268 EmitRangeCheckConst(20170624142921,IntToStr(Value.UInt),
5269 IntToStr(low(TMaxPrecUInt)),IntToStr(pred(high(TMaxPrecUInt))),ErrorEl);
5270 Value.UInt:=low(Value.UInt);
5271 end
5272 else
5273 inc(Value.UInt);
5274 end;
5275
5276 {$ifdef FPC_HAS_CPSTRING}
5277 procedure TResExprEvaluator.PredString(Value: TResEvalString;
5278 ErrorEl: TPasElement);
5279 begin
5280 if length(Value.S)<>1 then
5281 RaiseRangeCheck(20170624150138,ErrorEl);
5282 if Value.S[1]=#0 then
5283 begin
5284 EmitRangeCheckConst(20170624150220,Value.AsString,'#1','#255',ErrorEl);
5285 Value.S:=#255;
5286 end
5287 else
5288 Value.S:=pred(Value.S[1]);
5289 end;
5290
5291 procedure TResExprEvaluator.SuccString(Value: TResEvalString;
5292 ErrorEl: TPasElement);
5293 begin
5294 if length(Value.S)<>1 then
5295 RaiseRangeCheck(20170624150432,ErrorEl);
5296 if Value.S[1]=#255 then
5297 begin
5298 EmitRangeCheckConst(20170624150441,Value.AsString,'#0','#254',ErrorEl);
5299 Value.S:=#0;
5300 end
5301 else
5302 Value.S:=succ(Value.S[1]);
5303 end;
5304 {$endif}
5305
5306 procedure TResExprEvaluator.PredUnicodeString(Value: TResEvalUTF16;
5307 ErrorEl: TPasElement);
5308 begin
5309 if length(Value.S)<>1 then
5310 RaiseRangeCheck(20170624150703,ErrorEl);
5311 if Value.S[1]=#0 then
5312 begin
5313 EmitRangeCheckConst(20170624150710,Value.AsString,'#1','#65535',ErrorEl);
5314 Value.S:=WideChar(#65535);
5315 end
5316 else
5317 Value.S:=pred(Value.S[1]);
5318 end;
5319
5320 procedure TResExprEvaluator.SuccUnicodeString(Value: TResEvalUTF16;
5321 ErrorEl: TPasElement);
5322 begin
5323 if length(Value.S)<>1 then
5324 RaiseRangeCheck(20170624150849,ErrorEl);
5325 if Value.S[1]=#65535 then
5326 begin
5327 EmitRangeCheckConst(20170624150910,Value.AsString,'#0','#65534',ErrorEl);
5328 Value.S:=#0;
5329 end
5330 else
5331 Value.S:=succ(Value.S[1]);
5332 end;
5333
5334 procedure TResExprEvaluator.PredEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
5335 var
5336 EnumType: TPasEnumType;
5337 begin
5338 EnumType:=Value.ElType as TPasEnumType;
5339 if EnumType=nil then
5340 RaiseInternalError(20170821174038,dbgs(Value));
5341 if Value.Index<=0 then
5342 begin
5343 EmitRangeCheckConst(20170624144332,Value.AsString,
5344 TPasEnumValue(EnumType.Values[Min(1,EnumType.Values.Count-1)]).Name,
5345 TPasEnumValue(EnumType.Values[EnumType.Values.Count-1]).Name,ErrorEl);
5346 Value.Index:=EnumType.Values.Count-1;
5347 end
5348 else
5349 dec(Value.Index);
5350 Value.IdentEl:=TPasEnumValue(EnumType.Values[Value.Index]);
5351 end;
5352
5353 procedure TResExprEvaluator.SuccEnum(Value: TResEvalEnum; ErrorEl: TPasElement);
5354 var
5355 EnumType: TPasEnumType;
5356 begin
5357 EnumType:=Value.ElType as TPasEnumType;
5358 if EnumType=nil then
5359 RaiseInternalError(20170821174058,dbgs(Value));
5360 if Value.Index>=EnumType.Values.Count-1 then
5361 begin
5362 EmitRangeCheckConst(20170624145013,Value.AsString,
5363 TPasEnumValue(EnumType.Values[0]).Name,
5364 TPasEnumValue(EnumType.Values[Max(0,EnumType.Values.Count-2)]).Name,ErrorEl);
5365 Value.Index:=0;
5366 end
5367 else
5368 inc(Value.Index);
5369 Value.IdentEl:=TPasEnumValue(EnumType.Values[Value.Index]);
5370 end;
5371
5372 { TResolveData }
5373
5374 procedure TResolveData.SetElement(AValue: TPasElement);
5375 begin
5376 if FElement=AValue then Exit;
5377 if Element<>nil then
5378 Element.Release{$IFDEF CheckPasTreeRefCount}(ClassName+'.SetElement'){$ENDIF};
5379 FElement:=AValue;
5380 if Element<>nil then
5381 Element.AddRef{$IFDEF CheckPasTreeRefCount}(ClassName+'.SetElement'){$ENDIF};
5382 end;
5383
5384 constructor TResolveData.Create;
5385 begin
5386
5387 end;
5388
5389 destructor TResolveData.Destroy;
5390 begin
5391 {$IFDEF VerbosePasResolverMem}
5392 writeln('TResolveData.Destroy START ',ClassName);
5393 {$ENDIF}
5394 Element:=nil;
5395 Owner:=nil;
5396 Next:=nil;
5397 inherited Destroy;
5398 {$IFDEF VerbosePasResolverMem}
5399 writeln('TResolveData.Destroy END ',ClassName);
5400 {$ENDIF}
5401 end;
5402
5403 { TResEvalValue }
5404
5405 constructor TResEvalValue.CreateKind(const aKind: TREVKind);
5406 begin
5407 Create;
5408 Kind:=aKind;
5409 end;
5410
TResEvalValue.Clonenull5411 function TResEvalValue.Clone: TResEvalValue;
5412 begin
5413 Result:=TResEvalValueClass(ClassType).Create;
5414 Result.Kind:=Kind;
5415 Result.IdentEl:=IdentEl;
5416 end;
5417
AsDebugStringnull5418 function TResEvalValue.AsDebugString: string;
5419 begin
5420 str(Kind,Result);
5421 Result:=Result+'='+AsString;
5422 end;
5423
AsStringnull5424 function TResEvalValue.AsString: string;
5425 begin
5426 case Kind of
5427 revkNone: Result:='<None>';
5428 revkNil: Result:='nil';
5429 else
5430 str(Kind,Result);
5431 end;
5432 end;
5433
5434 { TResEvalUInt }
5435
5436 constructor TResEvalUInt.Create;
5437 begin
5438 inherited Create;
5439 Kind:=revkUInt;
5440 end;
5441
5442 constructor TResEvalUInt.CreateValue(const aValue: TMaxPrecUInt);
5443 begin
5444 Create;
5445 UInt:=aValue;
5446 end;
5447
TResEvalUInt.Clonenull5448 function TResEvalUInt.Clone: TResEvalValue;
5449 begin
5450 Result:=inherited Clone;
5451 TResEvalUInt(Result).UInt:=UInt;
5452 end;
5453
AsStringnull5454 function TResEvalUInt.AsString: string;
5455 begin
5456 Result:=IntToStr(UInt);
5457 end;
5458
5459 { TResEvalInt }
5460
5461 constructor TResEvalInt.Create;
5462 begin
5463 inherited Create;
5464 Kind:=revkInt;
5465 end;
5466
5467 constructor TResEvalInt.CreateValue(const aValue: TMaxPrecInt);
5468 begin
5469 Create;
5470 Int:=aValue;
5471 end;
5472
5473 constructor TResEvalInt.CreateValue(const aValue: TMaxPrecInt; aTyped: TResEvalTypedInt
5474 );
5475 begin
5476 Create;
5477 Int:=aValue;
5478 Typed:=aTyped;
5479 end;
5480
TResEvalInt.Clonenull5481 function TResEvalInt.Clone: TResEvalValue;
5482 begin
5483 Result:=inherited Clone;
5484 TResEvalInt(Result).Int:=Int;
5485 TResEvalInt(Result).Typed:=Typed;
5486 end;
5487
AsStringnull5488 function TResEvalInt.AsString: string;
5489 begin
5490 Result:=IntToStr(Int);
5491 end;
5492
AsDebugStringnull5493 function TResEvalInt.AsDebugString: string;
5494 begin
5495 if Typed=reitNone then
5496 Result:=inherited AsDebugString
5497 else
5498 begin
5499 str(Kind,Result);
5500 case Typed of
5501 reitByte: Result:=Result+':byte';
5502 reitShortInt: Result:=Result+':shortint';
5503 reitWord: Result:=Result+':word';
5504 reitSmallInt: Result:=Result+':smallint';
5505 reitUIntSingle: Result:=Result+':uintsingle';
5506 reitIntSingle: Result:=Result+':intsingle';
5507 reitLongWord: Result:=Result+':longword';
5508 reitLongInt: Result:=Result+':longint';
5509 reitUIntDouble: Result:=Result+':uintdouble';
5510 reitIntDouble: Result:=Result+':intdouble';
5511 end;
5512 Result:=Result+'='+AsString;
5513 end;
5514 end;
5515
5516 { TResEvalFloat }
5517
5518 constructor TResEvalFloat.Create;
5519 begin
5520 inherited Create;
5521 Kind:=revkFloat;
5522 end;
5523
5524 constructor TResEvalFloat.CreateValue(const aValue: TMaxPrecFloat);
5525 begin
5526 Create;
5527 FloatValue:=aValue;
5528 end;
5529
TResEvalFloat.Clonenull5530 function TResEvalFloat.Clone: TResEvalValue;
5531 begin
5532 Result:=inherited Clone;
5533 TResEvalFloat(Result).FloatValue:=FloatValue;
5534 end;
5535
AsStringnull5536 function TResEvalFloat.AsString: string;
5537 begin
5538 str(FloatValue,Result);
5539 end;
5540
TResEvalFloat.IsIntnull5541 function TResEvalFloat.IsInt(out Int: TMaxPrecInt): boolean;
5542 begin
5543 Int:=0;
5544 if Frac(FloatValue)<>0 then exit(false);
5545 if FloatValue<TMaxPrecFloat(low(TMaxPrecInt)) then exit(false);
5546 if FloatValue>TMaxPrecFloat(high(TMaxPrecInt)) then exit(false);
5547 Int:=Trunc(FloatValue);
5548 Result:=true;
5549 end;
5550
5551 {$ifdef FPC_HAS_CPSTRING}
5552 { TResEvalString }
5553
5554 constructor TResEvalString.Create;
5555 begin
5556 inherited Create;
5557 Kind:=revkString;
5558 end;
5559
5560 constructor TResEvalString.CreateValue(const aValue: RawByteString);
5561 begin
5562 Create;
5563 S:=aValue;
5564 end;
5565
TResEvalString.Clonenull5566 function TResEvalString.Clone: TResEvalValue;
5567 begin
5568 Result:=inherited Clone;
5569 TResEvalString(Result).S:=S;
5570 end;
5571
AsStringnull5572 function TResEvalString.AsString: string;
5573 begin
5574 Result:=RawStrToCaption(S,60);
5575 end;
5576 {$endif}
5577
5578 { TResEvalUTF16 }
5579
5580 constructor TResEvalUTF16.Create;
5581 begin
5582 inherited Create;
5583 Kind:=revkUnicodeString;
5584 end;
5585
5586 constructor TResEvalUTF16.CreateValue(const aValue: UnicodeString);
5587 begin
5588 Create;
5589 S:=aValue;
5590 end;
5591
TResEvalUTF16.Clonenull5592 function TResEvalUTF16.Clone: TResEvalValue;
5593 begin
5594 Result:=inherited Clone;
5595 TResEvalUTF16(Result).S:=S;
5596 end;
5597
AsStringnull5598 function TResEvalUTF16.AsString: string;
5599 begin
5600 Result:=String(UnicodeStrToCaption(S,60));
5601 end;
5602
5603 { TResEvalEnum }
5604
5605 constructor TResEvalEnum.Create;
5606 begin
5607 inherited Create;
5608 Kind:=revkEnum;
5609 end;
5610
5611 constructor TResEvalEnum.CreateValue(const aValue: integer;
5612 aIdentEl: TPasEnumValue);
5613 begin
5614 Create;
5615 Index:=aValue;
5616 IdentEl:=aIdentEl;
5617 ElType:=IdentEl.Parent as TPasEnumType;
5618 if ElType=nil then
5619 raise Exception.Create('');
5620 end;
5621
TResEvalEnum.GetEnumValuenull5622 function TResEvalEnum.GetEnumValue: TPasEnumValue;
5623 begin
5624 Result:=nil;
5625 if ElType<>nil then
5626 if (Index>=0) and (Index<ElType.Values.Count) then
5627 Result:=TObject(ElType.Values[Index]) as TPasEnumValue;
5628 end;
5629
GetEnumNamenull5630 function TResEvalEnum.GetEnumName: String;
5631 var
5632 V: TPasEnumValue;
5633 begin
5634 V:=GetEnumValue;
5635 if V<>nil then
5636 Result:=V.Name
5637 else
5638 Result:='';
5639 end;
5640
TResEvalEnum.Clonenull5641 function TResEvalEnum.Clone: TResEvalValue;
5642 begin
5643 Result:=inherited Clone;
5644 TResEvalEnum(Result).Index:=Index;
5645 TResEvalEnum(Result).ElType:=ElType;
5646 end;
5647
AsDebugStringnull5648 function TResEvalEnum.AsDebugString: string;
5649 begin
5650 str(Kind,Result);
5651 Result:=Result+'='+AsString+'='+IntToStr(Index);
5652 end;
5653
AsStringnull5654 function TResEvalEnum.AsString: string;
5655 begin
5656 if IdentEl<>nil then
5657 begin
5658 Result:=IdentEl.Name;
5659 if Result<>'' then exit;
5660 end;
5661 Result:=GetEnumName;
5662 if Result<>'' then exit;
5663 Result:=ElType.Name+'('+IntToStr(Index)+')';
5664 end;
5665
5666 { TResEvalRangeInt }
5667
5668 constructor TResEvalRangeInt.Create;
5669 begin
5670 inherited Create;
5671 Kind:=revkRangeInt;
5672 end;
5673
5674 constructor TResEvalRangeInt.CreateValue(const aElKind: TRESetElKind;
5675 aElType: TPasType; const aRangeStart, aRangeEnd: TMaxPrecInt);
5676 begin
5677 Create;
5678 ElKind:=aElKind;
5679 ElType:=aElType;
5680 RangeStart:=aRangeStart;
5681 RangeEnd:=aRangeEnd;
5682 end;
5683
TResEvalRangeInt.Clonenull5684 function TResEvalRangeInt.Clone: TResEvalValue;
5685 begin
5686 Result:=inherited Clone;
5687 TResEvalRangeInt(Result).ElKind:=ElKind;
5688 TResEvalRangeInt(Result).RangeStart:=RangeStart;
5689 TResEvalRangeInt(Result).RangeEnd:=RangeEnd;
5690 end;
5691
AsStringnull5692 function TResEvalRangeInt.AsString: string;
5693 begin
5694 Result:=ElementAsString(RangeStart)+'..'+ElementAsString(RangeEnd);
5695 end;
5696
AsDebugStringnull5697 function TResEvalRangeInt.AsDebugString: string;
5698 var
5699 s: string;
5700 begin
5701 str(Kind,Result);
5702 str(ElKind,s);
5703 Result:=Result+'/'+s+':'+GetObjName(ElType)+'='+AsString;
5704 end;
5705
ElementAsStringnull5706 function TResEvalRangeInt.ElementAsString(El: TMaxPrecInt): string;
5707 var
5708 EnumValue: TPasEnumValue;
5709 EnumType: TPasEnumType;
5710 begin
5711 case ElKind of
5712 revskBool:
5713 if El=0 then
5714 Result:='false'
5715 else
5716 Result:='true';
5717 revskEnum:
5718 begin
5719 EnumType:=ElType as TPasEnumType;
5720 if (El>=0) and (El<EnumType.Values.Count) then
5721 begin
5722 EnumValue:=TPasEnumValue(EnumType.Values[El]);
5723 Result:=EnumValue.Name;
5724 end
5725 else
5726 Result:=ElType.Name+'('+IntToStr(El)+')';
5727 end;
5728 revskInt: Result:=IntToStr(El);
5729 revskChar:
5730 if ((El>=32) and (El<=38)) or ((El>=40) and (El<=126)) then
5731 Result:=''''+Chr(El)+''''
5732 else
5733 Result:='#'+IntToStr(El);
5734 end;
5735 end;
5736
5737 { TResEvalSet }
5738
5739 constructor TResEvalSet.Create;
5740 begin
5741 inherited Create;
5742 Kind:=revkSetOfInt;
5743 end;
5744
5745 constructor TResEvalSet.CreateEmpty(const aElKind: TRESetElKind;
5746 aElType: TPasType);
5747 begin
5748 Create;
5749 ElKind:=aElKind;
5750 ElType:=aElType;
5751 end;
5752
5753 constructor TResEvalSet.CreateEmptySameKind(aSet: TResEvalSet);
5754 begin
5755 Create;
5756 IdentEl:=aSet.IdentEl;
5757 ElKind:=aSet.ElKind;
5758 ElType:=aSet.ElType;
5759 end;
5760
5761 constructor TResEvalSet.CreateValue(const aElKind: TRESetElKind;
5762 aElType: TPasType; const aRangeStart, aRangeEnd: TMaxPrecInt);
5763 begin
5764 inherited CreateValue(aElKind, aElType, aRangeStart, aRangeEnd);
5765 Add(aRangeStart,aRangeEnd);
5766 end;
5767
TResEvalSet.Clonenull5768 function TResEvalSet.Clone: TResEvalValue;
5769 var
5770 RS: TResEvalSet;
5771 i: Integer;
5772 begin
5773 Result:=inherited Clone;
5774 RS:=TResEvalSet(Result);
5775 RS.ElKind:=ElKind;
5776 RS.ElType:=ElType;
5777 SetLength(RS.Ranges,length(Ranges));
5778 for i:=0 to length(Ranges)-1 do
5779 RS.Ranges[i]:=Ranges[i];
5780 end;
5781
AsStringnull5782 function TResEvalSet.AsString: string;
5783 var
5784 i: Integer;
5785 begin
5786 Result:='[';
5787 for i:=0 to length(Ranges)-1 do
5788 begin
5789 if i>0 then Result:=Result+',';
5790 Result:=Result+ElementAsString(Ranges[i].RangeStart);
5791 if Ranges[i].RangeStart<>Ranges[i].RangeEnd then
5792 Result:=Result+'..'+ElementAsString(Ranges[i].RangeEnd);
5793 end;
5794 Result:=Result+']';
5795 end;
5796
Addnull5797 function TResEvalSet.Add(aRangeStart, aRangeEnd: TMaxPrecInt): boolean;
5798
5799 {$IF FPC_FULLVERSION<30101}
5800 procedure Insert(const Item: TItem; var Items: TItems; Index: integer);
5801 var
5802 i: Integer;
5803 begin
5804 Setlength(Items,length(Items)+1);
5805 for i:=length(Items)-1 downto Index+1 do
5806 Items[i]:=Items[i-1];
5807 Items[Index]:=Item;
5808 end;
5809
5810 procedure Delete(var Items: TItems; Start, Size: integer);
5811 var
5812 i: Integer;
5813 begin
5814 if Size=0 then exit;
5815 for i:=Start+Size to length(Items)-1 do
5816 Items[i-Size]:=Items[i];
5817 Setlength(Items,length(Items)-Size);
5818 end;
5819 {$ENDIF}
5820
5821 var
5822 StartIndex, l, EndIndex: Integer;
5823 Item: TItem;
5824 begin
5825 Result:=false;
5826 {$IFDEF VerbosePasResEval}
5827 writeln('TResEvalSetInt.Add ',aRangeStart,'..',aRangeEnd);
5828 {$ENDIF}
5829 if aRangeStart>aRangeEnd then
5830 raise Exception.Create('');
5831 if ElKind=revskNone then
5832 raise Exception.Create('');
5833
5834 l:=length(Ranges);
5835 if l=0 then
5836 begin
5837 // first range
5838 RangeStart:=aRangeStart;
5839 RangeEnd:=aRangeEnd;
5840 SetLength(Ranges,1);
5841 Ranges[0].RangeStart:=aRangeStart;
5842 Ranges[0].RangeEnd:=aRangeEnd;
5843 exit(true);
5844 end;
5845 if RangeStart>aRangeStart then
5846 RangeStart:=aRangeStart;
5847 if RangeEnd<aRangeEnd then
5848 RangeEnd:=aRangeEnd;
5849
5850 // find insert position
5851 StartIndex:=IndexOfRange(aRangeStart,true);
5852 if (StartIndex>0) and (Ranges[StartIndex-1].RangeEnd=aRangeStart-1) then
5853 dec(StartIndex);
5854 if StartIndex=l then
5855 begin
5856 // add new range
5857 Item.RangeStart:=aRangeStart;
5858 Item.RangeEnd:=aRangeEnd;
5859 Insert(Item,Ranges,StartIndex);
5860 Result:=true;
5861 end
5862 else
5863 begin
5864 // StartIndex is now the first affected range
5865 EndIndex:=IndexOfRange(aRangeEnd,true);
5866 if (EndIndex>StartIndex) then
5867 if (EndIndex=l) or (Ranges[EndIndex].RangeStart>aRangeEnd+1) then
5868 dec(EndIndex);
5869 // EndIndex is now the last affected range
5870 if StartIndex>EndIndex then
5871 raise Exception.Create('');
5872 if StartIndex=EndIndex then
5873 begin
5874 if (Ranges[StartIndex].RangeStart>aRangeEnd) then
5875 begin
5876 // range in front
5877 if (Ranges[StartIndex].RangeStart>aRangeEnd+1) then
5878 begin
5879 // insert new range
5880 Item.RangeStart:=aRangeStart;
5881 Item.RangeEnd:=aRangeEnd;
5882 Insert(Item,Ranges,StartIndex);
5883 Result:=true;
5884 end
5885 else
5886 begin
5887 // enlarge range at its start
5888 Ranges[StartIndex].RangeStart:=aRangeStart;
5889 Result:=true;
5890 end;
5891 end
5892 else if Ranges[StartIndex].RangeEnd<aRangeStart then
5893 begin
5894 // range behind
5895 if Ranges[StartIndex].RangeEnd+1<aRangeStart then
5896 begin
5897 // insert new range
5898 Item.RangeStart:=aRangeStart;
5899 Item.RangeEnd:=aRangeEnd;
5900 Insert(Item,Ranges,StartIndex+1);
5901 Result:=true;
5902 end
5903 else
5904 begin
5905 // enlarge range at its end
5906 Ranges[StartIndex].RangeEnd:=aRangeEnd;
5907 Result:=true;
5908 end;
5909 end
5910 else
5911 begin
5912 // intersection -> enlarge to union range
5913 Result:=false;
5914 if (Ranges[StartIndex].RangeStart>aRangeStart) then
5915 Ranges[StartIndex].RangeStart:=aRangeStart;
5916 if (Ranges[StartIndex].RangeEnd<aRangeEnd) then
5917 Ranges[StartIndex].RangeEnd:=aRangeEnd;
5918 end;
5919 end
5920 else
5921 begin
5922 // multiple ranges are merged to one
5923 Result:=false;
5924 if Ranges[StartIndex].RangeStart>aRangeStart then
5925 Ranges[StartIndex].RangeStart:=aRangeStart;
5926 if aRangeEnd<Ranges[EndIndex].RangeEnd then
5927 aRangeEnd:=Ranges[EndIndex].RangeEnd;
5928 Ranges[StartIndex].RangeEnd:=aRangeEnd;
5929 Delete(Ranges,StartIndex+1,EndIndex-StartIndex);
5930 end;
5931 end;
5932 {$IFDEF VerbosePasResEval}
5933 writeln('TResEvalSetInt.Add END ',AsDebugString);
5934 ConsistencyCheck;
5935 {$ENDIF}
5936 end;
5937
IndexOfRangenull5938 function TResEvalSet.IndexOfRange(Index: TMaxPrecInt; FindInsertPos: boolean
5939 ): integer;
5940 var
5941 l, r, m: Integer;
5942 begin
5943 l:=0;
5944 r:=length(Ranges)-1;
5945 while l<=r do
5946 begin
5947 m:=(l+r) div 2;
5948 if Ranges[m].RangeStart>Index then
5949 r:=m-1
5950 else if Ranges[m].RangeEnd<Index then
5951 l:=m+1
5952 else
5953 exit(m);
5954 end;
5955 if not FindInsertPos then
5956 exit(-1);
5957 // find insert position
5958 if length(Ranges)=0 then
5959 exit(0)
5960 else if l>m then
5961 exit(l)
5962 else
5963 exit(m);
5964 Result:=-1;
5965 end;
5966
TResEvalSet.Intersectsnull5967 function TResEvalSet.Intersects(aRangeStart, aRangeEnd: TMaxPrecInt): integer;
5968 var
5969 Index: Integer;
5970 begin
5971 Index:=IndexOfRange(aRangeStart,true);
5972 if (Index=length(Ranges)) or (Ranges[Index].RangeStart>aRangeEnd) then
5973 Result:=-1
5974 else
5975 Result:=Index;
5976 end;
5977
5978 procedure TResEvalSet.ConsistencyCheck;
5979
5980 procedure E(Msg: string);
5981 begin
5982 raise Exception.Create(Msg);
5983 end;
5984
5985 var
5986 i: Integer;
5987 begin
5988 if (ElKind=revskNone) and (length(Ranges)>0) then
5989 E('');
5990 for i:=0 to length(Ranges)-1 do
5991 begin
5992 if Ranges[i].RangeStart>Ranges[i].RangeEnd then
5993 E('');
5994 if (i>0) and (Ranges[i-1].RangeEnd+1>=Ranges[i].RangeStart) then
5995 E('missing gap');
5996 if RangeStart>Ranges[i].RangeStart then
5997 E('wrong RangeStart='+IntToStr(RangeStart));
5998 if RangeEnd<Ranges[i].RangeEnd then
5999 E('wrong RangeEnd='+IntToStr(RangeEnd));
6000 end;
6001 end;
6002
6003 end.
6004
6005