1 |
torben |
2671 |
// Upgraded to Delphi 2009: Sebastian Zierer
|
2 |
|
|
|
3 |
|
|
(* ***** BEGIN LICENSE BLOCK *****
|
4 |
|
|
* Version: MPL 1.1
|
5 |
|
|
*
|
6 |
|
|
* The contents of this file are subject to the Mozilla Public License Version
|
7 |
|
|
* 1.1 (the "License"); you may not use this file except in compliance with
|
8 |
|
|
* the License. You may obtain a copy of the License at
|
9 |
|
|
* http://www.mozilla.org/MPL/
|
10 |
|
|
*
|
11 |
|
|
* Software distributed under the License is distributed on an "AS IS" basis,
|
12 |
|
|
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
13 |
|
|
* for the specific language governing rights and limitations under the
|
14 |
|
|
* License.
|
15 |
|
|
*
|
16 |
|
|
* The Original Code is TurboPower SysTools
|
17 |
|
|
*
|
18 |
|
|
* The Initial Developer of the Original Code is
|
19 |
|
|
* TurboPower Software
|
20 |
|
|
*
|
21 |
|
|
* Portions created by the Initial Developer are Copyright (C) 1996-2002
|
22 |
|
|
* the Initial Developer. All Rights Reserved.
|
23 |
|
|
*
|
24 |
|
|
* Contributor(s):
|
25 |
|
|
*
|
26 |
|
|
* ***** END LICENSE BLOCK ***** *)
|
27 |
|
|
|
28 |
|
|
{*********************************************************}
|
29 |
|
|
{* SysTools: StExpr.pas 4.04 *}
|
30 |
|
|
{*********************************************************}
|
31 |
|
|
{* SysTools: Expression evaluator component *}
|
32 |
|
|
{*********************************************************}
|
33 |
|
|
|
34 |
|
|
{$I StDefine.inc}
|
35 |
|
|
|
36 |
|
|
unit StExpr;
|
37 |
|
|
|
38 |
|
|
interface
|
39 |
|
|
|
40 |
|
|
uses
|
41 |
|
|
Windows,
|
42 |
|
|
Classes, Controls, Messages, StdCtrls, SysUtils,
|
43 |
|
|
{$IFDEF UseMathUnit} Math, {$ENDIF}
|
44 |
|
|
StBase, StConst, StMath;
|
45 |
|
|
|
46 |
|
|
type
|
47 |
|
|
{TStFloat = Double;} {TStFloat is defined in StBase}
|
48 |
|
|
{.Z+}
|
49 |
|
|
PStFloat = ^TStFloat;
|
50 |
|
|
{.Z-}
|
51 |
|
|
|
52 |
|
|
type
|
53 |
|
|
{user-defined functions with up to 3 parameters}
|
54 |
|
|
TStFunction0Param =
|
55 |
|
|
function : TStFloat;
|
56 |
|
|
TStFunction1Param =
|
57 |
|
|
function(Value1 : TStFloat) : TStFloat;
|
58 |
|
|
TStFunction2Param =
|
59 |
|
|
function(Value1, Value2 : TStFloat) : TStFloat;
|
60 |
|
|
TStFunction3Param =
|
61 |
|
|
function(Value1, Value2, Value3 : TStFloat) : TStFloat;
|
62 |
|
|
|
63 |
|
|
{user-defined methods with up to 3 parameters}
|
64 |
|
|
TStMethod0Param =
|
65 |
|
|
function : TStFloat
|
66 |
|
|
of object;
|
67 |
|
|
TStMethod1Param =
|
68 |
|
|
function(Value1 : TStFloat) : TStFloat
|
69 |
|
|
of object;
|
70 |
|
|
TStMethod2Param =
|
71 |
|
|
function(Value1, Value2 : TStFloat) : TStFloat
|
72 |
|
|
of object;
|
73 |
|
|
TStMethod3Param =
|
74 |
|
|
function(Value1, Value2, Value3 : TStFloat) : TStFloat
|
75 |
|
|
of object;
|
76 |
|
|
|
77 |
|
|
TStGetIdentValueEvent =
|
78 |
|
|
procedure(Sender : TObject; const Identifier : String; var Value : TStFloat)
|
79 |
|
|
of object;
|
80 |
|
|
|
81 |
|
|
{.Z+}
|
82 |
|
|
{tokens}
|
83 |
|
|
TStToken = (
|
84 |
|
|
ssStart, ssInIdent, ssInNum, ssInSign, ssInExp, ssEol, ssNum, ssIdent,
|
85 |
|
|
ssLPar, ssRPar, ssComma, ssPlus, ssMinus, ssTimes, ssDiv, ssEqual, ssPower);
|
86 |
|
|
|
87 |
|
|
const
|
88 |
|
|
{Note: see Initialization section!}
|
89 |
|
|
StExprOperators : array[ssLPar..ssPower] of Char = '(),+-*/=^';
|
90 |
|
|
{$IFNDEF VERSION4}
|
91 |
|
|
var
|
92 |
|
|
ListSeparator : Char;
|
93 |
|
|
{$ENDIF VERSION4}
|
94 |
|
|
{.Z-}
|
95 |
|
|
|
96 |
|
|
type
|
97 |
|
|
TStExpression = class(TStComponent)
|
98 |
|
|
{.Z+}
|
99 |
|
|
protected {private}
|
100 |
|
|
{property variables}
|
101 |
|
|
FAllowEqual : Boolean;
|
102 |
|
|
FLastError : Integer;
|
103 |
|
|
FErrorPos : Integer;
|
104 |
|
|
FExpression : String;
|
105 |
|
|
|
106 |
|
|
{event variables}
|
107 |
|
|
FOnAddIdentifier : TNotifyEvent;
|
108 |
|
|
FOnGetIdentValue : TStGetIdentValueEvent;
|
109 |
|
|
|
110 |
|
|
{internal variables}
|
111 |
|
|
eBusyFlag : Boolean;
|
112 |
|
|
eCurChar : Char;
|
113 |
|
|
eExprPos : Integer;
|
114 |
|
|
eIdentList : TList;
|
115 |
|
|
eStack : TList;
|
116 |
|
|
eToken : TStToken;
|
117 |
|
|
eTokenStr : String;
|
118 |
|
|
lhs, rhs : TStFloat;
|
119 |
|
|
|
120 |
|
|
{property methods}
|
121 |
|
|
function GetAsInteger : Integer;
|
122 |
|
|
function GetAsString : String;
|
123 |
|
|
|
124 |
|
|
{ident list routines}
|
125 |
|
|
function FindIdent(Name : String) : Integer;
|
126 |
|
|
|
127 |
|
|
{stack routines}
|
128 |
|
|
procedure StackClear;
|
129 |
|
|
function StackCount : Integer;
|
130 |
|
|
procedure StackPush(const Value : TStFloat);
|
131 |
|
|
function StackPeek : TStFloat;
|
132 |
|
|
function StackPop : TStFloat;
|
133 |
|
|
function StackEmpty : Boolean;
|
134 |
|
|
|
135 |
|
|
procedure DoOnAddIdentifier;
|
136 |
|
|
procedure GetBase;
|
137 |
|
|
{-base: unsigned_num | (expression) | sign factor | func_call }
|
138 |
|
|
procedure GetExpression;
|
139 |
|
|
{-expression: term | expression+term | expression-term implemented as loop}
|
140 |
|
|
procedure GetFactor;
|
141 |
|
|
{-factor: base | base^factor}
|
142 |
|
|
procedure GetFunction;
|
143 |
|
|
{-func_call: identifier | identifier(params)}
|
144 |
|
|
procedure GetParams(N : Integer);
|
145 |
|
|
{-params: expression | params,expression}
|
146 |
|
|
procedure GetTerm;
|
147 |
|
|
{-term: factor | term*factor | term/factor implemented as loop}
|
148 |
|
|
procedure GetToken;
|
149 |
|
|
{-return the next token string in eTokenStr and type in eToken}
|
150 |
|
|
function PopOperand : TStFloat;
|
151 |
|
|
{-remove top operand value from stack}
|
152 |
|
|
procedure RaiseExprError(Code : LongInt; Column : Integer);
|
153 |
|
|
{-generate an expression exception}
|
154 |
|
|
|
155 |
|
|
public
|
156 |
|
|
constructor Create(AOwner : TComponent);
|
157 |
|
|
override;
|
158 |
|
|
destructor Destroy;
|
159 |
|
|
override;
|
160 |
|
|
{.Z-}
|
161 |
|
|
|
162 |
|
|
function AnalyzeExpression : TStFloat;
|
163 |
|
|
procedure AddConstant(const Name : String; Value : TStFloat);
|
164 |
|
|
procedure AddFunction0Param(const Name : String; FunctionAddr : TStFunction0Param);
|
165 |
|
|
procedure AddFunction1Param(const Name : String; FunctionAddr : TStFunction1Param);
|
166 |
|
|
procedure AddFunction2Param(const Name : String; FunctionAddr : TStFunction2Param);
|
167 |
|
|
procedure AddFunction3Param(const Name : String; FunctionAddr : TStFunction3Param);
|
168 |
|
|
procedure AddInternalFunctions;
|
169 |
|
|
procedure AddMethod0Param(const Name : String; MethodAddr : TStMethod0Param);
|
170 |
|
|
procedure AddMethod1Param(const Name : String; MethodAddr : TStMethod1Param);
|
171 |
|
|
procedure AddMethod2Param(const Name : String; MethodAddr : TStMethod2Param);
|
172 |
|
|
procedure AddMethod3Param(const Name : String; MethodAddr : TStMethod3Param);
|
173 |
|
|
procedure AddVariable(const Name : String; VariableAddr : PStFloat);
|
174 |
|
|
procedure ClearIdentifiers;
|
175 |
|
|
procedure GetIdentList(S : TStrings);
|
176 |
|
|
procedure RemoveIdentifier(const Name : String);
|
177 |
|
|
|
178 |
|
|
{public properties}
|
179 |
|
|
property AsInteger : Integer
|
180 |
|
|
read GetAsInteger;
|
181 |
|
|
property AsFloat : TStFloat
|
182 |
|
|
read AnalyzeExpression;
|
183 |
|
|
property AsString : String
|
184 |
|
|
read GetAsString;
|
185 |
|
|
property ErrorPosition : Integer
|
186 |
|
|
read FErrorPos;
|
187 |
|
|
property Expression : String
|
188 |
|
|
read FExpression write FExpression;
|
189 |
|
|
property LastError : Integer
|
190 |
|
|
read FLastError;
|
191 |
|
|
|
192 |
|
|
published
|
193 |
|
|
property AllowEqual : Boolean
|
194 |
|
|
read FAllowEqual write FAllowEqual default True;
|
195 |
|
|
|
196 |
|
|
property OnAddIdentifier : TNotifyEvent
|
197 |
|
|
read FOnAddIdentifier write FOnAddIdentifier;
|
198 |
|
|
property OnGetIdentValue : TStGetIdentValueEvent
|
199 |
|
|
read FOnGetIdentValue write FOnGetIdentValue;
|
200 |
|
|
end;
|
201 |
|
|
|
202 |
|
|
|
203 |
|
|
type
|
204 |
|
|
TStExprErrorEvent =
|
205 |
|
|
procedure(Sender : TObject; ErrorNumber : LongInt; const ErrorStr : String)
|
206 |
|
|
of object;
|
207 |
|
|
|
208 |
|
|
type
|
209 |
|
|
TStExpressionEdit = class(TStBaseEdit)
|
210 |
|
|
{.Z+}
|
211 |
|
|
protected {private}
|
212 |
|
|
{property variables}
|
213 |
|
|
FAutoEval : Boolean;
|
214 |
|
|
FExpr : TStExpression;
|
215 |
|
|
FOnError : TStExprErrorEvent;
|
216 |
|
|
|
217 |
|
|
{property methods}
|
218 |
|
|
function GetOnAddIdentifier : TNotifyEvent;
|
219 |
|
|
function GetOnGetIdentValue : TStGetIdentValueEvent;
|
220 |
|
|
procedure SetOnAddIdentifier(Value : TNotifyEvent);
|
221 |
|
|
procedure SetOnGetIdentValue(Value : TStGetIdentValueEvent);
|
222 |
|
|
|
223 |
|
|
{VCL control methods}
|
224 |
|
|
procedure CMExit(var Msg : TMessage);
|
225 |
|
|
message CM_EXIT;
|
226 |
|
|
procedure DoEvaluate;
|
227 |
|
|
{.Z-}
|
228 |
|
|
|
229 |
|
|
protected
|
230 |
|
|
procedure KeyPress(var Key: Char);
|
231 |
|
|
override;
|
232 |
|
|
|
233 |
|
|
public
|
234 |
|
|
constructor Create(AOwner : TComponent);
|
235 |
|
|
override;
|
236 |
|
|
destructor Destroy;
|
237 |
|
|
override;
|
238 |
|
|
|
239 |
|
|
function Evaluate : TStFloat;
|
240 |
|
|
|
241 |
|
|
property Expr : TStExpression
|
242 |
|
|
read FExpr;
|
243 |
|
|
|
244 |
|
|
published
|
245 |
|
|
property AutoEval : Boolean
|
246 |
|
|
read FAutoEval write FAutoEval default False;
|
247 |
|
|
|
248 |
|
|
property OnAddIdentifier : TNotifyEvent
|
249 |
|
|
read GetOnAddIdentifier write SetOnAddIdentifier;
|
250 |
|
|
property OnError : TStExprErrorEvent
|
251 |
|
|
read FOnError write FOnError;
|
252 |
|
|
property OnGetIdentValue : TStGetIdentValueEvent
|
253 |
|
|
read GetOnGetIdentValue write SetOnGetIdentValue;
|
254 |
|
|
end;
|
255 |
|
|
|
256 |
|
|
function AnalyzeExpr(const Expr : String) : Double;
|
257 |
|
|
{-Compute the arithmetic expression Expr and return the result}
|
258 |
|
|
|
259 |
|
|
procedure TpVal(const S : String; var V : Extended; var Code : Integer);
|
260 |
|
|
{
|
261 |
|
|
Evaluate string as a floating point number, emulates Borlandish Pascal's
|
262 |
|
|
Val() intrinsic
|
263 |
|
|
}
|
264 |
|
|
|
265 |
|
|
|
266 |
|
|
implementation
|
267 |
|
|
|
268 |
|
|
const
|
269 |
|
|
Alpha = ['A'..'Z', 'a'..'z', '_'];
|
270 |
|
|
{ Numeric = ['0'..'9', '.']; }
|
271 |
|
|
AlphaNumeric = Alpha + ['0'..'9'];
|
272 |
|
|
var
|
273 |
|
|
{Note: see Initialization section!}
|
274 |
|
|
Numeric: set of Ansichar;
|
275 |
|
|
|
276 |
|
|
type
|
277 |
|
|
PStIdentRec = ^TStIdentRec;
|
278 |
|
|
{a double-variant record - wow - confusing maybe, but it saves space}
|
279 |
|
|
TStIdentRec = record
|
280 |
|
|
Name : String;
|
281 |
|
|
Kind : (ikConstant, ikVariable, ikFunction, ikMethod);
|
282 |
|
|
case Byte of
|
283 |
|
|
0 : (Value : TStFloat);
|
284 |
|
|
1 : (VarAddr : PStFloat);
|
285 |
|
|
2 : (PCount : Integer;
|
286 |
|
|
case Byte of
|
287 |
|
|
0 : (Func0Addr : TStFunction0Param);
|
288 |
|
|
1 : (Func1Addr : TStFunction1Param);
|
289 |
|
|
2 : (Func2Addr : TStFunction2Param);
|
290 |
|
|
3 : (Func3Addr : TStFunction3Param);
|
291 |
|
|
4 : (Meth0Addr : TStMethod0Param);
|
292 |
|
|
5 : (Meth1Addr : TStMethod1Param);
|
293 |
|
|
6 : (Meth2Addr : TStMethod2Param);
|
294 |
|
|
7 : (Meth3Addr : TStMethod3Param);
|
295 |
|
|
)
|
296 |
|
|
end;
|
297 |
|
|
|
298 |
|
|
|
299 |
|
|
{routine for backward compatibility}
|
300 |
|
|
|
301 |
|
|
function AnalyzeExpr(const Expr : String) : Double;
|
302 |
|
|
begin
|
303 |
|
|
with TStExpression.Create(nil) do
|
304 |
|
|
try
|
305 |
|
|
Expression := Expr;
|
306 |
|
|
Result := AnalyzeExpression;
|
307 |
|
|
finally
|
308 |
|
|
Free;
|
309 |
|
|
end;
|
310 |
|
|
end;
|
311 |
|
|
|
312 |
|
|
|
313 |
|
|
{*** function definitions ***}
|
314 |
|
|
|
315 |
|
|
function _Abs(Value : TStFloat) : TStFloat; far;
|
316 |
|
|
begin
|
317 |
|
|
Result := Abs(Value);
|
318 |
|
|
end;
|
319 |
|
|
|
320 |
|
|
function _ArcTan(Value : TStFloat) : TStFloat; far;
|
321 |
|
|
begin
|
322 |
|
|
Result := ArcTan(Value);
|
323 |
|
|
end;
|
324 |
|
|
|
325 |
|
|
function _Cos(Value : TStFloat) : TStFloat; far;
|
326 |
|
|
begin
|
327 |
|
|
Result := Cos(Value);
|
328 |
|
|
end;
|
329 |
|
|
|
330 |
|
|
function _Exp(Value : TStFloat) : TStFloat; far;
|
331 |
|
|
begin
|
332 |
|
|
Result := Exp(Value);
|
333 |
|
|
end;
|
334 |
|
|
|
335 |
|
|
function _Frac(Value : TStFloat) : TStFloat; far;
|
336 |
|
|
begin
|
337 |
|
|
Result := Frac(Value);
|
338 |
|
|
end;
|
339 |
|
|
|
340 |
|
|
function _Int(Value : TStFloat) : TStFloat; far;
|
341 |
|
|
begin
|
342 |
|
|
Result := Int(Value);
|
343 |
|
|
end;
|
344 |
|
|
|
345 |
|
|
function _Trunc(Value : TStFloat) : TStFloat; far;
|
346 |
|
|
begin
|
347 |
|
|
Result := Trunc(Value);
|
348 |
|
|
end;
|
349 |
|
|
|
350 |
|
|
function _Ln(Value : TStFloat) : TStFloat; far;
|
351 |
|
|
begin
|
352 |
|
|
Result := Ln(Value);
|
353 |
|
|
end;
|
354 |
|
|
|
355 |
|
|
function _Pi : TStFloat; far;
|
356 |
|
|
begin
|
357 |
|
|
Result := Pi;
|
358 |
|
|
end;
|
359 |
|
|
|
360 |
|
|
function _Round(Value : TStFloat) : TStFloat; far;
|
361 |
|
|
begin
|
362 |
|
|
Result := Round(Value);
|
363 |
|
|
end;
|
364 |
|
|
|
365 |
|
|
function _Sin(Value : TStFloat) : TStFloat; far;
|
366 |
|
|
begin
|
367 |
|
|
Result := Sin(Value);
|
368 |
|
|
end;
|
369 |
|
|
|
370 |
|
|
function _Sqr(Value : TStFloat) : TStFloat; far;
|
371 |
|
|
begin
|
372 |
|
|
Result := Sqr(Value);
|
373 |
|
|
end;
|
374 |
|
|
|
375 |
|
|
function _Sqrt(Value : TStFloat) : TStFloat; far;
|
376 |
|
|
begin
|
377 |
|
|
Result := Sqrt(Value);
|
378 |
|
|
end;
|
379 |
|
|
|
380 |
|
|
{$IFDEF UseMathUnit}
|
381 |
|
|
function _ArcCos(Value : TStFloat) : TStFloat; far;
|
382 |
|
|
begin
|
383 |
|
|
Result := ArcCos(Value);
|
384 |
|
|
end;
|
385 |
|
|
|
386 |
|
|
function _ArcSin(Value : TStFloat) : TStFloat; far;
|
387 |
|
|
begin
|
388 |
|
|
Result := ArcSin(Value);
|
389 |
|
|
end;
|
390 |
|
|
|
391 |
|
|
function _ArcTan2(Value1, Value2 : TStFloat) : TStFloat; far;
|
392 |
|
|
begin
|
393 |
|
|
Result := ArcTan2(Value1, Value2);
|
394 |
|
|
end;
|
395 |
|
|
|
396 |
|
|
function _Tan(Value : TStFloat) : TStFloat; far;
|
397 |
|
|
begin
|
398 |
|
|
Result := Tan(Value);
|
399 |
|
|
end;
|
400 |
|
|
|
401 |
|
|
function _Cotan(Value : TStFloat) : TStFloat; far;
|
402 |
|
|
begin
|
403 |
|
|
Result := CoTan(Value);
|
404 |
|
|
end;
|
405 |
|
|
|
406 |
|
|
function _Hypot(Value1, Value2 : TStFloat) : TStFloat; far;
|
407 |
|
|
begin
|
408 |
|
|
Result := Hypot(Value1, Value2);
|
409 |
|
|
end;
|
410 |
|
|
|
411 |
|
|
function _Cosh(Value : TStFloat) : TStFloat; far;
|
412 |
|
|
begin
|
413 |
|
|
Result := Cosh(Value);
|
414 |
|
|
end;
|
415 |
|
|
|
416 |
|
|
function _Sinh(Value : TStFloat) : TStFloat; far;
|
417 |
|
|
begin
|
418 |
|
|
Result := Sinh(Value);
|
419 |
|
|
end;
|
420 |
|
|
|
421 |
|
|
function _Tanh(Value : TStFloat) : TStFloat; far;
|
422 |
|
|
begin
|
423 |
|
|
Result := Tanh(Value);
|
424 |
|
|
end;
|
425 |
|
|
|
426 |
|
|
function _ArcCosh(Value : TStFloat) : TStFloat; far;
|
427 |
|
|
begin
|
428 |
|
|
Result := ArcCosh(Value);
|
429 |
|
|
end;
|
430 |
|
|
|
431 |
|
|
function _ArcSinh(Value : TStFloat) : TStFloat; far;
|
432 |
|
|
begin
|
433 |
|
|
Result := ArcSinh(Value);
|
434 |
|
|
end;
|
435 |
|
|
|
436 |
|
|
function _ArcTanh(Value : TStFloat) : TStFloat; far;
|
437 |
|
|
begin
|
438 |
|
|
Result := ArcTanh(Value);
|
439 |
|
|
end;
|
440 |
|
|
|
441 |
|
|
function _Lnxp1(Value : TStFloat) : TStFloat; far;
|
442 |
|
|
begin
|
443 |
|
|
Result := Lnxp1(Value);
|
444 |
|
|
end;
|
445 |
|
|
|
446 |
|
|
function _Log10(Value : TStFloat) : TStFloat; far;
|
447 |
|
|
begin
|
448 |
|
|
Result := Log10(Value);
|
449 |
|
|
end;
|
450 |
|
|
|
451 |
|
|
function _Log2(Value : TStFloat) : TStFloat; far;
|
452 |
|
|
begin
|
453 |
|
|
Result := Log2(Value);
|
454 |
|
|
end;
|
455 |
|
|
|
456 |
|
|
function _LogN(Value1, Value2 : TStFloat) : TStFloat; far;
|
457 |
|
|
begin
|
458 |
|
|
Result := LogN(Value1, Value2);
|
459 |
|
|
end;
|
460 |
|
|
|
461 |
|
|
function _Ceil(Value : TStFloat) : TStFloat; far;
|
462 |
|
|
begin
|
463 |
|
|
Result := Ceil(Value);
|
464 |
|
|
end;
|
465 |
|
|
|
466 |
|
|
function _Floor(Value : TStFloat) : TStFloat; far;
|
467 |
|
|
begin
|
468 |
|
|
Result := Floor(Value);
|
469 |
|
|
end;
|
470 |
|
|
{$ENDIF}
|
471 |
|
|
|
472 |
|
|
|
473 |
|
|
{*** TStExpression ***}
|
474 |
|
|
|
475 |
|
|
procedure TStExpression.AddConstant(const Name : String; Value : TStFloat);
|
476 |
|
|
var
|
477 |
|
|
IR : PStIdentRec;
|
478 |
|
|
begin
|
479 |
|
|
if FindIdent(Name) > -1 then
|
480 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
481 |
|
|
|
482 |
|
|
New(IR);
|
483 |
|
|
IR^.Name := LowerCase(Name);
|
484 |
|
|
IR^.Kind := ikConstant;
|
485 |
|
|
IR^.Value := Value;
|
486 |
|
|
eIdentList.Add(IR);
|
487 |
|
|
|
488 |
|
|
DoOnAddIdentifier;
|
489 |
|
|
end;
|
490 |
|
|
|
491 |
|
|
procedure TStExpression.AddFunction0Param(const Name : String;
|
492 |
|
|
FunctionAddr : TStFunction0Param);
|
493 |
|
|
var
|
494 |
|
|
IR : PStIdentRec;
|
495 |
|
|
begin
|
496 |
|
|
if FindIdent(Name) > -1 then
|
497 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
498 |
|
|
|
499 |
|
|
New(IR);
|
500 |
|
|
IR^.Name := LowerCase(Name);
|
501 |
|
|
IR^.PCount := 0;
|
502 |
|
|
IR^.Kind := ikFunction;
|
503 |
|
|
IR^.Func0Addr := FunctionAddr;
|
504 |
|
|
eIdentList.Add(IR);
|
505 |
|
|
|
506 |
|
|
DoOnAddIdentifier;
|
507 |
|
|
end;
|
508 |
|
|
|
509 |
|
|
procedure TStExpression.AddFunction1Param(const Name : String;
|
510 |
|
|
FunctionAddr : TStFunction1Param);
|
511 |
|
|
var
|
512 |
|
|
IR : PStIdentRec;
|
513 |
|
|
begin
|
514 |
|
|
if FindIdent(Name) > -1 then
|
515 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
516 |
|
|
|
517 |
|
|
New(IR);
|
518 |
|
|
IR^.Name := LowerCase(Name);
|
519 |
|
|
IR^.PCount := 1;
|
520 |
|
|
IR^.Kind := ikFunction;
|
521 |
|
|
IR^.Func1Addr := FunctionAddr;
|
522 |
|
|
eIdentList.Add(IR);
|
523 |
|
|
|
524 |
|
|
DoOnAddIdentifier;
|
525 |
|
|
end;
|
526 |
|
|
|
527 |
|
|
procedure TStExpression.AddFunction2Param(const Name : String;
|
528 |
|
|
FunctionAddr : TStFunction2Param);
|
529 |
|
|
var
|
530 |
|
|
IR : PStIdentRec;
|
531 |
|
|
begin
|
532 |
|
|
if FindIdent(Name) > -1 then
|
533 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
534 |
|
|
|
535 |
|
|
New(IR);
|
536 |
|
|
IR^.Name := LowerCase(Name);
|
537 |
|
|
IR^.PCount := 2;
|
538 |
|
|
IR^.Kind := ikFunction;
|
539 |
|
|
IR^.Func2Addr := FunctionAddr;
|
540 |
|
|
eIdentList.Add(IR);
|
541 |
|
|
|
542 |
|
|
DoOnAddIdentifier;
|
543 |
|
|
end;
|
544 |
|
|
|
545 |
|
|
procedure TStExpression.AddFunction3Param(const Name : String;
|
546 |
|
|
FunctionAddr : TStFunction3Param);
|
547 |
|
|
var
|
548 |
|
|
IR : PStIdentRec;
|
549 |
|
|
begin
|
550 |
|
|
if FindIdent(Name) > -1 then
|
551 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
552 |
|
|
|
553 |
|
|
New(IR);
|
554 |
|
|
IR^.Name := LowerCase(Name);
|
555 |
|
|
IR^.PCount := 3;
|
556 |
|
|
IR^.Kind := ikFunction;
|
557 |
|
|
IR^.Func3Addr := FunctionAddr;
|
558 |
|
|
eIdentList.Add(IR);
|
559 |
|
|
|
560 |
|
|
DoOnAddIdentifier;
|
561 |
|
|
end;
|
562 |
|
|
|
563 |
|
|
procedure TStExpression.AddInternalFunctions;
|
564 |
|
|
begin
|
565 |
|
|
eBusyFlag := True;
|
566 |
|
|
try
|
567 |
|
|
{add function name and parameter count to list}
|
568 |
|
|
AddFunction1Param('abs', _Abs);
|
569 |
|
|
AddFunction1Param('arctan', _ArcTan);
|
570 |
|
|
AddFunction1Param('cos', _Cos);
|
571 |
|
|
AddFunction1Param('exp', _Exp);
|
572 |
|
|
AddFunction1Param('frac', _Frac);
|
573 |
|
|
AddFunction1Param('int', _Int);
|
574 |
|
|
AddFunction1Param('trunc', _Trunc);
|
575 |
|
|
AddFunction1Param('ln', _Ln);
|
576 |
|
|
AddFunction0Param('pi', _Pi);
|
577 |
|
|
AddFunction1Param('round', _Round);
|
578 |
|
|
AddFunction1Param('sin', _Sin);
|
579 |
|
|
AddFunction1Param('sqr', _Sqr);
|
580 |
|
|
AddFunction1Param('sqrt', _Sqrt);
|
581 |
|
|
{$IFDEF UseMathUnit}
|
582 |
|
|
AddFunction1Param('arccos', _ArcCos);
|
583 |
|
|
AddFunction1Param('arcsin', _ArcSin);
|
584 |
|
|
AddFunction2Param('arctan2', _ArcTan2);
|
585 |
|
|
AddFunction1Param('tan', _Tan);
|
586 |
|
|
AddFunction1Param('cotan', _Cotan);
|
587 |
|
|
AddFunction2Param('hypot', _Hypot);
|
588 |
|
|
AddFunction1Param('cosh', _Cosh);
|
589 |
|
|
AddFunction1Param('sinh', _Sinh);
|
590 |
|
|
AddFunction1Param('tanh', _Tanh);
|
591 |
|
|
AddFunction1Param('arccosh', _ArcCosh);
|
592 |
|
|
AddFunction1Param('arcsinh', _ArcSinh);
|
593 |
|
|
AddFunction1Param('arctanh', _ArcTanh);
|
594 |
|
|
AddFunction1Param('lnxp1', _Lnxp1);
|
595 |
|
|
AddFunction1Param('log10', _Log10);
|
596 |
|
|
AddFunction1Param('log2', _Log2);
|
597 |
|
|
AddFunction2Param('logn', _LogN);
|
598 |
|
|
AddFunction1Param('ceil', _Ceil);
|
599 |
|
|
AddFunction1Param('floor', _Floor);
|
600 |
|
|
{$ENDIF}
|
601 |
|
|
finally
|
602 |
|
|
eBusyFlag := False;
|
603 |
|
|
end;
|
604 |
|
|
end;
|
605 |
|
|
|
606 |
|
|
procedure TStExpression.AddMethod0Param(const Name : String;
|
607 |
|
|
MethodAddr : TStMethod0Param);
|
608 |
|
|
var
|
609 |
|
|
IR : PStIdentRec;
|
610 |
|
|
begin
|
611 |
|
|
if FindIdent(Name) > -1 then
|
612 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
613 |
|
|
|
614 |
|
|
New(IR);
|
615 |
|
|
IR^.Name := LowerCase(Name);
|
616 |
|
|
IR^.PCount := 0;
|
617 |
|
|
IR^.Kind := ikMethod;
|
618 |
|
|
IR^.Meth0Addr := MethodAddr;
|
619 |
|
|
eIdentList.Add(IR);
|
620 |
|
|
|
621 |
|
|
DoOnAddIdentifier;
|
622 |
|
|
end;
|
623 |
|
|
|
624 |
|
|
procedure TStExpression.AddMethod1Param(const Name : String;
|
625 |
|
|
MethodAddr : TStMethod1Param);
|
626 |
|
|
var
|
627 |
|
|
IR : PStIdentRec;
|
628 |
|
|
begin
|
629 |
|
|
if FindIdent(Name) > -1 then
|
630 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
631 |
|
|
|
632 |
|
|
New(IR);
|
633 |
|
|
IR^.Name := LowerCase(Name);
|
634 |
|
|
IR^.PCount := 1;
|
635 |
|
|
IR^.Kind := ikMethod;
|
636 |
|
|
IR^.Meth1Addr := MethodAddr;
|
637 |
|
|
eIdentList.Add(IR);
|
638 |
|
|
|
639 |
|
|
DoOnAddIdentifier;
|
640 |
|
|
end;
|
641 |
|
|
|
642 |
|
|
procedure TStExpression.AddMethod2Param(const Name : String;
|
643 |
|
|
MethodAddr : TStMethod2Param);
|
644 |
|
|
var
|
645 |
|
|
IR : PStIdentRec;
|
646 |
|
|
begin
|
647 |
|
|
if FindIdent(Name) > -1 then
|
648 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
649 |
|
|
|
650 |
|
|
New(IR);
|
651 |
|
|
IR^.Name := LowerCase(Name);
|
652 |
|
|
IR^.PCount := 2;
|
653 |
|
|
IR^.Kind := ikMethod;
|
654 |
|
|
IR^.Meth2Addr := MethodAddr;
|
655 |
|
|
eIdentList.Add(IR);
|
656 |
|
|
|
657 |
|
|
DoOnAddIdentifier;
|
658 |
|
|
end;
|
659 |
|
|
|
660 |
|
|
procedure TStExpression.AddMethod3Param(const Name : String;
|
661 |
|
|
MethodAddr : TStMethod3Param);
|
662 |
|
|
var
|
663 |
|
|
IR : PStIdentRec;
|
664 |
|
|
begin
|
665 |
|
|
if FindIdent(Name) > -1 then
|
666 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
667 |
|
|
|
668 |
|
|
New(IR);
|
669 |
|
|
IR^.Name := LowerCase(Name);
|
670 |
|
|
IR^.PCount := 3;
|
671 |
|
|
IR^.Kind := ikMethod;
|
672 |
|
|
IR^.Meth3Addr := MethodAddr;
|
673 |
|
|
eIdentList.Add(IR);
|
674 |
|
|
|
675 |
|
|
DoOnAddIdentifier;
|
676 |
|
|
end;
|
677 |
|
|
|
678 |
|
|
procedure TStExpression.AddVariable(const Name : String; VariableAddr : PStFloat);
|
679 |
|
|
var
|
680 |
|
|
IR : PStIdentRec;
|
681 |
|
|
begin
|
682 |
|
|
if FindIdent(Name) > -1 then
|
683 |
|
|
RaiseExprError(stscExprDupIdent, 0);
|
684 |
|
|
|
685 |
|
|
New(IR);
|
686 |
|
|
IR^.Name := LowerCase(Name);
|
687 |
|
|
IR^.Kind := ikVariable;
|
688 |
|
|
IR^.VarAddr := VariableAddr;
|
689 |
|
|
eIdentList.Add(IR);
|
690 |
|
|
|
691 |
|
|
DoOnAddIdentifier;
|
692 |
|
|
end;
|
693 |
|
|
|
694 |
|
|
function TStExpression.AnalyzeExpression : TStFloat;
|
695 |
|
|
begin
|
696 |
|
|
FLastError := 0;
|
697 |
|
|
|
698 |
|
|
{error if nothing to do}
|
699 |
|
|
if (Length(FExpression) = 0) then
|
700 |
|
|
RaiseExprError(stscExprEmpty, 0);
|
701 |
|
|
|
702 |
|
|
{clear operand stack}
|
703 |
|
|
StackClear;
|
704 |
|
|
|
705 |
|
|
{get the first character from the string}
|
706 |
|
|
eExprPos := 1;
|
707 |
|
|
eCurChar := FExpression[1];
|
708 |
|
|
|
709 |
|
|
{get the first Token and start parsing}
|
710 |
|
|
GetToken;
|
711 |
|
|
GetExpression;
|
712 |
|
|
|
713 |
|
|
{make sure expression is fully evaluated}
|
714 |
|
|
if (eToken <> ssEol) or (StackCount <> 1) then
|
715 |
|
|
RaiseExprError(stscExprBadExp, FErrorPos);
|
716 |
|
|
|
717 |
|
|
Result := StackPop;
|
718 |
|
|
end;
|
719 |
|
|
|
720 |
|
|
procedure TStExpression.ClearIdentifiers;
|
721 |
|
|
var
|
722 |
|
|
I : Integer;
|
723 |
|
|
begin
|
724 |
|
|
for I := 0 to eIdentList.Count-1 do
|
725 |
|
|
Dispose(PStIdentRec(eIdentList[I]));
|
726 |
|
|
eIdentList.Clear;
|
727 |
|
|
end;
|
728 |
|
|
|
729 |
|
|
constructor TStExpression.Create(AOwner : TComponent);
|
730 |
|
|
begin
|
731 |
|
|
inherited Create(AOwner);
|
732 |
|
|
|
733 |
|
|
eStack := TList.Create;
|
734 |
|
|
eIdentList := TList.Create;
|
735 |
|
|
|
736 |
|
|
FAllowEqual := True;
|
737 |
|
|
|
738 |
|
|
AddInternalFunctions;
|
739 |
|
|
end;
|
740 |
|
|
|
741 |
|
|
destructor TStExpression.Destroy;
|
742 |
|
|
begin
|
743 |
|
|
StackClear;
|
744 |
|
|
eStack.Free;
|
745 |
|
|
eStack := nil;
|
746 |
|
|
|
747 |
|
|
ClearIdentifiers;
|
748 |
|
|
eIdentList.Free;
|
749 |
|
|
eIdentList := nil;
|
750 |
|
|
|
751 |
|
|
inherited Destroy;
|
752 |
|
|
end;
|
753 |
|
|
|
754 |
|
|
procedure TStExpression.DoOnAddIdentifier;
|
755 |
|
|
begin
|
756 |
|
|
if eBusyFlag then
|
757 |
|
|
Exit;
|
758 |
|
|
if Assigned(FOnAddIdentifier) then
|
759 |
|
|
FOnAddIdentifier(Self);
|
760 |
|
|
end;
|
761 |
|
|
|
762 |
|
|
function TStExpression.FindIdent(Name : String) : Integer;
|
763 |
|
|
var
|
764 |
|
|
I : Integer;
|
765 |
|
|
begin
|
766 |
|
|
Result := -1;
|
767 |
|
|
for I := 0 to eIdentList.Count-1 do begin
|
768 |
|
|
if Name = PStIdentRec(eIdentList[I])^.Name then begin
|
769 |
|
|
Result := I;
|
770 |
|
|
Break;
|
771 |
|
|
end;
|
772 |
|
|
end;
|
773 |
|
|
end;
|
774 |
|
|
|
775 |
|
|
function TStExpression.GetAsInteger : Integer;
|
776 |
|
|
begin
|
777 |
|
|
Result := Round(AnalyzeExpression);
|
778 |
|
|
end;
|
779 |
|
|
|
780 |
|
|
function TStExpression.GetAsString : String;
|
781 |
|
|
begin
|
782 |
|
|
Result := FloatToStr(AnalyzeExpression);
|
783 |
|
|
end;
|
784 |
|
|
|
785 |
|
|
procedure TpVal(const S : String; var V : Extended; var Code : Integer);
|
786 |
|
|
{
|
787 |
|
|
Evaluate string as a floating point number, emulates Borlandish Pascal's
|
788 |
|
|
Val() intrinsic
|
789 |
|
|
|
790 |
|
|
Recognizes strings of the form:
|
791 |
|
|
[-/+](d*[.][d*]|[d*].d*)[(e|E)[-/+](d*)]
|
792 |
|
|
|
793 |
|
|
Parameters:
|
794 |
|
|
S : string to convert
|
795 |
|
|
V : Resultant Extended value
|
796 |
|
|
Code: position in string where an error occured or
|
797 |
|
|
-- 0 if no error
|
798 |
|
|
-- Length(S) + 1 if otherwise valid string terminates prematurely (e.g. "10.2e-")
|
799 |
|
|
|
800 |
|
|
if Code <> 0 on return then the value of V is undefined
|
801 |
|
|
}
|
802 |
|
|
|
803 |
|
|
type
|
804 |
|
|
{ recognizer machine states }
|
805 |
|
|
TNumConvertState = (ncStart, ncSign, ncWhole, ncDecimal, ncStartDecimal,
|
806 |
|
|
ncFraction, ncE, ncExpSign, ncExponent, ncEndSpaces, ncBadChar);
|
807 |
|
|
const
|
808 |
|
|
{ valid stop states for machine }
|
809 |
|
|
StopStates: set of TNumConvertState = [ncWhole, ncDecimal, ncFraction,
|
810 |
|
|
ncExponent, ncEndSpaces];
|
811 |
|
|
|
812 |
|
|
var
|
813 |
|
|
i : Integer; { general purpose counter }
|
814 |
|
|
P : PChar; { current position in evaluated string }
|
815 |
|
|
NegVal : Boolean; { is entire value negative? }
|
816 |
|
|
NegExp : Boolean; { is exponent negative? }
|
817 |
|
|
Exponent : LongInt; { accumulator for exponent }
|
818 |
|
|
Mantissa : Extended; { mantissa }
|
819 |
|
|
FracMul : Extended; { decimal place holder }
|
820 |
|
|
State : TNumConvertState; { current state of recognizer machine }
|
821 |
|
|
|
822 |
|
|
|
823 |
|
|
begin
|
824 |
|
|
{initializations}
|
825 |
|
|
V := 0.0;
|
826 |
|
|
Code := 0;
|
827 |
|
|
|
828 |
|
|
State := ncStart;
|
829 |
|
|
|
830 |
|
|
NegVal := False;
|
831 |
|
|
NegExp := False;
|
832 |
|
|
|
833 |
|
|
Mantissa := 0.0;
|
834 |
|
|
FracMul := 0.1;
|
835 |
|
|
Exponent := 0;
|
836 |
|
|
|
837 |
|
|
{
|
838 |
|
|
Evaluate the string
|
839 |
|
|
When the loop completes (assuming no error)
|
840 |
|
|
-- WholeVal will contain the absolute value of the mantissa
|
841 |
|
|
-- Exponent will contain the absolute value of the exponent
|
842 |
|
|
-- NegVal will be set True if the mantissa is negative
|
843 |
|
|
-- NegExp will be set True if the exponent is negative
|
844 |
|
|
|
845 |
|
|
If an error occurs P will be pointing at the character that caused the problem,
|
846 |
|
|
or one past the end of the string if it terminates prematurely
|
847 |
|
|
}
|
848 |
|
|
|
849 |
|
|
{ keep going until run out of string or halt if unrecognized or out-of-place
|
850 |
|
|
character detected }
|
851 |
|
|
|
852 |
|
|
P := PChar(S);
|
853 |
|
|
for i := 1 to Length(S) do begin
|
854 |
|
|
case State of
|
855 |
|
|
ncStart : begin
|
856 |
|
|
if P^ = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator then begin
|
857 |
|
|
State := ncStartDecimal; { decimal point detected in mantissa }
|
858 |
|
|
end else
|
859 |
|
|
|
860 |
|
|
case P^ of
|
861 |
|
|
' ': begin
|
862 |
|
|
{ignore}
|
863 |
|
|
end;
|
864 |
|
|
|
865 |
|
|
'+': begin
|
866 |
|
|
State := ncSign;
|
867 |
|
|
end;
|
868 |
|
|
|
869 |
|
|
'-': begin
|
870 |
|
|
NegVal := True;
|
871 |
|
|
State := ncSign;
|
872 |
|
|
end;
|
873 |
|
|
|
874 |
|
|
'e', 'E': begin
|
875 |
|
|
Mantissa := 0;
|
876 |
|
|
State := ncE; { exponent detected }
|
877 |
|
|
end;
|
878 |
|
|
|
879 |
|
|
'0'..'9': begin
|
880 |
|
|
State := ncWhole; { start of whole portion of mantissa }
|
881 |
|
|
Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
|
882 |
|
|
end;
|
883 |
|
|
|
884 |
|
|
else
|
885 |
|
|
State := ncBadChar;
|
886 |
|
|
end;
|
887 |
|
|
|
888 |
|
|
end;
|
889 |
|
|
|
890 |
|
|
ncSign : begin
|
891 |
|
|
if P^ = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator then begin
|
892 |
|
|
State := ncDecimal; { decimal point detected in mantissa }
|
893 |
|
|
end else
|
894 |
|
|
|
895 |
|
|
case P^ of
|
896 |
|
|
'0'..'9': begin
|
897 |
|
|
State := ncWhole; { start of whole portion of mantissa }
|
898 |
|
|
Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
|
899 |
|
|
end;
|
900 |
|
|
|
901 |
|
|
'e', 'E': begin
|
902 |
|
|
Mantissa := 0;
|
903 |
|
|
State := ncE; { exponent detected }
|
904 |
|
|
end;
|
905 |
|
|
|
906 |
|
|
else
|
907 |
|
|
State := ncBadChar;
|
908 |
|
|
end;
|
909 |
|
|
end;
|
910 |
|
|
|
911 |
|
|
ncWhole : begin
|
912 |
|
|
if P^ = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator then begin
|
913 |
|
|
State := ncDecimal; { decimal point detected in mantissa }
|
914 |
|
|
end else
|
915 |
|
|
|
916 |
|
|
case P^ of
|
917 |
|
|
'0'..'9': begin
|
918 |
|
|
Mantissa := (Mantissa * 10) + (Ord(P^) - Ord('0'));
|
919 |
|
|
end;
|
920 |
|
|
|
921 |
|
|
'.': begin
|
922 |
|
|
end;
|
923 |
|
|
|
924 |
|
|
'e', 'E': begin
|
925 |
|
|
State := ncE; { exponent detected }
|
926 |
|
|
end;
|
927 |
|
|
|
928 |
|
|
' ': begin
|
929 |
|
|
State := ncEndSpaces;
|
930 |
|
|
end;
|
931 |
|
|
|
932 |
|
|
else
|
933 |
|
|
State := ncBadChar;
|
934 |
|
|
end;
|
935 |
|
|
end;
|
936 |
|
|
|
937 |
|
|
ncDecimal : begin
|
938 |
|
|
case P^ of
|
939 |
|
|
'0'..'9': begin
|
940 |
|
|
State := ncFraction; { start of fractional portion of mantissa }
|
941 |
|
|
Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
|
942 |
|
|
FracMul := FracMul * 0.1;
|
943 |
|
|
end;
|
944 |
|
|
|
945 |
|
|
'e', 'E': begin
|
946 |
|
|
State := ncE; { exponent detected }
|
947 |
|
|
end;
|
948 |
|
|
|
949 |
|
|
' ': begin
|
950 |
|
|
State := ncEndSpaces;
|
951 |
|
|
end;
|
952 |
|
|
|
953 |
|
|
else
|
954 |
|
|
State := ncBadChar;
|
955 |
|
|
end;
|
956 |
|
|
|
957 |
|
|
end;
|
958 |
|
|
|
959 |
|
|
ncStartDecimal : begin
|
960 |
|
|
case P^ of
|
961 |
|
|
'0'..'9': begin
|
962 |
|
|
State := ncFraction; { start of fractional portion of mantissa }
|
963 |
|
|
Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
|
964 |
|
|
FracMul := FracMul * 0.1;
|
965 |
|
|
end;
|
966 |
|
|
|
967 |
|
|
' ': begin
|
968 |
|
|
State := ncEndSpaces;
|
969 |
|
|
end;
|
970 |
|
|
|
971 |
|
|
else
|
972 |
|
|
State := ncBadChar;
|
973 |
|
|
end;
|
974 |
|
|
end;
|
975 |
|
|
|
976 |
|
|
ncFraction : begin
|
977 |
|
|
case P^ of
|
978 |
|
|
'0'..'9': begin
|
979 |
|
|
Mantissa := Mantissa + (FracMul * (Ord(P^) - Ord('0')));
|
980 |
|
|
FracMul := FracMul * 0.1;
|
981 |
|
|
end;
|
982 |
|
|
|
983 |
|
|
'e', 'E': begin
|
984 |
|
|
State := ncE; { exponent detected }
|
985 |
|
|
end;
|
986 |
|
|
|
987 |
|
|
' ': begin
|
988 |
|
|
State := ncEndSpaces;
|
989 |
|
|
end;
|
990 |
|
|
|
991 |
|
|
else
|
992 |
|
|
State := ncBadChar;
|
993 |
|
|
end;
|
994 |
|
|
end;
|
995 |
|
|
|
996 |
|
|
ncE : begin
|
997 |
|
|
case P^ of
|
998 |
|
|
'0'..'9': begin
|
999 |
|
|
State := ncExponent; { start of exponent }
|
1000 |
|
|
Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
|
1001 |
|
|
end;
|
1002 |
|
|
|
1003 |
|
|
'+': begin
|
1004 |
|
|
State := ncExpSign;
|
1005 |
|
|
end;
|
1006 |
|
|
|
1007 |
|
|
'-': begin
|
1008 |
|
|
NegExp := True; { exponent is negative }
|
1009 |
|
|
State := ncExpSign;
|
1010 |
|
|
end;
|
1011 |
|
|
|
1012 |
|
|
else
|
1013 |
|
|
State := ncBadChar;
|
1014 |
|
|
end;
|
1015 |
|
|
end;
|
1016 |
|
|
|
1017 |
|
|
ncExpSign : begin
|
1018 |
|
|
case P^ of
|
1019 |
|
|
'0'..'9': begin
|
1020 |
|
|
State := ncExponent; { start of exponent }
|
1021 |
|
|
Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
|
1022 |
|
|
end;
|
1023 |
|
|
|
1024 |
|
|
else
|
1025 |
|
|
State := ncBadChar;
|
1026 |
|
|
end;
|
1027 |
|
|
end;
|
1028 |
|
|
|
1029 |
|
|
ncExponent : begin
|
1030 |
|
|
case P^ of
|
1031 |
|
|
'0'..'9': begin
|
1032 |
|
|
Exponent := Exponent * 10 + (Ord(P^) - Ord('0'));
|
1033 |
|
|
end;
|
1034 |
|
|
|
1035 |
|
|
' ': begin
|
1036 |
|
|
State := ncEndSpaces;
|
1037 |
|
|
end;
|
1038 |
|
|
|
1039 |
|
|
else
|
1040 |
|
|
State := ncBadChar;
|
1041 |
|
|
end;
|
1042 |
|
|
end;
|
1043 |
|
|
|
1044 |
|
|
ncEndSpaces : begin
|
1045 |
|
|
case P^ of
|
1046 |
|
|
' ': begin
|
1047 |
|
|
{ignore}
|
1048 |
|
|
end;
|
1049 |
|
|
else
|
1050 |
|
|
State := ncBadChar;
|
1051 |
|
|
end;
|
1052 |
|
|
end;
|
1053 |
|
|
end;
|
1054 |
|
|
|
1055 |
|
|
Inc(P);
|
1056 |
|
|
if State = ncBadChar then begin
|
1057 |
|
|
Code := i;
|
1058 |
|
|
Break;
|
1059 |
|
|
end;
|
1060 |
|
|
end;
|
1061 |
|
|
{
|
1062 |
|
|
Final calculations
|
1063 |
|
|
}
|
1064 |
|
|
if not (State in StopStates) then begin
|
1065 |
|
|
Code := i; { point to error }
|
1066 |
|
|
end else begin
|
1067 |
|
|
{ negate if needed }
|
1068 |
|
|
if NegVal then
|
1069 |
|
|
Mantissa := -Mantissa;
|
1070 |
|
|
|
1071 |
|
|
|
1072 |
|
|
{ apply exponent if any }
|
1073 |
|
|
if Exponent <> 0 then begin
|
1074 |
|
|
if NegExp then
|
1075 |
|
|
for i := 1 to Exponent do
|
1076 |
|
|
Mantissa := Mantissa * 0.1
|
1077 |
|
|
else
|
1078 |
|
|
for i := 1 to Exponent do
|
1079 |
|
|
Mantissa := Mantissa * 10.0;
|
1080 |
|
|
end;
|
1081 |
|
|
|
1082 |
|
|
V := Mantissa;
|
1083 |
|
|
end;
|
1084 |
|
|
end;
|
1085 |
|
|
|
1086 |
|
|
|
1087 |
|
|
procedure TStExpression.GetBase;
|
1088 |
|
|
var
|
1089 |
|
|
SaveSign : TStToken;
|
1090 |
|
|
Code : Integer;
|
1091 |
|
|
NumVal : TStFloat;
|
1092 |
|
|
begin
|
1093 |
|
|
case eToken of
|
1094 |
|
|
ssNum :
|
1095 |
|
|
begin
|
1096 |
|
|
{evaluate real number string}
|
1097 |
|
|
if (eTokenStr[1] = {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator{'.'}) then
|
1098 |
|
|
eTokenStr := '0' + eTokenStr;
|
1099 |
|
|
{Val(eTokenStr, NumVal, Code);}
|
1100 |
|
|
TpVal(eTokenStr, NumVal, Code);
|
1101 |
|
|
if Code <> 0 then
|
1102 |
|
|
RaiseExprError(stscExprBadNum, FErrorPos);
|
1103 |
|
|
{put on operand stack}
|
1104 |
|
|
StackPush(NumVal);
|
1105 |
|
|
GetToken;
|
1106 |
|
|
end;
|
1107 |
|
|
ssIdent :
|
1108 |
|
|
{function call}
|
1109 |
|
|
GetFunction;
|
1110 |
|
|
ssLPar :
|
1111 |
|
|
begin
|
1112 |
|
|
{nested expression}
|
1113 |
|
|
GetToken;
|
1114 |
|
|
GetExpression;
|
1115 |
|
|
if (eToken <> ssRPar) then
|
1116 |
|
|
RaiseExprError(stscExprBadExp, FErrorPos);
|
1117 |
|
|
GetToken;
|
1118 |
|
|
end;
|
1119 |
|
|
ssPlus, ssMinus :
|
1120 |
|
|
begin
|
1121 |
|
|
{unary sign}
|
1122 |
|
|
SaveSign := eToken;
|
1123 |
|
|
GetToken;
|
1124 |
|
|
GetFactor;
|
1125 |
|
|
if (SaveSign = ssMinus) then
|
1126 |
|
|
{update operand stack}
|
1127 |
|
|
StackPush(-PopOperand);
|
1128 |
|
|
end;
|
1129 |
|
|
else
|
1130 |
|
|
RaiseExprError(stscExprOpndExp, FErrorPos);
|
1131 |
|
|
end;
|
1132 |
|
|
end;
|
1133 |
|
|
|
1134 |
|
|
procedure TStExpression.GetExpression;
|
1135 |
|
|
var
|
1136 |
|
|
SaveOp : TStToken;
|
1137 |
|
|
begin
|
1138 |
|
|
GetTerm;
|
1139 |
|
|
while (True) do begin
|
1140 |
|
|
case eToken of
|
1141 |
|
|
ssPlus, ssMinus :
|
1142 |
|
|
begin
|
1143 |
|
|
SaveOp := eToken;
|
1144 |
|
|
GetToken;
|
1145 |
|
|
GetTerm;
|
1146 |
|
|
rhs := PopOperand;
|
1147 |
|
|
lhs := PopOperand;
|
1148 |
|
|
try
|
1149 |
|
|
case SaveOp of
|
1150 |
|
|
ssPlus : StackPush(lhs+rhs);
|
1151 |
|
|
ssMinus : StackPush(lhs-rhs);
|
1152 |
|
|
end;
|
1153 |
|
|
except
|
1154 |
|
|
{note operand stack overflow not possible here}
|
1155 |
|
|
RaiseExprError(stscExprNumeric, FErrorPos);
|
1156 |
|
|
end;
|
1157 |
|
|
end;
|
1158 |
|
|
else
|
1159 |
|
|
Break;
|
1160 |
|
|
end;
|
1161 |
|
|
end;
|
1162 |
|
|
end;
|
1163 |
|
|
|
1164 |
|
|
procedure TStExpression.GetFactor;
|
1165 |
|
|
begin
|
1166 |
|
|
GetBase;
|
1167 |
|
|
if (eToken = ssPower) then begin
|
1168 |
|
|
GetToken;
|
1169 |
|
|
GetFactor;
|
1170 |
|
|
rhs := PopOperand;
|
1171 |
|
|
lhs := PopOperand;
|
1172 |
|
|
try
|
1173 |
|
|
StackPush(Power(lhs, rhs));
|
1174 |
|
|
except
|
1175 |
|
|
{note operand stack overflow not possible here}
|
1176 |
|
|
RaiseExprError(stscExprNumeric, FErrorPos);
|
1177 |
|
|
end;
|
1178 |
|
|
end;
|
1179 |
|
|
end;
|
1180 |
|
|
|
1181 |
|
|
procedure TStExpression.GetFunction;
|
1182 |
|
|
var
|
1183 |
|
|
I : Integer;
|
1184 |
|
|
P1, P2, P3 : TStFloat;
|
1185 |
|
|
Ident : PStIdentRec;
|
1186 |
|
|
St : String;
|
1187 |
|
|
begin
|
1188 |
|
|
St := eTokenStr;
|
1189 |
|
|
GetToken;
|
1190 |
|
|
|
1191 |
|
|
{is this a request to add a constant? (=)}
|
1192 |
|
|
if FAllowEqual and (eTokenStr = '=') then begin
|
1193 |
|
|
GetToken;
|
1194 |
|
|
GetExpression;
|
1195 |
|
|
{leave result on the stack to be returned as the expression result}
|
1196 |
|
|
AddConstant(St, StackPeek);
|
1197 |
|
|
Exit;
|
1198 |
|
|
end;
|
1199 |
|
|
|
1200 |
|
|
I := FindIdent(St);
|
1201 |
|
|
if I > -1 then begin
|
1202 |
|
|
Ident := eIdentList[I];
|
1203 |
|
|
case Ident^.Kind of
|
1204 |
|
|
ikConstant : StackPush(Ident^.Value);
|
1205 |
|
|
ikVariable : StackPush(PStFloat(Ident^.VarAddr)^);
|
1206 |
|
|
ikFunction :
|
1207 |
|
|
begin
|
1208 |
|
|
{place parameters on stack, if any}
|
1209 |
|
|
GetParams(Ident^.PCount);
|
1210 |
|
|
try
|
1211 |
|
|
case Ident^.PCount of
|
1212 |
|
|
0 : StackPush(TStFunction0Param(Ident^.Func0Addr));
|
1213 |
|
|
1 : begin
|
1214 |
|
|
P1 := PopOperand;
|
1215 |
|
|
StackPush(TStFunction1Param(Ident^.Func1Addr)(P1));
|
1216 |
|
|
end;
|
1217 |
|
|
2 : begin
|
1218 |
|
|
P2 := PopOperand;
|
1219 |
|
|
P1 := PopOperand;
|
1220 |
|
|
StackPush(TStFunction2Param(Ident^.Func2Addr)(P1, P2));
|
1221 |
|
|
end;
|
1222 |
|
|
3 : begin
|
1223 |
|
|
P3 := PopOperand;
|
1224 |
|
|
P2 := PopOperand;
|
1225 |
|
|
P1 := PopOperand;
|
1226 |
|
|
StackPush(TStFunction3Param(Ident^.Func3Addr)(P1, P2, P3));
|
1227 |
|
|
end;
|
1228 |
|
|
else
|
1229 |
|
|
RaiseExprError(stscExprNumeric, FErrorPos);
|
1230 |
|
|
end;
|
1231 |
|
|
except
|
1232 |
|
|
{note operand stack overflow or underflow not possible here}
|
1233 |
|
|
{translate RTL numeric errors into STEXPR error}
|
1234 |
|
|
RaiseExprError(stscExprNumeric, FErrorPos);
|
1235 |
|
|
end;
|
1236 |
|
|
end;
|
1237 |
|
|
ikMethod :
|
1238 |
|
|
begin
|
1239 |
|
|
{place parameters on stack, if any}
|
1240 |
|
|
GetParams(Ident^.PCount);
|
1241 |
|
|
try
|
1242 |
|
|
case Ident^.PCount of
|
1243 |
|
|
0 : StackPush(TStMethod0Param(Ident^.Meth0Addr));
|
1244 |
|
|
1 : begin
|
1245 |
|
|
P1 := PopOperand;
|
1246 |
|
|
StackPush(TStMethod1Param(Ident^.Meth1Addr)(P1));
|
1247 |
|
|
end;
|
1248 |
|
|
2 : begin
|
1249 |
|
|
P2 := PopOperand;
|
1250 |
|
|
P1 := PopOperand;
|
1251 |
|
|
StackPush(TStMethod2Param(Ident^.Meth2Addr)(P1, P2));
|
1252 |
|
|
end;
|
1253 |
|
|
3 : begin
|
1254 |
|
|
P3 := PopOperand;
|
1255 |
|
|
P2 := PopOperand;
|
1256 |
|
|
P1 := PopOperand;
|
1257 |
|
|
StackPush(TStMethod3Param(Ident^.Meth3Addr)(P1, P2, P3));
|
1258 |
|
|
end;
|
1259 |
|
|
else
|
1260 |
|
|
RaiseExprError(stscExprNumeric, FErrorPos);
|
1261 |
|
|
end;
|
1262 |
|
|
except
|
1263 |
|
|
{note operand stack overflow or underflow not possible here}
|
1264 |
|
|
{translate RTL numeric errors into STEXPR error}
|
1265 |
|
|
RaiseExprError(stscExprNumeric, FErrorPos);
|
1266 |
|
|
end;
|
1267 |
|
|
end;
|
1268 |
|
|
end;
|
1269 |
|
|
end else begin
|
1270 |
|
|
|
1271 |
|
|
if Assigned(FOnGetIdentValue) then begin
|
1272 |
|
|
P1 := 0;
|
1273 |
|
|
FOnGetIdentValue(Self, St, P1);
|
1274 |
|
|
StackPush(P1);
|
1275 |
|
|
end else
|
1276 |
|
|
RaiseExprError(stscExprUnkFunc, FErrorPos);
|
1277 |
|
|
end;
|
1278 |
|
|
end;
|
1279 |
|
|
|
1280 |
|
|
procedure TStExpression.GetIdentList(S : TStrings);
|
1281 |
|
|
var
|
1282 |
|
|
I : Integer;
|
1283 |
|
|
begin
|
1284 |
|
|
if Assigned(S) then begin
|
1285 |
|
|
S.Clear;
|
1286 |
|
|
for I := 0 to eIdentList.Count-1 do
|
1287 |
|
|
S.Add(PStIdentRec(eIdentList[I])^.Name);
|
1288 |
|
|
end;
|
1289 |
|
|
end;
|
1290 |
|
|
|
1291 |
|
|
procedure TStExpression.GetParams(N : Integer);
|
1292 |
|
|
begin
|
1293 |
|
|
if (N > 0) then begin
|
1294 |
|
|
if (eToken <> ssLPar) then
|
1295 |
|
|
RaiseExprError(stscExprLParExp, FErrorPos);
|
1296 |
|
|
while (N > 0) do begin
|
1297 |
|
|
GetToken;
|
1298 |
|
|
{evaluate parameter value and leave on stack}
|
1299 |
|
|
GetExpression;
|
1300 |
|
|
Dec(N);
|
1301 |
|
|
if (N > 0) then
|
1302 |
|
|
if (eToken <> ssComma) then
|
1303 |
|
|
RaiseExprError(stscExprCommExp, FErrorPos);
|
1304 |
|
|
end;
|
1305 |
|
|
if (eToken <> ssRPar) then
|
1306 |
|
|
RaiseExprError(stscExprRParExp, FErrorPos);
|
1307 |
|
|
GetToken;
|
1308 |
|
|
end;
|
1309 |
|
|
end;
|
1310 |
|
|
|
1311 |
|
|
procedure TStExpression.GetTerm;
|
1312 |
|
|
var
|
1313 |
|
|
SaveOp : TStToken;
|
1314 |
|
|
begin
|
1315 |
|
|
GetFactor;
|
1316 |
|
|
while (True) do begin
|
1317 |
|
|
case eToken of
|
1318 |
|
|
ssTimes, ssDiv :
|
1319 |
|
|
begin
|
1320 |
|
|
SaveOp := eToken;
|
1321 |
|
|
GetToken;
|
1322 |
|
|
GetFactor;
|
1323 |
|
|
rhs := PopOperand;
|
1324 |
|
|
lhs := PopOperand;
|
1325 |
|
|
try
|
1326 |
|
|
case SaveOp of
|
1327 |
|
|
ssTimes :
|
1328 |
|
|
StackPush(lhs*rhs);
|
1329 |
|
|
ssDiv :
|
1330 |
|
|
StackPush(lhs/rhs);
|
1331 |
|
|
end;
|
1332 |
|
|
except
|
1333 |
|
|
{note operand stack overflow not possible here}
|
1334 |
|
|
RaiseExprError(stscExprNumeric, FErrorPos);
|
1335 |
|
|
end;
|
1336 |
|
|
end;
|
1337 |
|
|
else
|
1338 |
|
|
break;
|
1339 |
|
|
end;
|
1340 |
|
|
end;
|
1341 |
|
|
end;
|
1342 |
|
|
|
1343 |
|
|
procedure TStExpression.GetToken;
|
1344 |
|
|
var
|
1345 |
|
|
Done : Boolean;
|
1346 |
|
|
TT : TStToken;
|
1347 |
|
|
begin
|
1348 |
|
|
eToken := ssStart;
|
1349 |
|
|
eTokenStr := '';
|
1350 |
|
|
Done := False;
|
1351 |
|
|
|
1352 |
|
|
while (not Done) do begin
|
1353 |
|
|
case eToken of
|
1354 |
|
|
ssStart :
|
1355 |
|
|
begin
|
1356 |
|
|
{save potential error column at start of eTokenStr}
|
1357 |
|
|
FErrorPos := eExprPos;
|
1358 |
|
|
if (eCurChar = ' ') or (eCurChar = ^I) then
|
1359 |
|
|
{skip leading whitespace}
|
1360 |
|
|
else if (eCurChar = #0) then begin
|
1361 |
|
|
{end of string}
|
1362 |
|
|
eToken := ssEol;
|
1363 |
|
|
Done := true;
|
1364 |
|
|
end else if (eCurChar in Alpha) then begin
|
1365 |
|
|
{start of identifier}
|
1366 |
|
|
eTokenStr := eTokenStr + LowerCase(eCurChar);
|
1367 |
|
|
eToken := ssInIdent;
|
1368 |
|
|
end else if (eCurChar in Numeric) then begin
|
1369 |
|
|
{start of value}
|
1370 |
|
|
eTokenStr := eTokenStr + eCurChar;
|
1371 |
|
|
eToken := ssInNum;
|
1372 |
|
|
end else begin
|
1373 |
|
|
{presumably a single character operator}
|
1374 |
|
|
eTokenStr := eTokenStr + eCurChar;
|
1375 |
|
|
{make sure it matches a known operator}
|
1376 |
|
|
for TT := ssLPar to ssPower do
|
1377 |
|
|
if (eCurChar = StExprOperators[TT]) then begin
|
1378 |
|
|
Done := True;
|
1379 |
|
|
eToken := TT;
|
1380 |
|
|
Break;
|
1381 |
|
|
end;
|
1382 |
|
|
if (not Done) then begin
|
1383 |
|
|
{error: unknown character}
|
1384 |
|
|
RaiseExprError(stscExprBadChar, FErrorPos);
|
1385 |
|
|
end;
|
1386 |
|
|
{move to next character}
|
1387 |
|
|
Inc(eExprPos);
|
1388 |
|
|
if (eExprPos > Length(FExpression)) then
|
1389 |
|
|
eCurChar := #0
|
1390 |
|
|
else
|
1391 |
|
|
eCurChar := FExpression[eExprPos];
|
1392 |
|
|
end;
|
1393 |
|
|
end;
|
1394 |
|
|
ssInIdent :
|
1395 |
|
|
if (eCurChar in AlphaNumeric) then
|
1396 |
|
|
{continuing in identifier}
|
1397 |
|
|
eTokenStr := eTokenStr + LowerCase(eCurChar)
|
1398 |
|
|
else begin
|
1399 |
|
|
{end of identifier}
|
1400 |
|
|
eToken := ssIdent;
|
1401 |
|
|
Done := True;
|
1402 |
|
|
end;
|
1403 |
|
|
ssInNum :
|
1404 |
|
|
if (eCurChar in Numeric) then
|
1405 |
|
|
{continuing in number}
|
1406 |
|
|
eTokenStr := eTokenStr + eCurChar
|
1407 |
|
|
else if (LowerCase(eCurChar) = 'e') then begin
|
1408 |
|
|
{start of exponent}
|
1409 |
|
|
eTokenStr := eTokenStr + LowerCase(eCurChar);
|
1410 |
|
|
eToken := ssInSign;
|
1411 |
|
|
end else begin
|
1412 |
|
|
{end of number}
|
1413 |
|
|
eToken := ssNum;
|
1414 |
|
|
Done := True;
|
1415 |
|
|
end;
|
1416 |
|
|
ssInSign :
|
1417 |
|
|
if (eCurChar in ['-', '+']) or (eCurChar in Numeric) then begin
|
1418 |
|
|
{have exponent sign or start of number}
|
1419 |
|
|
eTokenStr := eTokenStr + eCurChar;
|
1420 |
|
|
eToken := ssInExp;
|
1421 |
|
|
end else begin
|
1422 |
|
|
{error: started exponent but didn't finish}
|
1423 |
|
|
RaiseExprError(stscExprBadNum, FErrorPos);
|
1424 |
|
|
end;
|
1425 |
|
|
ssInExp :
|
1426 |
|
|
if (eCurChar in Numeric) then
|
1427 |
|
|
{continuing in number}
|
1428 |
|
|
eTokenStr := eTokenStr + eCurChar
|
1429 |
|
|
else begin
|
1430 |
|
|
{end of number}
|
1431 |
|
|
eToken := ssNum;
|
1432 |
|
|
Done := True;
|
1433 |
|
|
end;
|
1434 |
|
|
end;
|
1435 |
|
|
|
1436 |
|
|
{get next character}
|
1437 |
|
|
if (not Done) then begin
|
1438 |
|
|
Inc(eExprPos);
|
1439 |
|
|
if (eExprPos > Length(FExpression)) then
|
1440 |
|
|
eCurChar := #0
|
1441 |
|
|
else
|
1442 |
|
|
eCurChar := FExpression[eExprPos];
|
1443 |
|
|
end;
|
1444 |
|
|
|
1445 |
|
|
end;
|
1446 |
|
|
end;
|
1447 |
|
|
|
1448 |
|
|
function TStExpression.PopOperand : TStFloat;
|
1449 |
|
|
begin
|
1450 |
|
|
if StackEmpty then
|
1451 |
|
|
RaiseExprError(stscExprBadExp, FErrorPos);
|
1452 |
|
|
Result := StackPop;
|
1453 |
|
|
end;
|
1454 |
|
|
|
1455 |
|
|
procedure TStExpression.RaiseExprError(Code : LongInt; Column : Integer);
|
1456 |
|
|
var
|
1457 |
|
|
E : EStExprError;
|
1458 |
|
|
begin
|
1459 |
|
|
{clear operand stack}
|
1460 |
|
|
StackClear;
|
1461 |
|
|
FLastError := Code;
|
1462 |
|
|
E := EStExprError.CreateResTPCol(Code, Column, 0);
|
1463 |
|
|
E.ErrorCode := Code;
|
1464 |
|
|
raise E;
|
1465 |
|
|
end;
|
1466 |
|
|
|
1467 |
|
|
procedure TStExpression.RemoveIdentifier(const Name : String);
|
1468 |
|
|
var
|
1469 |
|
|
I : Integer;
|
1470 |
|
|
S : String;
|
1471 |
|
|
begin
|
1472 |
|
|
S := LowerCase(Name);
|
1473 |
|
|
I := FindIdent(S);
|
1474 |
|
|
if I > -1 then begin
|
1475 |
|
|
Dispose(PStIdentRec(eIdentList[I]));
|
1476 |
|
|
eIdentList.Delete(I);
|
1477 |
|
|
end;
|
1478 |
|
|
end;
|
1479 |
|
|
|
1480 |
|
|
procedure TStExpression.StackClear;
|
1481 |
|
|
var
|
1482 |
|
|
I : Integer;
|
1483 |
|
|
begin
|
1484 |
|
|
for I := 0 to eStack.Count-1 do
|
1485 |
|
|
Dispose(PStFloat(eStack[I]));
|
1486 |
|
|
eStack.Clear;
|
1487 |
|
|
end;
|
1488 |
|
|
|
1489 |
|
|
function TStExpression.StackCount : Integer;
|
1490 |
|
|
begin
|
1491 |
|
|
Result := eStack.Count;
|
1492 |
|
|
end;
|
1493 |
|
|
|
1494 |
|
|
function TStExpression.StackEmpty : Boolean;
|
1495 |
|
|
begin
|
1496 |
|
|
Result := eStack.Count = 0;
|
1497 |
|
|
end;
|
1498 |
|
|
|
1499 |
|
|
function TStExpression.StackPeek : TStFloat;
|
1500 |
|
|
begin
|
1501 |
|
|
Result := PStFloat(eStack[eStack.Count-1])^;
|
1502 |
|
|
end;
|
1503 |
|
|
|
1504 |
|
|
function TStExpression.StackPop : TStFloat;
|
1505 |
|
|
var
|
1506 |
|
|
PF : PStFloat;
|
1507 |
|
|
begin
|
1508 |
|
|
PF := PStFloat(eStack[eStack.Count-1]);
|
1509 |
|
|
Result := PF^;
|
1510 |
|
|
Dispose(PF);
|
1511 |
|
|
eStack.Delete(eStack.Count-1);
|
1512 |
|
|
end;
|
1513 |
|
|
|
1514 |
|
|
procedure TStExpression.StackPush(const Value : TStFloat);
|
1515 |
|
|
var
|
1516 |
|
|
PF : PStFloat;
|
1517 |
|
|
begin
|
1518 |
|
|
New(PF);
|
1519 |
|
|
PF^ := Value;
|
1520 |
|
|
try
|
1521 |
|
|
eStack.Add(PF);
|
1522 |
|
|
except
|
1523 |
|
|
Dispose(PF);
|
1524 |
|
|
raise;
|
1525 |
|
|
end;
|
1526 |
|
|
end;
|
1527 |
|
|
|
1528 |
|
|
|
1529 |
|
|
{*** TStExpressionEdit ***}
|
1530 |
|
|
|
1531 |
|
|
procedure TStExpressionEdit.CMExit(var Msg : TMessage);
|
1532 |
|
|
begin
|
1533 |
|
|
inherited;
|
1534 |
|
|
|
1535 |
|
|
if FAutoEval then begin
|
1536 |
|
|
try
|
1537 |
|
|
DoEvaluate;
|
1538 |
|
|
except
|
1539 |
|
|
SetFocus;
|
1540 |
|
|
raise;
|
1541 |
|
|
end;
|
1542 |
|
|
end;
|
1543 |
|
|
end;
|
1544 |
|
|
|
1545 |
|
|
constructor TStExpressionEdit.Create(AOwner : TComponent);
|
1546 |
|
|
begin
|
1547 |
|
|
inherited Create(AOwner);
|
1548 |
|
|
|
1549 |
|
|
FExpr := TStExpression.Create(Self);
|
1550 |
|
|
FAutoEval := False;
|
1551 |
|
|
end;
|
1552 |
|
|
|
1553 |
|
|
destructor TStExpressionEdit.Destroy;
|
1554 |
|
|
begin
|
1555 |
|
|
FExpr.Free;
|
1556 |
|
|
|
1557 |
|
|
inherited Destroy;
|
1558 |
|
|
end;
|
1559 |
|
|
|
1560 |
|
|
procedure TStExpressionEdit.DoEvaluate;
|
1561 |
|
|
var
|
1562 |
|
|
V : TStFloat;
|
1563 |
|
|
begin
|
1564 |
|
|
if Text > '' then begin
|
1565 |
|
|
V := Evaluate;
|
1566 |
|
|
if FExpr.FLastError = 0 then
|
1567 |
|
|
Text := FloatToStr(V)
|
1568 |
|
|
else
|
1569 |
|
|
SelStart := FExpr.FErrorPos;
|
1570 |
|
|
end else
|
1571 |
|
|
Text := '0';
|
1572 |
|
|
end;
|
1573 |
|
|
|
1574 |
|
|
function TStExpressionEdit.Evaluate : TStFloat;
|
1575 |
|
|
begin
|
1576 |
|
|
Result := 0;
|
1577 |
|
|
FExpr.Expression := Text;
|
1578 |
|
|
try
|
1579 |
|
|
Result := FExpr.AnalyzeExpression;
|
1580 |
|
|
except
|
1581 |
|
|
on E : EStExprError do begin
|
1582 |
|
|
SelStart := FExpr.FErrorPos;
|
1583 |
|
|
if Assigned(FOnError) then
|
1584 |
|
|
FOnError(Self, E.ErrorCode, E.Message)
|
1585 |
|
|
else
|
1586 |
|
|
raise;
|
1587 |
|
|
end else
|
1588 |
|
|
raise;
|
1589 |
|
|
end;
|
1590 |
|
|
end;
|
1591 |
|
|
|
1592 |
|
|
function TStExpressionEdit.GetOnAddIdentifier : TNotifyEvent;
|
1593 |
|
|
begin
|
1594 |
|
|
Result := FExpr.OnAddIdentifier;
|
1595 |
|
|
end;
|
1596 |
|
|
|
1597 |
|
|
function TStExpressionEdit.GetOnGetIdentValue : TStGetIdentValueEvent;
|
1598 |
|
|
begin
|
1599 |
|
|
Result := FExpr.OnGetIdentValue;
|
1600 |
|
|
end;
|
1601 |
|
|
|
1602 |
|
|
procedure TStExpressionEdit.KeyPress(var Key : Char);
|
1603 |
|
|
begin
|
1604 |
|
|
if Key = #13 then begin
|
1605 |
|
|
DoEvaluate;
|
1606 |
|
|
Key := #0;
|
1607 |
|
|
SelStart := Length(Text);
|
1608 |
|
|
end;
|
1609 |
|
|
|
1610 |
|
|
inherited KeyPress(Key);
|
1611 |
|
|
end;
|
1612 |
|
|
|
1613 |
|
|
procedure TStExpressionEdit.SetOnAddIdentifier(Value : TNotifyEvent);
|
1614 |
|
|
begin
|
1615 |
|
|
FExpr.OnAddIdentifier := Value;
|
1616 |
|
|
end;
|
1617 |
|
|
|
1618 |
|
|
procedure TStExpressionEdit.SetOnGetIdentValue(Value : TStGetIdentValueEvent);
|
1619 |
|
|
begin
|
1620 |
|
|
FExpr.OngetIdentValue := Value;
|
1621 |
|
|
end;
|
1622 |
|
|
|
1623 |
|
|
{$IFNDEF VERSION4}
|
1624 |
|
|
procedure GetListSep;
|
1625 |
|
|
var
|
1626 |
|
|
SepBuf : array[0..1] of Char;
|
1627 |
|
|
begin
|
1628 |
|
|
if GetLocaleInfo(GetThreadLocale, LOCALE_SLIST, SepBuf, Length(SepBuf)) > 0 then
|
1629 |
|
|
ListSeparator := SepBuf[0]
|
1630 |
|
|
else
|
1631 |
|
|
ListSeparator := ',';
|
1632 |
|
|
end;
|
1633 |
|
|
{$ENDIF VERSION4}
|
1634 |
|
|
|
1635 |
|
|
initialization
|
1636 |
|
|
{$IFNDEF VERSION4}
|
1637 |
|
|
GetListSep;
|
1638 |
|
|
{$ENDIF VERSION4}
|
1639 |
|
|
Numeric := ['0'..'9', {'.'}{$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}DecimalSeparator];
|
1640 |
|
|
StExprOperators[ssComma] := {$IFDEF DELPHIXE2}FormatSettings.{$ENDIF}ListSeparator;
|
1641 |
|
|
end.
|
1642 |
|
|
|