ViewVC Help
View File | Revision Log | Show Annotations | Root Listing
root/JDesigner/texpr.pas
Revision: 1.1.1.1 (vendor branch)
Committed: Mon Dec 10 19:29:11 2001 UTC (14 years, 6 months ago) by hsauro
Branch: MAIN, hsauro
CVS Tags: V10, HEAD_NEW, HEAD
Changes since 1.1: +0 -0 lines
Log Message:
no message

Line File contents
1 { ******************************************************** }
2 { }
3 { Copyright (c) H M Sauro 1996 }
4 { Future Skill Software }
5 { }
6 { Modified July 1999 to include boolean operations, not, }
7 { or, and, <, <=, >, >=, <>, = }
8 { True = 1 and False = 0
9 { ******************************************************** }
10
11
12 unit Texpr;
13
14 interface
15
16 uses SysUtils, Classes, Controls, Forms, StdCtrls, nSymTab;
17
18 const
19 EOF_CHAR = $7F;
20 MAX_DIGIT_COUNT = 2;
21 DEFAULT_MAX_SIZE = 400; { Initial max size of rpn expression space, can grow dynamically }
22 GROWTH = 100; { This is how much the rpn expression grows by if space runs out }
23 MAX_BUILTINS = 24; { Maximum number of built-in functions }
24 DEFAULT_STACK_SIZE = 100; { default depth of evaluation stack, can be set dynamically at runtime }
25
26
27 type
28 { Changes the way the parser interprets new symbols. eInstallSymbols means
29 add new symbols to the symbol table without complaint, initialised to zero.
30 eReportNewSymbols means raise an exception when a new symbol is encountered }
31 TAssignBehaviour = (eReportNewSymbols, eInstallSymbols);
32
33 { Top level exception }
34 EExprException = class (Exception);
35
36 TParser = class;
37 TEvaluator = class;
38
39 { This is the Object that is accessible from the Component palette }
40
41 TAlgExpression =
42 class (TComponent)
43 private
44 FExpression : string;
45 FParser : TParser;
46 FSymbolTable : TBinarySearchTree; { Its own private symbol table ! }
47 FEvaluator : TEvaluator;
48 public
49 nBuiltIns : integer;
50 constructor create (AOwner : TComponent); override;
51 destructor destroy; override;
52
53 function EvalThis (s : string) : double;
54 function Eval : double;
55 procedure Compile (s : string);
56 procedure SetExp (s: string);
57 function GetExp : string;
58 procedure SetRunTimeStack (s : integer);
59 function GetRunTimeStack : integer;
60 procedure Clear;
61 procedure SetVar (s : string; d : double);
62 function GetVar (s : string) : double;
63 function rpn : string;
64 procedure SetAssignBehaviour (value : TAssignBehaviour);
65 function GetAssignBehaviour : TAssignBehaviour;
66 procedure InstallBuiltIns;
67 property Symbols : TBinarySearchTree read FSymbolTable;
68 published
69 property str: string read GetExp write SetExp;
70 property AssignBehaviour: TAssignBehaviour read GetAssignBehaviour write SetAssignBehaviour;
71 property RunTimeStack: integer read GetRunTimeStack write SetRunTimeStack;
72 end;
73
74
75 { ********************************************************************** }
76 { Declarations for the Parser }
77
78 ECompileException = class (Exception);
79 EMissingLParen = class (ECompileException);
80 EMissingRParen = class (ECompileException);
81 ESyntaxError = class (ECompileException);
82 EUnknownIdentifier = class (ECompileException);
83 ETokenExpected = class (ECompileException);
84
85 { ********************* Lexical scanner types etc *********************** }
86
87 TcharCode = (LETTER, DIGIT, POINT, SPECIAL, ETX);
88 TTokenCodes = (EMPTY, IDENTIFIER, NUMBER, PLUS, MINUS, MULT,
89 cPOWER, RPAREN, LPAREN, SLASH, ERROR, tEquals,
90 APOSTROPHY, SEMICOLON, ANDTOKEN, ORTOKEN, NOTTOKEN,
91 tLessThan, tLessThanOrEqual, tMoreThan, tNotEqual, tMoreThanOrEqual,
92 End_of_string);
93
94 TFunctionId = record
95 name : string;
96 opcode : integer;
97 end;
98
99 { ************* Reverse polish data structures and types ****************** }
100
101 TRpnEntry = (V, O, C);
102
103 { The instruction stream is composed of RpnElement types. These are
104 made from a union of three data types:
105 1. value RP_CONSTANT followed by double value, used for storing constants;
106 2. value RP_OPERAND followed by a pointer into the symbol table for fast access;
107 3. value < 0, an integer, always less than zero and is a code for
108 representing an operation, eg -1 means ADDITION.
109
110 The Union structure was chosen initially to converse memory but later it
111 was discovered that a Union also speeded up processing }
112
113 TRpnElement = record
114 case TRpnEntry of
115 V : (value : integer);
116 O : (operand : pTSymTabNode); { operands and operators }
117 C : (constant : double); { constants, eg 1.234 }
118 end;
119
120 { for the benefit of dynamic rpn expressions }
121 TRpnArrayType = array[1..1000] of TRpnElement; { doesn't allocate space! }
122 pRpnArrayType = ^TRpnArrayType;
123
124 { Because the rpn expression is a dynamic structure it has two lengths,
125 a MaxLength which is the actual space allocated on the heap; and LengthUsed
126 which is the space actually used in the array. LengthUsed <= MaxLength }
127 TProgram = record
128 MaxLength, LengthUsed : integer;
129 expr : pRpnArrayType;
130 end;
131
132 { *********************** Start of TParser OBJECT ************************* }
133
134 TParser = class (TObject)
135 private
136 FProgram : TProgram; { Note the parser owns the rpn expression }
137 FSymTab : TBinarySearchTree; { Only a pointer to the copy held by TAlgExpression }
138 FToken, Fprevious_token : TTokenCodes;
139 Fvalue, Fprevious_value : double;
140 Fname, Fprevious_name : string;
141 Fexpression : string; Flen_expr : integer;
142 Fch : char; Fposition : integer;
143 Fchar_table : array[0..255] of TcharCode;
144 Ffunction_id : array[1..MAX_BUILTINS] of TFunctionId; { built-in functions }
145 FBehaviour : TAssignBehaviour;
146 procedure initialise_scanner;
147 procedure init_funcTable;
148 function search_functionId (name : string; var index : integer) : boolean;
149 procedure SetAssignBehaviour (behave : TAssignBehaviour);
150 function GetAssignBehaviour : TAssignBehaviour;
151 function ReturnRpnString : string;
152 function LookAheadch : char;
153 procedure nextchar;
154 procedure skip_blanks;
155 procedure get_token;
156 procedure unget_token;
157 procedure get_word;
158 procedure get_number;
159 procedure get_special;
160 procedure factor;
161 procedure super_term;
162 procedure term;
163 procedure DoSimpleExpression;
164 procedure doexpression;
165 procedure doassignment (lefthand_name : string);
166 procedure dostatement;
167 function GetNextInstructionSpace : integer;
168 procedure StoreInst (inst : integer);
169 procedure StoreSymbol (symb : pTSymTabNode);
170 procedure StoreConstant (c : double);
171 public
172 constructor create;
173 destructor destroy; override;
174
175 procedure ParseExp (expr : string; SymTab : TBinarySearchTree);
176 procedure FreeProgram;
177 end;
178
179
180 { ********************************************************************** }
181 { Declarations for the Evaluator }
182
183 { Evaluator exceptions }
184 EEvaluateException = class (Exception);
185 ERTStackOverFlow = class (EEvaluateException); { Only applicable to xD routines }
186 ERTStackUnderFlow = class (EEvaluateException);
187 EMathPower = class (EEvaluateException);
188 EEvaluationError = class (EEvaluateException);
189
190
191 { Record returned after an evaluation }
192 TEvalType = record
193 value : double;
194 SymTabPtr : pTSymTabNode;
195 end;
196
197 TStack = array[0..1023] of double;
198 pTStack = ^TStack;
199
200 { *********************** Start of TEvaluator OBJECT ************************* }
201
202 TEvaluator = class (TObject)
203 private
204 { declare runtime stack used during evaluations }
205 FStack : pTStack;
206 FStack_top : integer;
207 FStackSize : integer;
208 FStackSize_Minus_1 : integer; { StackSize - 1 }
209 TrigF : double; { set to Pi/180 if user decides to use degrees else = 1.0 }
210 FUseRadians : boolean;
211 procedure FreeStack;
212 function GetStack : integer;
213 procedure SetStack (size : integer);
214
215 public
216 procedure Use_radians;
217 procedure Use_degrees;
218 function run (ProgramExpr : TProgram; SymTab : TBinarySearchTree) : TEvalType;
219 constructor create;
220 destructor destroy; override;
221 end;
222
223 { -------------------------------------------------------------------------- }
224
225 procedure Register;
226
227 implementation
228
229
230 { -------------------------------------------------------------------------- }
231 { -------------------------------------------------------------------------- }
232
233
234 { Further Declarations for the Evaluator }
235
236 const
237 RP_CONSTANT = 5000; { Push constant value which follows on to the stack }
238 RP_OPERAND = 1000; { Push value pointed to by following ptr onto stack }
239 RP_ADD = -1; { Pop two args off stack, add them and push result onto stack }
240 RP_SUBTRACT = -2;
241 RP_MULTIPLY = -3;
242 RP_DIVIDE = -4;
243 RP_POWER = -5;
244 RP_AND = -6;
245 RP_OR = -7;
246 RP_NOT = -8;
247 RP_GT = -9;
248 RP_LT = -10;
249 RP_GE = -11;
250 RP_LE = -12;
251 RP_NOTEQ = -13; // <>
252 RP_GTE = -14; // >=
253 RP_LTE = -15; // <=
254
255 RP_SIN = -101;
256 RP_COS = -102;
257 RP_TAN = -103;
258 RP_EXP = -104;
259 RP_LOG = -105; { log to the base 10 }
260 RP_LN = -106; { log to the base e }
261 RP_SQR = -107; { square function }
262 RP_SQRT = -108; { square root function }
263 RP_FACT = -109; { factorial, x! }
264 RP_ARCSIN = -110;
265 RP_ARCCOS = -111;
266 RP_ARCTAN = -112;
267 RP_SINH = -113;
268 RP_COSH = -114;
269 RP_TANH = -115;
270 RP_ARCSINH = -116;
271 RP_ARCCOSH = -117;
272 RP_ARCTANH = -118;
273
274 RP_UNARYMINUS = -120;
275
276 RP_EQUALS = -500; { Assignment operator }
277
278 RP_STOP = 0;
279
280 { In the instruction stream, any entry value greater than zero is either
281 a constant of an operand instruction. In either case the argument follows in
282 the next instruction. In the case of a constant, the following value is the
283 constant, in the case of an operand, the following value is a pointer to the
284 symbol table. Anything else is an operator and have values less than zero,
285 except the STOP instruction which has a value of zero. See constants above for
286 types of operator available }
287
288 { --------------------------------------------------------------------------- }
289
290
291 function power (x : double; n : double) : double; forward;
292
293
294 procedure TAlgExpression.InstallBuiltIns;
295 begin
296 nBuiltIns := 5;
297 { Install built-in constants. TAlgExp owns the symbol table }
298 FSymbolTable.insert ('Pi', 3.141592653589793);
299 FSymbolTable.insert ('e', 2.718281828459045);
300 FSymbolTable.insert ('Degrees', 0.0174532925199433);
301 FSymbolTable.insert ('False', 0);
302 FSymbolTable.insert ('True', 1);
303 end;
304
305
306 constructor TAlgExpression.Create (AOwner : TComponent);
307 begin
308 inherited Create (AOwner);
309 FExpression := '';
310 FParser := TParser.Create;
311 FSymbolTable := TBinarySearchTree.Create;
312 FEvaluator := TEvaluator.Create;
313
314 nBuiltIns := 0;
315 end;
316
317
318 destructor TAlgExpression.Destroy;
319 begin
320 FSymbolTable.free;
321 FParser.free;
322 FEvaluator.free;
323 inherited Destroy;
324 end;
325
326
327 procedure TAlgExpression.SetAssignBehaviour (value : TAssignBehaviour);
328 begin
329 if Fparser.GetAssignBehaviour <> value then
330 FParser.SetAssignBehaviour (value);
331 end;
332
333
334 function TAlgExpression.GetAssignBehaviour : TAssignBehaviour;
335 begin
336 result := FParser.GetAssignBehaviour;
337 end;
338
339
340 { Access via properties }
341 procedure TAlgExpression.SetExp (s: string);
342 begin
343 FExpression := s;
344 end;
345
346
347 { Access via properties }
348 function TAlgExpression.GetExp : string;
349 begin
350 result := FExpression;
351 end;
352
353
354 { Allow user of object to resize the runtime stack used by the evaluator, note
355 the existing stack is destroyed during this operation }
356 procedure TAlgExpression.SetRunTimeStack (s : integer);
357 begin
358 if s > 0 then
359 FEvaluator.SetStack (s)
360 else
361 raise EExprException.Create ('Error: Stack size must be greater than zero!');
362 end;
363
364
365 { Get the current size of the stack }
366 function TAlgExpression.GetRunTimeStack : integer;
367 begin
368 result := FEvaluator.GetStack;
369 end;
370
371
372 { Evaulate expression s by compiling and evaulating, slow but simple for quick hacks }
373 { Use: x := e.evalThis ('cos(1.2) + sin(4.5)'); }
374 function TAlgExpression.EvalThis (s : string) : double;
375 begin
376 Result := 0.0;
377 if s <> '' then
378 begin
379 { free any existing compiled expression before we proceed }
380 FParser.FreeProgram;
381
382 FExpression := s;
383 FParser.ParseExp (FExpression, FSymbolTable);
384 result := FEvaluator.run(Fparser.FProgram, FSymbolTable).value;
385 end;
386 end;
387
388
389 { Fast version of the above, less error checking code but much faster }
390 function TAlgExpression.Eval : double;
391 begin
392 if FExpression <> '' then
393 begin
394 if Fparser.FProgram.Expr = Nil then FParser.ParseExp (FExpression, FSymbolTable);
395 result := FEvaluator.run (Fparser.FProgram, FSymbolTable).value;
396 end
397 else
398 raise EExprException.Create ('Error: no expression to evaluate');
399 end;
400
401
402 { Convert string expression into internal rpn format }
403 { Usage: e.Compile ('cos(1.2)'); Subsequent calls to e.eval would evaluate
404 cos(1.2) much quicker }
405 procedure TAlgExpression.Compile (s : string);
406 begin
407 if s <> '' then
408 begin
409 FExpression := s;
410 FParser.ParseExp (FExpression, FSymbolTable);
411 end
412 else
413 raise EExprException.Create ('Error: no expression to evaluate');
414 end;
415
416
417 { Declare and initialise a string variable in the symbol table }
418 { Usage: e.SetVar ('a', 1.2); e.SetVar ('Pi', 3.1415);
419 e.EvalThis ('a*Pi');
420 }
421 procedure TAlgExpression.SetVar (s : string; d : double);
422 var np : pTSymTabNode;
423 begin
424 np := FSymbolTable.find_symbol (s);
425 if np <> Nil then FSymbolTable.SetSymTabValue (np, d) else FSymbolTable.insert (s, d);
426 end;
427
428
429 { Fetch the value of a declared variable from the symbol table }
430 { Usage: e.SetVar ('a', 1.2); x := e.GetVar ('a'). x then equals 1.2 }
431 function TAlgExpression.GetVar (s : string) : double;
432 var np : pTSymTabNode;
433 begin
434 np := FSymbolTable.find_symbol (s);
435 if np <> Nil then result := FSymbolTable.GetSymTabValue (np) else result := 0.0;
436 end;
437
438
439 { Clear all declared variables from the symbol table }
440 procedure TAlgExpression.Clear;
441 begin
442 FSymbolTable.Clear;
443 { ReInstall built-in constants }
444 InstallBuiltIns;
445 end;
446
447
448 function TAlgExpression.rpn : string;
449 begin
450 if Fparser.FProgram.Expr <> Nil then
451 result := FParser.ReturnRpnString;
452 end;
453
454
455 procedure Register;
456 begin
457 RegisterComponents('JLib', [TAlgExpression]);
458 end;
459
460
461 { ------------------------------------------------------------------------- }
462 { ------- PARSER ROUTINES FOLLOW }
463 { ------------------------------------------------------------------------- }
464
465
466 { ----------------------------------------------------------------------- }
467
468
469 constructor TParser.Create;
470 begin
471 inherited Create;
472 initialise_scanner;
473 end;
474
475
476 destructor TParser.Destroy;
477 begin
478 FreeProgram;
479 inherited Destroy;
480 end;
481
482
483 procedure TParser.FreeProgram;
484 begin
485 { Check it hasn't been destroyed already ! }
486 if FProgram.Expr = Nil then exit;
487
488 if FProgram.expr <> Nil then
489 FreeMem (FProgram.expr, (FProgram.MaxLength+1)*Sizeof (TrpnElement));
490 FProgram.Expr := Nil;
491 end;
492
493
494
495 procedure TParser.SetAssignBehaviour (behave : TAssignBehaviour);
496 begin
497 FBehaviour := behave;
498 end;
499
500
501 function TParser.GetAssignBehaviour : TAssignBehaviour;
502 begin
503 result := FBehaviour;
504 end;
505
506
507 procedure TParser.init_funcTable;
508 begin
509 { all function names must be in LOWER case }
510 Ffunction_id[1].name := 'sin'; Ffunction_id[1].opcode := RP_SIN;
511 Ffunction_id[2].name := 'cos'; Ffunction_id[2].opcode := RP_COS;
512 Ffunction_id[3].name := 'tan'; Ffunction_id[3].opcode := RP_TAN;
513 Ffunction_id[4].name := 'exp'; Ffunction_id[4].opcode := RP_EXP;
514 Ffunction_id[5].name := 'log'; Ffunction_id[5].opcode := RP_LOG;
515 Ffunction_id[6].name := 'ln'; Ffunction_id[6].opcode := RP_LN;
516 Ffunction_id[7].name := 'sqr'; Ffunction_id[7].opcode := RP_SQR;
517 Ffunction_id[8].name := 'sqrt'; Ffunction_id[8].opcode := RP_SQRT;
518 Ffunction_id[9].name := 'fact'; Ffunction_id[9].opcode := RP_FACT;
519 Ffunction_id[10].name := 'arcsin'; Ffunction_id[10].opcode := RP_ARCSIN;
520 Ffunction_id[11].name := 'arccos'; Ffunction_id[11].opcode := RP_ARCCOS;
521 Ffunction_id[12].name := 'arctan'; Ffunction_id[12].opcode := RP_ARCTAN;
522 Ffunction_id[13].name := 'sinh'; Ffunction_id[13].opcode := RP_SINH;
523 Ffunction_id[14].name := 'cosh'; Ffunction_id[14].opcode := RP_COSH;
524 Ffunction_id[15].name := 'tanh'; Ffunction_id[15].opcode := RP_TANH;
525 Ffunction_id[16].name := 'arcsinh'; Ffunction_id[16].opcode := RP_ARCSINH;
526 Ffunction_id[17].name := 'arccosh'; Ffunction_id[17].opcode := RP_ARCCOSH;
527 Ffunction_id[18].name := 'arctanh'; Ffunction_id[18].opcode := RP_ARCTANH;
528
529 { use RP_STOP from RpnTypes to indicate end of function list }
530 Ffunction_id[19].opcode := RP_STOP;
531 end;
532
533
534 procedure TParser.initialise_scanner;
535 var ch : char;
536 begin
537 for ch := chr(0) to chr(255) do Fchar_table[ord(ch)] := SPECIAL;
538 for ch := '0' to '9' do Fchar_table[ord(ch)] := DIGIT;
539 for ch := 'A' to 'Z' do Fchar_table[ord(ch)] := LETTER;
540 for ch := 'a' to 'z' do Fchar_table[ord(ch)] := LETTER;
541 Fchar_table[ord('.')] := POINT;
542 Fchar_table[EOF_CHAR] := ETX;
543
544 init_funcTable;
545 FBehaviour := eInstallSymbols;
546 end;
547
548
549 { return true if it finds name in the built-in function
550 table and index then holds the op code }
551 function TParser.search_functionId (name : string; var index : integer) : boolean;
552 var i : integer;
553 begin
554 name := LowerCase (name); { drop the case just in case the user has used upper case }
555 i := 1;
556 repeat
557 if name = Ffunction_id[i].name then
558 begin
559 index := Ffunction_id[i].opcode;
560 result := true;
561 exit;
562 end;
563 inc (i);
564 until Ffunction_id[i].opcode = RP_STOP;
565 index := 0;
566 result := false;
567 end;
568
569
570 function TParser.LookAheadch : char;
571 begin
572 if Fposition > Flen_expr then
573 result := char(EOF_CHAR)
574 else
575 result := FExpression [FPosition];
576 end;
577
578
579 { Update ch to next character in input stream }
580 procedure TParser.nextchar;
581 begin
582 if Fposition > Flen_expr then
583 Fch := char(EOF_CHAR)
584 else
585 begin
586 Fch := Fexpression [Fposition];
587 inc (Fposition);
588 end;
589 end;
590
591
592 procedure TParser.skip_blanks;
593 begin
594 while Fch = ' ' do nextchar;
595 end;
596
597
598 { Scan in a number token }
599 procedure TParser.get_number;
600 var single_digit, scale, evalue : double; exponent_sign, digit_count : integer;
601 begin
602 Fvalue := 0.0; evalue := 0.0; exponent_sign := 1;
603 { check for decimal point just in case user has typed some thing like .5 }
604 if Fch <> '.' then
605 repeat
606 single_digit := ord (Fch) - ord ('0');
607 Fvalue := 10*Fvalue + single_digit;
608 nextchar;
609 until Fchar_table[ord(Fch)] <> DIGIT;
610
611 scale := 1;
612 if Fch = '.' then
613 begin
614 { start collecting fractional part }
615 nextchar;
616 if Fchar_table[ord(Fch)] <> DIGIT then
617 begin
618 FreeProgram;
619 raise ESyntaxError.Create ('Syntax error: expecting number after decimal point');
620 end;
621
622 while Fchar_table[ord(Fch)] = DIGIT do
623 begin
624 scale := scale * 0.1;
625 single_digit := ord (Fch) - ord ('0');
626 Fvalue := Fvalue + (single_digit * scale);
627 nextchar;
628 end;
629 {until char_table[ord(ch)] <> DIGIT;}
630 end;
631 { next check for scientific notation }
632 if (Fch = 'e') or (Fch = 'E') then
633 begin
634 nextchar;
635 if (Fch = '-') or (Fch = '+') then
636 begin
637 if Fch = '-' then exponent_sign := -1;
638 nextchar;
639 end;
640 { accumulate exponent, check that firat ch is a digit }
641 if Fchar_table[ord(Fch)] <> DIGIT then
642 begin
643 FreeProgram;
644 raise ESyntaxError.Create ('Syntax error: number expected in exponent');
645 end;
646
647 digit_count := 0;
648 repeat
649 inc (digit_count);
650 single_digit := ord (Fch) - ord ('0');
651 evalue := 10*evalue + single_digit;
652 nextchar;
653 until (Fchar_table[ord(Fch)] <> DIGIT) or (digit_count > MAX_DIGIT_COUNT);
654
655 if digit_count > MAX_DIGIT_COUNT then
656 begin
657 FreeProgram;
658 raise ESyntaxError.Create ('Syntax error: too many digits in exponent');
659 end;
660
661 evalue := evalue * exponent_sign;
662 evalue := power (10.0, evalue);
663 Fvalue := Fvalue * evalue;
664 end;
665 Ftoken := Number;
666 end;
667
668
669 { Scan in an identifier token }
670 procedure TParser.get_word;
671 begin
672 Fname := '';
673 while (Fchar_table [ord(Fch)] = LETTER) or (Fchar_table[ord(Fch)] = DIGIT) do
674 begin
675 Fname := Fname + Fch;
676 nextchar;
677 end;
678 FToken := Identifier;
679 end;
680
681
682
683 { Get special tokens }
684 procedure TParser.get_special;
685 begin
686 case Fch of
687 '+' : Ftoken := Plus;
688 '-' : Ftoken := Minus;
689 '*' : Ftoken := Mult;
690 '/' : Ftoken := Slash;
691 '^' : Ftoken := cPower;
692 '(' : Ftoken := Lparen;
693 ')' : Ftoken := Rparen;
694 '=' : Ftoken := tEquals;
695 '>' : begin
696 if LookAheadch = '=' then
697 begin
698 nextchar;
699 Ftoken := tMoreThanOrEqual;
700 end
701 else
702 Ftoken := tMoreThan;
703 end;
704 '<' : begin
705 if LookAheadch = '>' then
706 begin
707 nextchar;
708 Ftoken := tNotEqual;
709 end
710 else
711 if LookAheadCh = '=' then
712 begin
713 nextchar;
714 Ftoken := tLessThanOrEqual;
715 end
716 else
717 Ftoken := tLessThan;
718 end;
719 ';' : Ftoken := SEMICOLON;
720 '''' : Ftoken := Apostrophy;
721 else
722 Ftoken := Error;
723 end;
724 nextchar;
725 end;
726
727
728 { Get the next token }
729 procedure TParser.get_token;
730 begin
731 { check if a token has been pushed back into the token stream, if so use it first }
732 if Fprevious_token <> EMPTY then
733 begin
734 Ftoken := Fprevious_token;
735 Fname := Fprevious_name;
736 Fvalue := Fprevious_value;
737 Fprevious_token := EMPTY;
738 exit;
739 end;
740
741 skip_blanks;
742
743 case Fchar_table[ord(Fch)] of
744
745 LETTER : begin get_word; end;
746 POINT : get_number; { just in case user has entered .5 etc }
747 DIGIT : get_number;
748 ETX : Ftoken := End_of_string;
749 else
750 get_special;
751 end;
752 if FToken = Identifier then
753 begin
754 if LowerCase (FName) = 'and' then
755 FToken := ANDTOKEN
756 else
757 if LowerCase (FName) = 'or' then
758 FToken := ORTOKEN
759 else
760 if LowerCase (FName) = 'not' then
761 FToken := NOTTOKEN
762 end;
763 end;
764
765
766 { push token back into token stream }
767 procedure TParser.unget_token;
768 begin
769 Fprevious_token := Ftoken;
770 Fprevious_name := Fname;
771 Fprevious_value := Fvalue;
772 end;
773
774
775 { -------------------------------------------------------------------- }
776 { Some debugging routines for internal use }
777
778 { Debugging routines, not for general use }
779 {procedure show_token;
780 begin
781 case token of
782 EMPTY : writeln ('<No token>');
783 Identifier : writeln ('<Word>');
784 Number : writeln ('<Number:', value:8, '>');
785 Plus : writeln ('<Plus>');
786 Minus : writeln ('<Minus>');
787 Mult : writeln ('<Mult>');
788 Slash : writeln ('<Divide>');
789 cPower : writeln ('<Power>');
790 Error : writeln ('<Error!!!>');
791 End_of_string : writeln ('<Reached end of string>');
792 end;
793 end;}
794
795 { For debugging only }
796 {procedure display_rpn_expr (rpn_array : pRpnArrayType);
797 var i : integer;
798 begin
799 i := 1;
800 repeat
801 if rpn_array^[i].value = RP_CONSTANT then
802 begin
803 write ('<CONSTANT:');
804 inc (i); writeln (rpn_array^[i].constant);
805 end
806 else
807 case rpn_array^[i].value of
808 -1 : writeln ('<+>');
809 -2 : writeln ('<->');
810 -3 : writeln ('<*>');
811 -4 : writeln ('</>');
812 -5 : writeln ('<^>');
813 else
814 writeln (rpn_array^[i].value);
815 end;
816 inc (i);
817 until rpn_array^[i].value = RP_STOP;
818 writeln ('<RP_STOP>');
819 end;}
820
821
822 function TParser.ReturnRpnString : string;
823 var p : pRpnArrayType; i : integer;
824 begin
825 i := 1; p := FProgram.expr; result := '';
826 repeat
827 if p^[i].value = RP_OPERAND then
828 begin
829 inc (i); result := result + (p^[i].operand)^.name + ' ';
830 end
831 else if p^[i].value = RP_CONSTANT then
832 begin
833 inc (i);
834 result := result + floattostr (p^[i].constant) + ' ';
835 end
836 else
837 case p^[i].value of
838 RP_EQUALS : begin
839 result := result + '= '; inc (i);
840 result := result + (p^[i].operand)^.name + ' ';
841 end;
842 RP_ADD : result := result + '+ ';
843 RP_SUBTRACT : result := result + '- ';
844 RP_MULTIPLY : result := result + '* ';
845 RP_DIVIDE : result := result + '/ ';
846 RP_POWER : result := result + '^ ';
847 RP_SIN : result := result + 'sin ';
848 RP_COS : result := result + 'cos ';
849 RP_TAN : result := result + 'tan ';
850 RP_ARCSIN : result := result + 'arcsin ';
851 RP_ARCCOS : result := result + 'arccos ';
852 RP_ARCTAN : result := result + 'arctan ';
853
854 RP_SINH : result := result + 'sinh ';
855 RP_COSH : result := result + 'cosh ';
856 RP_TANH : result := result + 'tanh ';
857
858 RP_ARCSINH : result := result + 'arcsinh ';
859 RP_ARCCOSH : result := result + 'arccosh ';
860 RP_ARCTANH : result := result + 'arctanh ';
861
862 RP_EXP : result := result + 'exp ';
863 RP_LOG : result := result + 'log ';
864 RP_LN : result := result + 'ln ';
865 RP_SQR : result := result + 'sqr ';
866 RP_SQRT : result := result + 'sqrt ';
867 RP_FACT : result := result + 'fact ';
868 RP_UNARYMINUS : result := result + 'UMINUS ';
869 end;
870 inc (i);
871 until p^[i].value = RP_STOP;
872 end;
873
874
875 { ------------------------------------------------------------------------ }
876
877 { Checks that there is enough space to store the next instruction, if not it grows
878 the array space automatically and returns the index to the new instruction position}
879 function TParser.GetNextInstructionSpace : integer;
880 begin
881 if FProgram.LengthUsed+1 > FProgram.MaxLength then
882 begin
883 { Not enough space, so reallocate heap space with GROWTH extra spaces }
884 ReAllocMem(FProgram.expr, (FProgram.MaxLength+GROWTH)*Sizeof (TrpnElement));
885 FProgram.MaxLength := FProgram.MaxLength + GROWTH;
886 end;
887 inc (FProgram.LengthUsed);
888 Result := FProgram.LengthUsed;
889 end;
890
891
892 procedure TParser.StoreInst (inst : integer);
893 begin
894 FProgram.expr^[GetNextInstructionSpace].value := inst;
895 end;
896
897
898 procedure TParser.StoreSymbol (symb : pTSymTabNode);
899 begin
900 FProgram.expr^[GetNextInstructionSpace].operand := symb;
901 end;
902
903
904 procedure TParser.StoreConstant (c : double);
905 begin
906 FProgram.expr^[GetNextInstructionSpace].constant := c;
907 end;
908
909
910 { Parse for constants, identifier, functions or '(' expressions ')' }
911 procedure TParser.factor;
912 var index : integer; np : pTSymTabNode;
913 begin
914 case Ftoken of
915 Number :
916 begin
917 StoreInst (RP_CONSTANT);
918 StoreConstant (Fvalue);
919 get_token;
920 end;
921
922 Identifier:
923 begin
924 { Check to see whether the name is a function identifier }
925 if search_functionId (Fname, index) then
926 begin
927 get_token;
928 if Ftoken <> Lparen then
929 begin
930 FreeProgram;
931 raise EMissingLParen.Create ('Syntax error: missing left bracket');
932 end;
933 get_token;
934 DoSimpleExpression;
935 if Ftoken <> Rparen then
936 begin
937 FreeProgram;
938 raise EMissingRParen.Create ('Syntax error: missing right bracket');
939 end;
940 { enter function id into instruction stream, not an Instruction as it appears }
941 StoreInst (index);
942 end
943 else
944 begin
945 { identifier wasn't a function name, so check in symbol table..}
946 { Search the symbol table. Nil if the name cannot be found }
947 np := FSymTab.find_symbol (Fname);
948 if np = Nil then
949 begin
950 { Check behaviour setting }
951 if FBehaviour = eInstallSymbols then
952 { i.e user wishes to accept undeclared identifiers, add to symbol table, init to 0.0 }
953 np := FSymTab.insert (Fname, 0.0)
954 else
955 begin
956 { User requests reporting of undeclared lefthand variables as an error }
957 FreeProgram;
958 raise ESyntaxError.CreateFmt ('Syntax error: Unrecognised identifier <%s> in expression', [Fname]);
959 end;
960 end;
961 { add operand to rpn expression }
962 StoreInst (RP_OPERAND);
963 StoreSymbol (np);
964 end;
965
966 get_token;
967 end;
968 Lparen :
969 begin
970 get_token;
971 DoExpression;
972 if (Ftoken = Rparen) then
973 get_token
974 else
975 begin
976 FreeProgram;
977 raise EMissingRParen.Create ('Syntax error: missing right bracket');
978 end
979 end;
980 NOTTOKEN :
981 begin
982 get_token;
983 Factor;
984 StoreInst (RP_NOT);
985 end;
986 else
987 begin
988 FreeProgram;
989 raise ESyntaxError.Create ('Syntax error: expecting number, identifier or left bracket');
990 end;
991 end;
992 end;
993
994
995 { Allows one to deal with power operators '^', sym ^ sym }
996 procedure TParser.super_term;
997 begin
998 factor;
999 while (Ftoken = cPower) do
1000 begin
1001 get_token;
1002 factor;
1003 StoreInst (RP_POWER);
1004 end;
1005 end;
1006
1007
1008 { Parse things like sym * sym or sym / sym }
1009 procedure TParser.term;
1010 var op : TtokenCodes;
1011 begin
1012 super_term;
1013 while (Ftoken = MULT) or (Ftoken = SLASH) or (Ftoken = ANDTOKEN) do
1014 begin
1015 op := Ftoken;
1016 get_token;
1017 super_term;
1018
1019 case op of
1020 MULT : StoreInst (RP_MULTIPLY);
1021 SLASH : StoreInst (RP_DIVIDE);
1022 ANDTOKEN : StoreInst (RP_AND);
1023 end;
1024 end;
1025 end;
1026
1027
1028 procedure TParser.DoExpression;
1029 var op : TtokenCodes;
1030 begin
1031 DoSimpleExpression;
1032
1033 while (fToken = tLessThan) or (fToken = tLessThanOrEqual) or
1034 (fToken = tMoreThan) or (fToken = tMoreThanOrEqual) or
1035 (fToken = tNotEqual) or (fToken = tEquals) do
1036 begin
1037 op := FToken; // remember token
1038 get_token;
1039 DoSimpleExpression;
1040 case op of
1041 tLessThan : StoreInst (RP_LT);
1042 tMoreThan : StoreInst (RP_GT);
1043 tNotEqual : StoreInst (RP_NOTEQ);
1044 tMoreThanOrEqual : StoreInst (RP_GTE);
1045 tLessThanOrEqual : StoreInst (RP_LTE);
1046 end;
1047 end;
1048 end;
1049
1050
1051 { Parse things like sym + sym or sym - sym, checking also fo runary operators }
1052 procedure TParser.DoSimpleExpression;
1053 var op, unary_op : TtokenCodes;
1054 begin
1055 { remember unary + or - if there is one }
1056 unary_op := Plus;
1057 if (Ftoken = Plus) or (Ftoken = Minus) then
1058 begin
1059 unary_op := Ftoken;
1060 get_token;
1061 end;
1062
1063 term;
1064 if (unary_op = Minus) then StoreInst (RP_UNARYMINUS);
1065
1066 while (Ftoken = PLUS) or (Ftoken = MINUS) or (FToken = ORTOKEN) do
1067 begin
1068 op := Ftoken; { remember the token }
1069 get_token;
1070 term;
1071
1072 case op of
1073 PLUS : StoreInst (RP_ADD);
1074 MINUS : StoreInst (RP_SUBTRACT);
1075 ORTOKEN : StoreInst (RP_OR);
1076 end;
1077 end;
1078 end;
1079
1080
1081 { Process expression of type, y=f(x). y= has already been parsed and y string
1082 is stored in variable lefthand_name }
1083 procedure TParser.doassignment (lefthand_name : string);
1084 var np : pTSymTabNode;
1085 begin
1086 { Search for identifier 'y', Nil if not found }
1087 np := FSymTab.find_symbol (Lefthand_name);
1088 if np = Nil then
1089 begin
1090 { Check behaviour setting }
1091 if FBehaviour = eInstallSymbols then
1092 begin
1093 { i.e user wishes to accept undeclared assigned identifiers, add to symbol table, init to 0.0 }
1094 np := FSymTab.insert (Lefthand_name, 0.0);
1095 end
1096 else
1097 begin
1098 { User requests reporting of undeclared lefthand variables as an error }
1099 FreeProgram;
1100 raise ESyntaxError.CreateFmt ('Syntax error: Unrecognised identifier <%s> on left of expression', [Lefthand_name]);
1101 end;
1102 end;
1103
1104 get_token;
1105 DoExpression;
1106 StoreInst (RP_EQUALS);
1107 StoreSymbol (np);
1108 end;
1109
1110
1111
1112
1113 procedure TParser.dostatement;
1114 var savedname : string;
1115 begin
1116 if Ftoken = Identifier then
1117 begin
1118 savedname := Fname;
1119 get_token; { look ahead for '=' token }
1120 if Ftoken = tEquals then doassignment (savedname) else
1121 begin
1122 { Not an assignment, therefore Unwind back to start before processing expression}
1123 unget_token;
1124 Ftoken := Identifier;
1125 Fname := savedname;
1126 DoExpression;
1127 end;
1128 end
1129 else
1130 DoExpression;
1131 end;
1132
1133
1134 { compiles an expression into an internal static array called rpn_array }
1135 procedure TParser.ParseExp (expr : string; SymTab : TBinarySearchTree);
1136 begin
1137 { make a local copy of the symbol table pointer so that it is
1138 accessible throughout the unit }
1139 FSymTab := SymTab;
1140
1141 { make a local copy of the expressiob string so that it is
1142 accessible through out the unit }
1143 Fexpression := expr; Flen_expr := length (Fexpression);
1144
1145 Fposition := 1; Fprevious_token := EMPTY;
1146
1147 { Create space for the rpn expression }
1148
1149 FProgram.MaxLength := DEFAULT_MAX_SIZE;
1150 FProgram.LengthUsed := 0;
1151 { Add one to the allocation so that we start to index from ONE }
1152 FProgram.expr := AllocMem ((DEFAULT_MAX_SIZE+1)*Sizeof (TrpnElement));
1153
1154 { start scan by fetching first character }
1155 nextchar;
1156 get_token;
1157 dostatement; { Note statments can be spearated by ';' }
1158 while (Ftoken = SEMICOLON) and (Ftoken <> End_of_String) do
1159 begin
1160 get_token;
1161 if Ftoken = End_of_String then break;
1162 dostatement;
1163 end;
1164
1165 { At this point we should have reached end of string, if we havn't
1166 then it's a syntax error }
1167 if Ftoken <> End_of_String then
1168 begin
1169 FreeProgram;
1170 raise ESyntaxError.Create ('Syntax error: reached end of equation too soon, something missing?');
1171 end;
1172 { ...and don't forget the terminator instruction }
1173 StoreInst (RP_STOP);
1174 { --------------------------- END PARSING ----------------------------- }
1175
1176 { Reduce size of memory used to what's required }
1177 If FProgram.LengthUsed < FProgram.MaxLength then
1178 begin
1179 ReAllocMem(FProgram.expr, (FProgram.LengthUsed+1)*Sizeof (TrpnElement));
1180 FProgram.MaxLength := FProgram.LengthUsed;
1181 end;
1182 end;
1183
1184
1185 { ********************* END OF PARSER ROUTINES **************************** }
1186
1187
1188 { ------------------------------------------------------------------------- }
1189 { ------- EVALUATOR ROUTINES FOLLOW }
1190 { ------------------------------------------------------------------------- }
1191
1192
1193
1194 { public routines for changing behaviour of trifg functions, i.e whether the
1195 trig functions accept radians or degrees }
1196
1197
1198 constructor TEvaluator.Create;
1199 begin
1200 inherited Create;
1201 { Initialise Constants and Evaluator runtime stack }
1202 {Log_e := 0.4342944819032518; { Log10 of e }
1203 FStack := Nil; { Holds the stack pointer }
1204 SetStack (DEFAULT_STACK_SIZE);
1205 Use_Radians;
1206 end;
1207
1208
1209 destructor TEvaluator.Destroy;
1210 begin
1211 FreeStack;
1212 inherited Destroy;
1213 { Do not destroy rpn expression since this is owned by the Parser ! }
1214 end;
1215
1216
1217 procedure TEvaluator.Use_radians;
1218 begin
1219 FUseRadians := true;
1220 end;
1221
1222
1223 procedure TEvaluator.Use_degrees;
1224 begin
1225 FUseRadians := false;
1226 end;
1227
1228
1229 { Set size of dynamic stack }
1230 procedure TEvaluator.SetStack (size : integer);
1231 begin
1232 { Destroy old stack if necessary }
1233 if FStack <> Nil then FreeMem (FStack, sizeof (double) * FStackSize);
1234 FStackSize := size;
1235 FStackSize_Minus_1 := size - 1;
1236 FStack := AllocMem (sizeof (double) * size);
1237 end;
1238
1239
1240 { Returns current size of runtime stack }
1241 function TEvaluator.GetStack : integer;
1242 begin
1243 result := FStackSize;
1244 end;
1245
1246
1247 { Destroy space allocated for stack }
1248 procedure TEvaluator.FreeStack;
1249 begin
1250 if FStack <> Nil then FreeMem (FStack, sizeof (double) * FStackSize);
1251 FStack := Nil;
1252 end;
1253
1254
1255
1256 { ---------------------------------------------------------------------- }
1257
1258
1259 { Something missing from Pascal!
1260 Compute x^n where n may be a fractional value, eg 1.2^3.4 }
1261 function power (x : double; n : double) : double;
1262 var int_of_n : double; intn : integer;
1263 begin
1264 Result := 0.0;
1265 if n = 0.0 then begin result := 1.0; exit; end; { save going through exp etc }
1266 if x > 0 then
1267 result := exp (n*ln(x))
1268 else if x = 0 then
1269 result := 0.0
1270 else if x < 0 then
1271 begin
1272 { check if n is an integer }
1273 int_of_n := int (n);
1274 intn := round (int_of_n);
1275 if int_of_n = n then { if it's an integer }
1276 begin
1277 result := exp (n*ln(abs(x)));
1278 { now work out the sign }
1279 if (odd (intn)) and (int_of_n <> 0) then result := result * (-1);
1280 end
1281 else
1282 begin
1283 raise EMathPower.Create ('Error calculating root of negative number in power');
1284 end;
1285 end;
1286 end;
1287
1288 { --------------------------------------------------------------------------- }
1289 { Much Optimised version of run }
1290 { --------------------------------------------------------------------------- }
1291
1292
1293 { evaluate reverse polish expression, fully optimised for speed }
1294 function TEvaluator.run (ProgramExpr : TProgram; SymTab : TBinarySearchTree) : TEvalType;
1295 var i, k : integer; symIndex : pTSymTabNode;
1296 p : pRpnArrayType; x : double; xi : integer;
1297 begin
1298 { scan reverse polish expression until we come across the stop code }
1299
1300 { If the expression is an assignment, then the routine returns a TEvalType
1301 record which holds the value of the right-hand side and a pointer to the
1302 variables which was assigned }
1303
1304 symIndex := Nil; { in case function is not an assignment function }
1305 if FUseRadians then TrigF := 1.0 else TrigF := Pi/180;
1306 { Initialise runtime stack }
1307 Fstack_top := -1; i := 1; p := ProgramExpr.expr;
1308 repeat { infinite loop, get out in case statement when RS_STOP instruction encountered }
1309 case p^[i].value of
1310
1311 RP_OPERAND : begin inc (i);
1312 if Fstack_top = FStackSize_MINUS_1 then
1313 raise ERTStackOverFlow.Create ('Evaluation Stack overflow during Operand push');
1314
1315 inc (Fstack_top);
1316 { Use the official calls to get to symbol table, best not
1317 go direct to the symbol table, a compromise }
1318 Fstack^[Fstack_top] := SymTab.GetSymTabValue (p^[i].operand);
1319 {Direct method: stack[stack_top] := (p^[i].operand)^.value;}
1320 end;
1321 RP_CONSTANT : begin inc (i);
1322 if Fstack_top = FStackSize_MINUS_1 then
1323 raise ERTStackOverFlow.Create ('Evaluation Stack overflow during Constant push');
1324 inc (Fstack_top); Fstack^[Fstack_top] := p^[i].constant;
1325 end;
1326 RP_STOP : begin { finally pop off the answer and return to caller }
1327 result.value := Fstack^[Fstack_top];
1328 result.SymTabPtr := symIndex; { set to nil if expression not an assignment }
1329 exit;
1330 end;
1331
1332 RP_AND : begin
1333 dec(Fstack_top);
1334 if (Fstack^[Fstack_top] <> 0) and (Fstack^[Fstack_top+1] <> 0) then
1335 Fstack^[Fstack_top] := 1
1336 else
1337 Fstack^[Fstack_top] := 0;
1338 end;
1339
1340 RP_OR : begin
1341 dec(Fstack_top);
1342 if (Fstack^[Fstack_top] <> 0) or (Fstack^[Fstack_top+1] <> 0) then
1343 Fstack^[Fstack_top] := 1
1344 else
1345 Fstack^[Fstack_top] := 0;
1346 end;
1347
1348 RP_NOT : begin
1349 if (Fstack^[Fstack_top] = 0) then
1350 Fstack^[Fstack_top] := 1
1351 else
1352 Fstack^[Fstack_top] := 0;
1353 end;
1354
1355 RP_GT : begin
1356 dec(Fstack_top);
1357 if Fstack^[Fstack_top] > Fstack^[Fstack_top+1] then
1358 Fstack^[Fstack_top] := 1
1359 else
1360 Fstack^[Fstack_top] := 0;
1361 end;
1362
1363 RP_GTE : begin
1364 dec(Fstack_top);
1365 if Fstack^[Fstack_top] >= Fstack^[Fstack_top+1] then
1366 Fstack^[Fstack_top] := 1
1367 else
1368 Fstack^[Fstack_top] := 0;
1369 end;
1370
1371 RP_LTE : begin
1372 dec(Fstack_top);
1373 if Fstack^[Fstack_top] <= Fstack^[Fstack_top+1] then
1374 Fstack^[Fstack_top] := 1
1375 else
1376 Fstack^[Fstack_top] := 0;
1377 end;
1378
1379 RP_LT : begin
1380 dec(Fstack_top);
1381 if Fstack^[Fstack_top] < Fstack^[Fstack_top+1] then
1382 Fstack^[Fstack_top] := 1
1383 else
1384 Fstack^[Fstack_top] := 0;
1385 end;
1386
1387 RP_NOTEQ : begin
1388 dec(Fstack_top);
1389 if Fstack^[Fstack_top] <> Fstack^[Fstack_top+1] then
1390 Fstack^[Fstack_top] := 1
1391 else
1392 Fstack^[Fstack_top] := 0;
1393 end;
1394
1395 RP_ADD : begin
1396 dec(Fstack_top);
1397 Fstack^[Fstack_top] := Fstack^[Fstack_top] + Fstack^[Fstack_top+1];
1398 end;
1399
1400 RP_SUBTRACT : begin
1401 dec(Fstack_top);
1402 Fstack^[Fstack_top] := Fstack^[Fstack_top] - Fstack^[Fstack_top+1];
1403 end;
1404
1405 RP_MULTIPLY : begin
1406 dec(Fstack_top);
1407 Fstack^[Fstack_top] := Fstack^[Fstack_top] * Fstack^[Fstack_top+1];
1408 end;
1409
1410 RP_DIVIDE : begin
1411 dec(Fstack_top);
1412 { Let the user catch divide by zero errors ! }
1413 Fstack^[Fstack_top] := Fstack^[Fstack_top] / Fstack^[Fstack_top+1];
1414 end;
1415
1416 RP_POWER : begin
1417 dec(Fstack_top);
1418 Fstack^[Fstack_top] := power (Fstack^[Fstack_top], Fstack^[Fstack_top+1]);
1419 end;
1420 RP_SIN : Fstack^[Fstack_top] := sin (Fstack^[Fstack_top]*TrigF);
1421 RP_COS : Fstack^[Fstack_top] := cos (Fstack^[Fstack_top]*TrigF);
1422 RP_TAN : begin x := Fstack^[Fstack_top]*TrigF;
1423 Fstack^[Fstack_top] := sin(x)/cos(x) end;
1424
1425 RP_EXP : Fstack^[Fstack_top] := exp(Fstack^[Fstack_top]);
1426 RP_LOG : Fstack^[Fstack_top] := ln(Fstack^[Fstack_top]) * 0.4342944819032518;{ Log10 of e }
1427 RP_LN : Fstack^[Fstack_top] := ln(Fstack^[Fstack_top]);
1428 RP_SQR : Fstack^[Fstack_top] := sqr(Fstack^[Fstack_top]);
1429 RP_SQRT : Fstack^[Fstack_top] := sqrt(Fstack^[Fstack_top]);
1430
1431 RP_FACT : begin
1432 xi := round (Fstack^[Fstack_top]); x := 1.0;
1433 for k := 1 to xi do x := x * k;
1434 Fstack^[Fstack_top] := x;
1435 end;
1436
1437 RP_ARCSIN : begin x := Fstack^[Fstack_top];
1438 Fstack^[Fstack_top] := (ArcTan (x/(sqrt(1-sqr(x)))))/TrigF; end;
1439 RP_ARCCOS : begin x := Fstack^[Fstack_top];
1440 Fstack^[Fstack_top] := (ArcTan ((sqrt(1-sqr(x))/x)))/TrigF; end;
1441 RP_ARCTAN : Fstack^[Fstack_top] := (ArcTan (Fstack^[Fstack_top]))/TrigF;
1442
1443 RP_SINH : begin x := exp (Fstack^[Fstack_top]); Fstack^[Fstack_top] := (x - (1/x))/2; end;
1444 RP_COSH : begin x := exp (Fstack^[Fstack_top]); Fstack^[Fstack_top] := (x + (1/x))/2; end;
1445 RP_TANH : begin x := exp (2*Fstack^[Fstack_top]); Fstack^[Fstack_top] := (x-1)/(x+1); end;
1446
1447 RP_ARCSINH : Fstack^[Fstack_top] := ln(Fstack^[Fstack_top] + sqrt (sqr (Fstack^[Fstack_top]) + 1));
1448 RP_ARCCOSH : Fstack^[Fstack_top] := ln(Fstack^[Fstack_top] + sqrt (sqr (Fstack^[Fstack_top]) - 1));
1449 RP_ARCTANH : Fstack^[Fstack_top] := ln((1 + Fstack^[Fstack_top])/(1 - Fstack^[Fstack_top]))/2;
1450
1451 RP_UNARYMINUS : Fstack^[Fstack_top] := -Fstack^[Fstack_top];
1452
1453 RP_EQUALS : begin
1454 { assignment operation, result already on stack and
1455 right-hand side to follow in instruction stream as an
1456 operand pointer into symbol table }
1457 inc (i);
1458 SymTab.SetSymTabValue (p^[i].operand, Fstack^[Fstack_top]);
1459 { Direct method: (p^[i].operand)^.value := stack[stack_top];}
1460 symIndex := p^[i].operand;
1461 end;
1462 else
1463 raise EEvaluationError.Create ('Internal Evaluation Error: unrecognised operator');
1464 end;
1465 inc (i);
1466 until false;
1467 end;
1468
1469
1470
1471 end.