home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kolekce / d56 / DM2KVCL.ZIP / PARSER.PAS < prev    next >
Pascal/Delphi Source File  |  2001-08-25  |  35KB  |  1,203 lines
  1. {****************************************************************************}
  2. {                      Adapted for Data Master 2000                          }
  3. {             original parser code by G.W. van der Vegt (tfp_01)             }
  4. {****************************************************************************}
  5. unit Parser;
  6. {$B-,F+}
  7. interface
  8. uses Common, Windows{for GetTickCount}, SysUtils;
  9.  
  10. const
  11.  
  12.   tfp_true  = 1.0;                      {----REAL value for BOOLEAN TRUE     }
  13.   tfp_false = 0.0;                      {----REAL value for BOOLEAN FALSE    }
  14.   maxreal  = +1e4932;                   {----Internal maxreal                }
  15.   maxparm  = 200;                       {----Maximum number of parameters    }
  16.  
  17. type
  18.                                         {used internally by TMathParser:}
  19.   tfp_fname = STRING[32];               {----String name                     }
  20.   tfp_ftype = (tfp_noparm,              {----Function or Function()          }
  21.                tfp_1real,               {----Function(VAR r)                 }
  22.                tfp_2real,               {----Function(VAR r1,r2)             }
  23.                tfp_nreal,               {----Function(VAR r;n  INTEGER)      }
  24.                tfp_realvar,             {----Real VAR                        }
  25.                tfp_intvar,              {----Integer VAR                     }
  26.                tfp_boolvar,             {----Boolean VAR                     }
  27.                tfp_realstr);            {----Real String VAR                 }
  28.   fie      = RECORD
  29.                fname : tfp_fname;       {----Name of function or var         }
  30.                faddr : POINTER;         {----FAR POINTER to function or var  }
  31.                ftype : tfp_ftype;       {----Type of entry                   }
  32.              END;
  33.   fieptr   = ARRAY[1..1] OF fie;        {----Will be used as [1..maxfie]     }
  34.   real=TReal;    {redefine!}
  35.  
  36.   TMathParser=class(TObject)
  37.   private                            {global variables moved from from tfp_01}
  38.     fiearr: ^fieptr;                    {----Array of functions & vars       }
  39.     maxfie: INTEGER;                    {----max no of functions & vars      }
  40.     fiesiz: INTEGER;                    {----current no of functions & vars  }
  41.     Line: STRING;                       {----Internal copy of string to Parse}
  42.     Lp: INTEGER;                        {----Parsing Pointer into Line       }
  43.     Nextchar: CHAR;                     {----Character at Lp Postion         }
  44.     PROCEDURE Newchar;
  45.     PROCEDURE Skip;
  46.     FUNCTION Eval_number : REAL;
  47.     FUNCTION Eval_factor : REAL;
  48.     FUNCTION Eval_term : REAL;
  49.     FUNCTION Eval_subterm : REAL;
  50.     FUNCTION Eval_r_expr : REAL;
  51.     FUNCTION Eval_b_expr : REAL;
  52.   public
  53.     function Parse(S: string): TReal;{evaluates string, may raise exceptions!}
  54.     procedure Init(No: integer);     {allocates memory for params & functions}
  55.     procedure AddObject(a: pointer; n: tfp_fname; t: tfp_ftype);
  56.     procedure AddGonio;      {these procs add standard parameters & functions}
  57.     procedure AddLogic;
  58.     procedure AddMath;
  59.     procedure AddMisc;
  60.     procedure AddSpec;
  61.     procedure AddStdParams(Pars:PRealArray);
  62.     destructor Destroy; override;
  63.   end;
  64.  
  65.   EMathParser=class(Exception)
  66.     ErrorCode: integer;
  67.     constructor CreateCode(Code: integer);
  68.   end;
  69.  
  70.   procedure SetErrorCode(Code:byte); {must be called ONLY from user functions}
  71.  
  72. resourcestring
  73.   errMathParser1='Incorrect numeric format encountered';
  74.   errMathParser2='Undefined function or parameter';
  75.   errMathParser3='Missed "(" or ")"';
  76.   errMathParser4='Only integer power for negative base allowed';
  77.   errMathParser5='TAN((2n+1)*PI/2) is infinite';
  78.   errMathParser6='Unable to evaluate empty expression';
  79.   errMathParser7='Argument of LN must be strictly positive';
  80.   errMathParser8='Argument of SQRT must be positive';
  81.   errMathParser9='Parser detects division by zero';
  82.   errMathParser10='Too many functions and parameters';
  83.   errMathParser11='Parser detects overflow/underflow';
  84.   errMathParser12='Invalid characters in function name';
  85.   errMathParser13='UNEXPECTED ERROR!!!';
  86.   errMathParser14='Boolean expression error';
  87.   errMathParser15='Error evaluating function parameters';
  88.  
  89. implementation
  90.  
  91. {---------------------------------------------------------}
  92. {----Tricky stuff to call FUNCTIONS                       }
  93. {---------------------------------------------------------}
  94.  
  95. VAR
  96.   GluePtr : POINTER;
  97.   Tfp_ernr: byte;
  98.  
  99. type
  100.   TNoParam=function: real;
  101.   T1Real=function(var R1): real;
  102.   T2Real=function(var R1,R2): real;
  103.   TNReal=function(var R1,N): real;
  104.  
  105. procedure SetErrorCode(Code:byte);
  106. begin Tfp_ernr:=Code; end;
  107.  
  108. FUNCTION Call_noparm : REAL;
  109. begin Call_noparm:=TNoParam(GluePtr); end;
  110.  
  111. FUNCTION Call_1real(VAR r) : REAL;
  112. begin Call_1real:=T1Real(GluePtr)(r); end;
  113.  
  114. FUNCTION Call_2real(VAR r1,r2) : REAL;
  115. begin Call_2real:=T2Real(GluePtr)(r1,r2); end;
  116.  
  117. FUNCTION Call_nreal(VAR r,n) : REAL;
  118. begin Call_nreal:=TNReal(GluePtr)(r,n); end;
  119.  
  120. constructor EMathParser.CreateCode(Code: integer);   {same as parser's codes!}
  121. begin
  122.   ErrorCode:=Code;
  123.   case Code of
  124.     1: Message:=errMathParser1;
  125.     2: Message:=errMathParser2;
  126.     3: Message:=errMathParser3;
  127.     4: Message:=errMathParser4;
  128.     5: Message:=errMathParser5;
  129.     6: Message:=errMathParser6;
  130.     7: Message:=errMathParser7;
  131.     8: Message:=errMathParser8;
  132.     9: Message:=errMathParser9;
  133.     10: Message:=errMathParser10;
  134.     11: Message:=errMathParser11;
  135.     12: Message:=errMathParser12;
  136.     13: Message:=errMathParser13;
  137.     14: Message:=errMathParser14;
  138.     15: Message:=errMathParser15;
  139.   end;
  140. end;
  141.  
  142. {--- TMathParser ---}
  143. PROCEDURE TMathParser.AddStdParams(Pars:PRealArray);
  144. var i: integer;
  145. BEGIN
  146.   for i:=low(TColIndex) to High(TColIndex) do
  147.   AddObject(@pars^[i], char(byte('A')+I-low(TColIndex)), tfp_realvar);
  148. END;
  149.  
  150. function xGCX(var R: TReal; var N: integer): TReal;                {Gx,Gy->Zx}
  151. var Ar: TRealArray absolute R;                            {params: M,Fi,Gx,Gy}
  152. begin             {note! after getting |M|,Fi of cable we need use 1/|M|, -Fi}
  153.   if N=3 then Result:=GCompensation(Ar[1],Ar[2],Ar[3],Ar[4]).X
  154.   else tfp_ernr:=15;
  155. end;
  156.  
  157. function xGCY(var R: TReal; var N: integer): TReal;                {Gx,Gy->Zy}
  158. var Ar: TRealArray absolute R;
  159. begin
  160.   if N=3 then Result:=GCompensation(Ar[1],Ar[2],Ar[3],Ar[4]).Y
  161.   else tfp_ernr:=15;
  162. end;
  163.  
  164. function xOSCX(var R: TReal; var N: integer): TReal;      {rets real part (X)}
  165. var Ar: TRealArray absolute R;
  166. begin                                          {params: ZoX,ZoY,ZsX,ZsY,ZX,ZY}
  167.   if N=5 then Result:=OSCompensation(Ar[1],Ar[2],Ar[3],Ar[4],Ar[5],Ar[6]).X
  168.   else tfp_ernr:=15;
  169. end;
  170.  
  171. function xOSCY(var R: TReal; var N: integer): TReal;
  172. var Ar: TRealArray absolute R;
  173. begin                                          {params: ZoX,ZoY,ZsX,ZsY,ZX,ZY}
  174.   if N=5 then Result:=OSCompensation(Ar[1],Ar[2],Ar[3],Ar[4],Ar[5],Ar[6]).Y
  175.   else tfp_ernr:=15;
  176. end;
  177.  
  178. function xInvCX(var X,Y: TReal): TReal;
  179. begin Result:=InvC(MakeC(X,Y)).X; end;
  180.  
  181. function xInvCY(var X,Y: TReal): TReal;
  182. begin Result:=InvC(MakeC(X,Y)).Y; end;
  183.  
  184. {other:}
  185. function xTime: TReal;
  186. begin Result:=GetTickCount/1e3; end;
  187.  
  188. {Van der Paw Ro calculation}
  189. function xf_VDP(var Ra,Rb: TReal): TReal;               {returns formfactor f}
  190. begin Result:=VDP(Ra,Rb); end;
  191.  
  192. function xRo_VDP(var R: TReal; var N: integer): TReal;     {Ra,Rb[Ohm]; d[cm]}
  193. var Ar: TRealArray absolute R;
  194. begin
  195. {NOTE! parameters are enumerated 0..N!!! i.e., n+1}
  196.   if N=2 then Result:=Pi*Ar[3]*(Ar[1]+Ar[2])/2/xf_VDP(Ar[1],Ar[2])
  197.   else tfp_ernr:=15;
  198. end;
  199.  
  200. {ADD routine:}
  201. procedure TMathParser.AddSpec;
  202. begin
  203.   addobject(@xTime,'Time',tfp_noparm);
  204.   addobject(@xf_VDP,'f_VDP',tfp_2real);
  205.   addobject(@xRo_VDP,'Ro_VDP',tfp_nreal);
  206.   addobject(@xGCX,'GCX',tfp_nreal);
  207.   addobject(@xGCY,'GCY',tfp_nreal);
  208.   addobject(@xOSCX,'OSCX',tfp_nreal);
  209.   addobject(@xOSCY,'OSCY',tfp_nreal);
  210.   addobject(@xInvCX,'InvCX',tfp_2real);
  211.   addobject(@xInvCY,'InvCY',tfp_2real);
  212. end;
  213.  
  214. {============================================================================}
  215. {======= all the rest of unit copied directly from tfp_01 ===================}
  216. {============================================================================}
  217. {---------------------------------------------------------}
  218. {----This routine skips one character                     }
  219. {---------------------------------------------------------}
  220.  
  221. PROCEDURE TMathParser.Newchar;
  222.  
  223. BEGIN
  224.   IF (lp<LENGTH(Line))
  225.     THEN INC(Lp);
  226.   Nextchar:=UPCASE(Line[Lp]);
  227. END;
  228.  
  229. {---------------------------------------------------------}
  230. {----This routine skips one character and                 }
  231. {    all folowing spaces from an expression               }
  232. {---------------------------------------------------------}
  233.  
  234. PROCEDURE TMathParser.Skip;
  235.  
  236. BEGIN
  237.   REPEAT
  238.     Newchar;
  239.   UNTIL (Nextchar<>' ');
  240. END;
  241.  
  242. {---------------------------------------------------------}
  243. {  Number     = Real    (Bv 23.4E-5)                      }
  244. {               Integer (Bv -45)                          }
  245. {---------------------------------------------------------}
  246.  
  247. FUNCTION TMathParser.Eval_number : REAL;
  248.  
  249. VAR
  250.   Temp  : STRING;
  251.   Err   : INTEGER;
  252.   value : REAL;
  253.  
  254. BEGIN
  255. {----Correct .xx to 0.xx}
  256.   IF (Nextchar='.')
  257.     THEN Temp:='0'+Nextchar
  258.     ELSE Temp:=Nextchar;
  259.  
  260.   Newchar;
  261.  
  262. {----Correct ±.xx to ±0.xx}
  263.   IF (LENGTH(temp)=1) AND (Temp[1] IN ['+','-']) AND (Nextchar='.')
  264.     THEN Temp:=Temp+'0';
  265.  
  266.   WHILE Nextchar IN ['0'..'9','.','E'] DO
  267.     BEGIN
  268.       Temp:=Temp+Nextchar;
  269.       IF (Nextchar='E')
  270.         THEN
  271.           BEGIN
  272.           {----Correct ±xxx.E to ±xxx.0E}
  273.             IF (Temp[LENGTH(Temp)-1]='.')
  274.               THEN INSERT('0',Temp,LENGTH(Temp));
  275.             Newchar;
  276.             IF (Nextchar IN ['+','-'])
  277.               THEN
  278.                 BEGIN
  279.                   Temp:=Temp+Nextchar;
  280.                   Newchar;
  281.                 END;
  282.           END
  283.         ELSE Newchar;
  284.     END;
  285.  
  286. {----Skip trailing spaces}
  287.   IF (line[lp]=' ')
  288.     THEN WHILE (Line[lp]=' ') DO INC(lp);
  289.   nextchar:=line[lp];
  290.  
  291. {----Correct ±xx. to ±xx.0 but NOT ±xxE±yy.}
  292.   IF (temp[LENGTH(temp)]='.') AND
  293.      (POS('E',temp)=0)
  294.     THEN Temp:=Temp+'0';
  295.  
  296.   VAL(Temp,value,Err);
  297.  
  298.   IF (Err<>0) THEN tfp_ernr:=1;
  299.  
  300.   IF (tfp_ernr=0)
  301.     THEN Eval_number:=value
  302.     ELSE Eval_number:=0;
  303. END;
  304.  
  305. {---------------------------------------------------------}
  306. {  Factor     = Number                                    }
  307. {    (External) Function()                                }
  308. {    (External) Function(Expr)                            }
  309. {    (External) Function(Expr,Expr)                       }
  310. {     External  Var Real                                  }
  311. {     External  Var Integer                               }
  312. {     External  Var Boolean                               }
  313. {     External  Var realstring                            }
  314. {               (R_Expr)                                  }
  315. {---------------------------------------------------------}
  316.  
  317. FUNCTION TMathParser.Eval_factor : REAL;
  318.  
  319. VAR
  320.   ferr    : BOOLEAN;
  321.   param   : INTEGER;
  322.   dummy   : ARRAY[0..maxparm] OF REAL;
  323.   value,
  324.   dummy1,
  325.   dummy2  : REAL;
  326.   temp    : tfp_fname;
  327.   e,
  328.   index   : INTEGER;
  329.   temps   : STRING;
  330.  
  331. BEGIN
  332.   CASE Nextchar OF
  333.     '+'  : BEGIN
  334.              Newchar;
  335.              value:=+Eval_factor;
  336.            END;
  337.     '-'  : BEGIN
  338.              Newchar;
  339.              value:=-Eval_factor;
  340.            END;
  341.  
  342.     '0'..'9',
  343.     '.'  : value:=Eval_number;
  344.     'A'..'Z'
  345.          : BEGIN
  346.              ferr:=TRUE;
  347.              Temp:=Nextchar;
  348.              Skip;
  349.              WHILE Nextchar IN ['0'..'9','_','A'..'Z'] DO
  350.                BEGIN
  351.                  Temp:=Temp+Nextchar;
  352.                  Skip;
  353.                END;
  354.  
  355.            {----Seek function and CALL it}
  356.              {$R-}
  357.              FOR Index:=1 TO Fiesiz DO
  358.                WITH fiearr^[index] DO
  359.                  IF (fname=temp)
  360.                    THEN
  361.                      BEGIN
  362.                        ferr:=FALSE;
  363.  
  364.                        CASE ftype OF
  365.  
  366.                        {----Function or Function()}
  367.                          tfp_noparm  : IF (nextchar='(')
  368.                                         THEN
  369.                                           BEGIN
  370.                                             Skip;
  371.  
  372.                                             IF (nextchar<>')')
  373.                                               THEN tfp_ernr:=15;
  374.  
  375.                                             Skip;
  376.                                           END;
  377.  
  378.                        {----Function(r)}
  379.                          tfp_1real   : IF (nextchar='(')
  380.                                          THEN
  381.                                            BEGIN
  382.                                              Skip;
  383.  
  384.                                              dummy1:=Eval_b_expr;
  385.  
  386.                                              IF (tfp_ernr=0) AND
  387.                                                 (nextchar<>')')
  388.                                                THEN tfp_ernr:=15;
  389.  
  390.                                              Skip; {----Dump the ')'}
  391.                                            END
  392.                                          ELSE tfp_ernr:=15;
  393.  
  394.                        {----Function(r1,r2)}
  395.                          tfp_2real   : IF (nextchar='(')
  396.                                          THEN
  397.                                            BEGIN
  398.                                              Skip;
  399.  
  400.                                              dummy1:=Eval_b_expr;
  401.  
  402.                                              IF (tfp_ernr=0) AND
  403.                                                 (nextchar<>',')
  404.                                                THEN tfp_ernr:=15;
  405.  
  406.                                              Skip; {----Dump the ','}
  407.                                              dummy2:=Eval_b_expr;
  408.  
  409.                                               IF (tfp_ernr=0) AND
  410.                                                  (nextchar<>')')
  411.                                                 THEN tfp_ernr:=15;
  412.  
  413.                                               Skip; {----Dump the ')'}
  414.                                             END
  415.                                           ELSE tfp_ernr:=15;
  416.  
  417.                        {----Function(r,n)}
  418.                          tfp_nreal   : IF (nextchar='(')
  419.                                          THEN
  420.                                            BEGIN
  421.                                              param:=0;
  422.  
  423.                                              Skip;
  424.                                              dummy[param]:=Eval_b_expr;
  425.  
  426.                                              IF (tfp_ernr=0) AND
  427.                                                 (nextchar<>',')
  428.                                                THEN tfp_ernr:=15
  429.                                                ELSE
  430.                                                  WHILE (tfp_ernr=0) AND
  431.                                                        (nextchar=',') AND
  432.                                                        (param<maxparm) DO
  433.                                                    BEGIN
  434.                                                      Skip; {----Dump the ','}
  435.                                                      INC(param);
  436.                                                      dummy[param]:=Eval_b_expr;
  437.                                                    END;
  438.  
  439.                                              IF (tfp_ernr=0) AND
  440.                                                 (nextchar<>')')
  441.                                                THEN tfp_ernr:=15;
  442.  
  443.                                              Skip; {----Dump the ')'}
  444.                                            END
  445.                                          ELSE tfp_ernr:=15;
  446.                        {----Real Var}
  447.                          tfp_realvar    : dummy1:=REAL(faddr^);
  448.  
  449.                        {----Integer Var}
  450.                          tfp_intvar     : dummy1:=1.0*INTEGER(faddr^);
  451.  
  452.                        {----Boolean Var}
  453.                          tfp_boolvar    : dummy1:=1.0*ORD(BOOLEAN(faddr^));
  454.  
  455.                        {----Real string Var}
  456.                          tfp_realstr    : BEGIN
  457.                                              temps:=STRING(faddr^);
  458.  
  459.                                            {----Delete Leading Spaces}
  460.                                              WHILE (Length(temps)>0) AND
  461.                                                    (temps[1]=' ') DO
  462.                                                Delete(temps,1,1);
  463.  
  464.                                            {----Delete Trailing Spaces}
  465.                                              WHILE (Length(temps)>0) AND
  466.                                                    (temps[Length(temps)]=' ') Do
  467.                                                Delete(temps,Length(temps),1);
  468.  
  469.                                           {----Correct .xx to 0.xx}
  470.                                              IF (LENGTH(temps)>=1)  AND
  471.                                                 (LENGTH(temps)<255) AND
  472.                                                 (temps[1]='.')
  473.                                                THEN Insert('0',temps,1);
  474.  
  475.                                            {----Correct ±.xx to ±0.xx}
  476.                                              IF (LENGTH(temps)>=2) AND
  477.                                                 (LENGTH(temps)<255) AND
  478.                                                 (temps[1] IN ['+','-']) AND
  479.                                                 (temps[2]='.')
  480.                                                THEN Insert('0',temps,2);
  481.  
  482.                                            {----Correct xx.Eyy to xx0.Exx}
  483.                                              IF (Pos('.E',temps)>0) AND
  484.                                                 (Length(temps)<255)
  485.                                                THEN Insert('0',temps,Pos('.E',temps));
  486.  
  487.                                            {----Correct xx.eyy to xx0.exx}
  488.                                              IF (Pos('.e',temps)>0) AND
  489.                                                 (Length(temps)<255)
  490.                                                THEN Insert('0',temps,Pos('.e',temps));
  491.                                            {----Correct ±xx. to ±xx.0 but NOT ±}
  492.                                              IF (temps[LENGTH(temps)]='.') AND
  493.                                                 (POS('E',temps)=0) AND
  494.                                                 (POS('e',temps)=0) AND
  495.                                                 (Length(temps)<255)
  496.                                                THEN Temps:=Temps+'0';
  497.  
  498.                                              VAL(temps,dummy1,e);
  499.                                              IF (e<>0)
  500.                                                THEN tfp_ernr:=1;
  501.                                            END;
  502.                        END;
  503.  
  504.                        IF (tfp_ernr=0)
  505.                          THEN
  506.                            BEGIN
  507.                              glueptr:=faddr;
  508.  
  509.                              CASE ftype OF
  510.                                tfp_noparm   : value:=call_noparm;
  511.                                tfp_1real    : value:=call_1real(dummy1);
  512.                                tfp_2real    : value:=call_2real(dummy1,dummy2);
  513.                                tfp_nreal    : value:=call_nreal(dummy,param);
  514.                                tfp_realvar,
  515.                                tfp_intvar,
  516.                                tfp_boolvar,
  517.                                tfp_realstr  : value:=dummy1;
  518.                              END;
  519.                            END;
  520.                      END;
  521.              IF (ferr=TRUE)
  522.                THEN tfp_ernr:=2;
  523.  
  524.              {$R+}
  525.            END;
  526.  
  527.     '('  : BEGIN
  528.              Skip;
  529.  
  530.              value:=Eval_b_expr;
  531.  
  532.              IF (tfp_ernr=0) AND (nextchar<>')') THEN tfp_ernr:=3;
  533.  
  534.              Skip; {----Dump the ')'}
  535.            END;
  536.  
  537.     ELSE tfp_ernr:=2;
  538.   END;
  539.  
  540.   IF (tfp_ernr=0)
  541.     THEN Eval_factor:=value
  542.     ELSE Eval_factor:=0;
  543.  
  544. END;
  545.  
  546. {---------------------------------------------------------}
  547. {  Term       = Factor ^ Factor                           }
  548. {---------------------------------------------------------}
  549.  
  550. FUNCTION TMathParser.Eval_term : REAL;
  551.  
  552. VAR
  553.   value,
  554.   Exponent,
  555.   dummy,
  556.   Base      : REAL;
  557.  
  558. BEGIN
  559.   value:=Eval_factor;
  560.  
  561.   WHILE (tfp_ernr=0) AND (Nextchar='^') DO
  562.     BEGIN
  563.       Skip;
  564.  
  565.       Exponent:=Eval_factor;
  566.  
  567.       Base:=value;
  568.       IF (tfp_ernr=0) AND (Base=0)
  569.         THEN value:=0
  570.         ELSE
  571.           BEGIN
  572.  
  573.           {----Over/Underflow Protected}
  574.             dummy:=Exponent*LN(ABS(Base));
  575.             IF (dummy<=LN(MAXREAL))
  576.                THEN value:=EXP(dummy)
  577.                ELSE tfp_ernr:=11;
  578.           END;
  579.  
  580.       IF (tfp_ernr=0) AND (Base<0)
  581.         THEN
  582.           BEGIN
  583.           {----allow only whole number exponents}
  584.             IF (INT(Exponent)<>Exponent) THEN tfp_ernr:=4;
  585.  
  586.             IF (tfp_ernr=0) AND ODD(ROUND(exponent)) THEN value:=-value;
  587.           END;
  588.     END;
  589.  
  590.   IF (tfp_ernr=0)
  591.     THEN Eval_term:=value
  592.     ELSE Eval_term:=0;
  593. END;
  594.  
  595. {---------------------------------------------------------}
  596. {----Subterm  = Term * Term                               }
  597. {               Term / Term                               }
  598. {---------------------------------------------------------}
  599.  
  600. FUNCTION TMathParser.Eval_subterm : REAL;
  601.  
  602. VAR
  603.   value,
  604.   dummy  : REAL;
  605.  
  606. BEGIN
  607.   value:=Eval_term;
  608.  
  609.   WHILE (tfp_ernr=0) AND (Nextchar IN ['*','/']) DO
  610.     CASE Nextchar OF
  611.  
  612.     {----Over/Underflow Protected}
  613.       '*' : BEGIN
  614.               Skip;
  615.  
  616.               dummy:=Eval_term;
  617.  
  618.               IF (tfp_ernr<>0) OR (value=0) OR (dummy=0)
  619.                 THEN value:=0
  620.                 ELSE IF (ABS( LN(ABS(value)) + LN(ABS(dummy)) )<LN(Maxreal))
  621.                   THEN value:= value * dummy
  622.                   ELSE tfp_ernr:=11;
  623.             END;
  624.  
  625.     {----Over/Underflow Protected}
  626.       '/' : BEGIN
  627.               Skip;
  628.  
  629.               dummy:=Eval_term;
  630.  
  631.               IF (tfp_ernr=0)
  632.                 THEN
  633.                   BEGIN
  634.  
  635.                   {----Division by ZERO Protected}
  636.                     IF (dummy<>0)
  637.                       THEN
  638.                         BEGIN
  639.                         {----Underflow Protected}
  640.                           IF (value<>0)
  641.                             THEN
  642.                               IF (ABS( LN(ABS(value))-LN(ABS(dummy)) )
  643.                                  <LN(Maxreal))
  644.                                 THEN value:=value/dummy
  645.                                 ELSE tfp_ernr:=11
  646.                         END
  647.                       ELSE tfp_ernr:=9;
  648.                   END;
  649.             END;
  650.     END;
  651.  
  652.   IF (tfp_ernr=0)
  653.     THEN Eval_subterm:=value
  654.     ELSE Eval_subterm:=0;
  655. END;
  656.  
  657. {---------------------------------------------------------}
  658. {  Real Expr  = Subterm + Subterm                         }
  659. {               Subterm - Subterm                         }
  660. {---------------------------------------------------------}
  661.  
  662. FUNCTION TMathParser.Eval_r_expr : REAL;
  663.  
  664. VAR
  665.   dummy,
  666.   dummy2,
  667.   value : REAL;
  668.  
  669. BEGIN
  670.   value:=Eval_subterm;
  671.  
  672.   WHILE (tfp_ernr=0) AND (Nextchar IN ['+','-']) DO
  673.     CASE Nextchar OF
  674.  
  675.       '+' : BEGIN
  676.               Skip;
  677.  
  678.               dummy:=Eval_subterm;
  679.  
  680.               IF (tfp_ernr=0)
  681.                 THEN
  682.                   BEGIN
  683.  
  684.                   {----Overflow Protected}
  685.                     IF (ABS( (value/10)+(dummy/10) )<(Maxreal/10))
  686.                       THEN value:=value+dummy
  687.                       ELSE tfp_ernr:=11;
  688.                   END;
  689.             END;
  690.  
  691.       '-' : BEGIN
  692.               Skip;
  693.               dummy2:=value;
  694.  
  695.               dummy:=Eval_subterm;
  696.  
  697.               IF (tfp_ernr=0)
  698.                 THEN
  699.                   BEGIN
  700.  
  701.                   {----Overflow Protected}
  702.                     IF (ABS( (value/10)-(dummy/10) )<(Maxreal/10))
  703.                       THEN value:=value-dummy
  704.                       ELSE tfp_ernr:=11;
  705.  
  706.                   {----Underflow Protected}
  707.                     IF (value=0) AND (dummy<>dummy2)
  708.                       THEN tfp_ernr:=11;
  709.                   END;
  710.  
  711.             END;
  712.     END;
  713.  
  714. {----At this point the current char must be
  715.         1. the EOLN marker or
  716.         2. a right bracket
  717.         3. start of a boolean operator }
  718.  
  719.   IF NOT (Nextchar IN [#00,')','>','<','=',','])
  720.     THEN tfp_ernr:=2;
  721.  
  722.   IF (tfp_ernr=0)
  723.     THEN Eval_r_expr:=value
  724.     ELSE Eval_r_expr:=0;
  725. END;
  726.  
  727. {---------------------------------------------------------}
  728. {  Boolean Expr  = R_Expr <  R_Expr                       }
  729. {                  R_Expr <= R_Expr                       }
  730. {                  R_Expr <> R_Expr                       }
  731. {                  R_Expr =  R_Expr                       }
  732. {                  R_Expr >= R_Expr                       }
  733. {                  R_Expr >  R_Expr                       }
  734. {---------------------------------------------------------}
  735.  
  736. FUNCTION TMathParser.Eval_b_expr : REAL;
  737.  
  738. VAR
  739.   value : REAL;
  740.  
  741. BEGIN
  742.   value:=Eval_r_expr;
  743.  
  744.   IF (tfp_ernr=0) AND (Nextchar IN ['<','>','='])
  745.     THEN
  746.       CASE Nextchar OF
  747.  
  748.         '<' : BEGIN
  749.                 Skip;
  750.                 IF (Nextchar IN ['>','='])
  751.                   THEN
  752.                     CASE Nextchar OF
  753.                       '>' : BEGIN
  754.                               Skip;
  755.                               IF (value<>Eval_r_expr)
  756.                                 THEN value:=tfp_true
  757.                                 ELSE value:=tfp_false;
  758.                             END;
  759.                       '=' : BEGIN
  760.                               Skip;
  761.                               IF (value<=Eval_r_expr)
  762.                                 THEN value:=tfp_true
  763.                                 ELSE value:=tfp_false;
  764.                             END;
  765.                     END
  766.                   ELSE
  767.                     BEGIN
  768.                       IF (value<Eval_r_expr)
  769.                         THEN value:=tfp_true
  770.                         ELSE value:=tfp_false;
  771.                     END;
  772.               END;
  773.  
  774.         '>' : BEGIN
  775.                 Skip;
  776.                 IF (Nextchar='=')
  777.                   THEN
  778.                     BEGIN
  779.                       Skip;
  780.                       IF (value>=Eval_r_expr)
  781.                         THEN value:=tfp_true
  782.                         ELSE value:=tfp_false;
  783.                     END
  784.                   ELSE
  785.                     BEGIN
  786.                       IF (value>Eval_r_expr)
  787.                         THEN value:=tfp_true
  788.                         ELSE value:=tfp_false;
  789.                     END;
  790.               END;
  791.         '=' : BEGIN
  792.                 Skip;
  793.                 IF (value=Eval_r_expr)
  794.                   THEN value:=tfp_true
  795.                   ELSE value:=tfp_false;
  796.               END;
  797.       END;
  798.  
  799.   IF (tfp_ernr=0)
  800.     THEN Eval_b_expr:=value
  801.     ELSE Eval_b_expr:=0.0;
  802. END;
  803.  
  804. {---------------------------------------------------------}
  805. {----Internal Functions                                   }
  806. {---------------------------------------------------------}
  807.  
  808. {$F+}
  809. FUNCTION xABS(VAR r : REAL) : REAL;
  810.  
  811. BEGIN
  812.  xabs:=ABS(r);
  813. END;
  814.  
  815. FUNCTION xAND(VAR r;VAR n : INTEGER) : REAL;
  816.  
  817. TYPE
  818.   tmp   = ARRAY[0..0] OF REAL;
  819.  
  820. VAR
  821.   x     : REAL;
  822.   i     : INTEGER;
  823.  
  824. BEGIN
  825. {$R-}
  826.   FOR i:=0 TO n DO
  827.     IF (tmp(r)[i]<>tfp_false) AND (tmp(r)[i]<>tfp_true)
  828.       THEN
  829.         BEGIN
  830.           IF (tfp_ernr=0)
  831.             THEN tfp_ernr:=14;
  832.         END;
  833.    IF (tfp_ernr=0) AND (n>0)
  834.      THEN
  835.        BEGIN
  836.          x:=tfp_true*ORD(tmp(r)[0]=tfp_true);
  837.          FOR i:=1 TO n DO
  838.            x:=tfp_true*ORD((x=tfp_true) AND (tmp(r)[i]=tfp_true))
  839.        END
  840.      ELSE tfp_ernr:=15;
  841.   IF tfp_ernr=0
  842.     THEN xAND:=x
  843.     ELSE xAND:=0.0;
  844. {$R+}
  845. END;
  846.  
  847. FUNCTION xARCTAN(VAR r : REAL) : REAL;
  848.  
  849. BEGIN
  850.   xARCTAN:=ARCTAN(r);
  851. END;
  852.  
  853. FUNCTION xCOS(VAR r : REAL) : REAL;
  854.  
  855. BEGIN
  856.   xCOS:=COS(r);
  857. END;
  858.  
  859. FUNCTION xDEG(VAR r : REAL) : REAL;
  860.  
  861. BEGIN
  862.   xDEG:=(r/pi)*180;
  863. END;
  864.  
  865. {FUNCTION xE : REAL;
  866.  
  867. BEGIN
  868.   xE:=EXP(1);
  869. END;}
  870.  
  871. FUNCTION xEXP(VAR r : REAL) : REAL;
  872.  
  873. BEGIN
  874.   xEXP:=0;
  875.   IF (ABS(r)<LN(MAXREAL))
  876.     THEN xEXP:=EXP(r)
  877.     ELSE tfp_ernr:=11;
  878. END;
  879.  
  880. FUNCTION xFALSE : REAL;
  881.  
  882. BEGIN
  883.   xFALSE:=tfp_false;
  884. END;
  885.  
  886. FUNCTION xFRAC(VAR r : REAL) : REAL;
  887.  
  888. BEGIN
  889.   xFRAC:=FRAC(r);
  890. END;
  891.  
  892. FUNCTION xINT(VAR r : REAL) : REAL;
  893.  
  894. BEGIN
  895.   xINT:=INT(r);
  896. END;
  897.  
  898. FUNCTION xLN(VAR r : REAL) : REAL;
  899.  
  900. BEGIN
  901.   xLN:=0;
  902.   IF (r>0)
  903.     THEN xLN:=LN(r)
  904.     ELSE tfp_ernr:=7;
  905. END;
  906.  
  907. FUNCTION xLOG(VAR r : REAL) : REAL;
  908.  
  909. BEGIN
  910.   xLOG:=0;
  911.   IF (r>0)
  912.     THEN xLOG:=LN(r)/LN(10)
  913.     ELSE tfp_ernr:=7;
  914. END;
  915.  
  916. FUNCTION xMAX(VAR r;VAR n : INTEGER) : REAL;
  917.  
  918. TYPE
  919.   tmp   = ARRAY[0..0] OF REAL;
  920.  
  921. VAR
  922.   max   : REAL;
  923.   i     : INTEGER;
  924.  
  925. BEGIN
  926. {$R-}
  927.   max:=tmp(r)[0];
  928.   FOR i:=1 TO n DO
  929.     IF (tmp(r)[i]>max)
  930.       THEN max:=tmp(r)[i];
  931.   xMAX:=max;
  932. {$R+}
  933. END;
  934.  
  935. FUNCTION xMIN(VAR r;VAR n : INTEGER) : REAL;
  936.  
  937. TYPE
  938.   tmp   = ARRAY[0..0] OF REAL;
  939.  
  940. VAR
  941.   min   : REAL;
  942.   i     : INTEGER;
  943.  
  944. BEGIN
  945. {$R-}
  946.   min:=tmp(r)[0];
  947.   FOR i:=1 TO n DO
  948.     IF (tmp(r)[i]<min)
  949.       THEN min:=tmp(r)[i];
  950.   xMIN:=min;
  951. {$R+}
  952. END;
  953. FUNCTION xIOR(VAR r;VAR n : INTEGER) : REAL;
  954.  
  955. TYPE
  956.   tmp   = ARRAY[0..0] OF REAL;
  957.  
  958. VAR
  959.   x     : REAL;
  960.   i     : INTEGER;
  961.  
  962. BEGIN
  963. {$R-}
  964.   FOR i:=0 TO n DO
  965.     IF (tmp(r)[i]<>tfp_false) AND (tmp(r)[i]<>tfp_true)
  966.       THEN
  967.         BEGIN
  968.           IF (tfp_ernr=0)
  969.             THEN tfp_ernr:=14;
  970.         END;
  971.    IF (tfp_ernr=0) AND (n>0)
  972.      THEN
  973.        BEGIN
  974.          x:=tfp_true*ORD(tmp(r)[0]=tfp_true);
  975.          FOR i:=1 TO n DO
  976.            x:=tfp_true*ORD((x=tfp_true) OR (tmp(r)[i]=tfp_true))
  977.        END
  978.      ELSE tfp_ernr:=15;
  979.   IF tfp_ernr=0
  980.     THEN xIOR:=x
  981.     ELSE xIOR:=0.0;
  982. {$R+}
  983. END;
  984.  
  985. FUNCTION xPI : REAL;
  986.  
  987. BEGIN
  988.   xPI:=PI;
  989. END;
  990.  
  991. function xRANDOM: real;           {added by RRR; rets 0..1}
  992. begin xRANDOM:=RANDOM; end;
  993.  
  994. FUNCTION xRAD(VAR r : REAL) : REAL;
  995.  
  996. BEGIN
  997.   xRAD:=(r/180)*pi;
  998. END;
  999.  
  1000. FUNCTION xROUND(VAR r : REAL) : REAL;
  1001.  
  1002. BEGIN
  1003.   xROUND:=ROUND(r);
  1004. END;
  1005.  
  1006. FUNCTION xSGN(VAR r : REAL) : REAL;
  1007.  
  1008. BEGIN
  1009.   IF (r>=0)
  1010.     THEN xSgn:=+1
  1011.     ELSE xSgn:=-1;
  1012. END;
  1013.  
  1014. FUNCTION xSIN(VAR r : REAL) : REAL;
  1015.  
  1016. BEGIN
  1017.   xSIN:=SIN(r);
  1018. END;
  1019.  
  1020. FUNCTION xSQR(VAR r : REAL) : REAL;
  1021.  
  1022. BEGIN
  1023.   xSQR:=0; if r=0 then Exit;
  1024.   IF ( ABS(2*LN(ABS(r))) )<LN(MAXREAL)
  1025.     THEN xSQR:=EXP( 2*LN(ABS(r)) )
  1026.     ELSE tfp_ernr:=11;
  1027. END;
  1028.  
  1029. FUNCTION xSQRT(VAR r : REAL) : REAL;
  1030.  
  1031. BEGIN
  1032.   xSQRT:=0;
  1033.   IF (r>=0)
  1034.     THEN xSQRT:=SQRT(r)
  1035.     ELSE tfp_ernr:=8;
  1036. END;
  1037.  
  1038. FUNCTION xTAN(VAR r : REAL) : REAL;
  1039.  
  1040. BEGIN
  1041.   xTAN:=0;
  1042.   IF (COS(r)=0)
  1043.     THEN tfp_ernr:=5
  1044.     ELSE xTAN:=SIN(r)/COS(r);
  1045. END;
  1046.  
  1047. FUNCTION xTRUE : REAL;
  1048.  
  1049. BEGIN
  1050.   xTRUE:=tfp_true;
  1051. END;
  1052.  
  1053. FUNCTION xXOR(VAR r1,r2 : REAL) : REAL;
  1054.  
  1055. BEGIN
  1056.  IF ((r1<>tfp_false) AND (r1<>tfp_true)) OR
  1057.     ((r2<>tfp_false) AND (r2<>tfp_true))
  1058.    THEN
  1059.      BEGIN
  1060.        IF (tfp_ernr=0)
  1061.          THEN tfp_ernr:=14;
  1062.      END
  1063.    ELSE xxor:=tfp_true*ORD((r1=tfp_true) XOR (r2=tfp_true));
  1064. END;
  1065.  
  1066. {===========================================================================}
  1067.  
  1068. PROCEDURE TMathParser.init(no : INTEGER);
  1069.  
  1070. BEGIN
  1071.   IF (maxfie>0)
  1072.     THEN FREEMEM(fiearr,maxfie*SIZEOF(fiearr^));
  1073.  
  1074.   GETMEM(fiearr,no*SIZEOF(fiearr^));
  1075.  
  1076.   maxfie:=no;
  1077.   fiesiz:=0;
  1078. END;
  1079.  
  1080. destructor TMathParser.Destroy;
  1081. begin
  1082.   if (maxfie>0) then FreeMem(fiearr,maxfie*SIZEOF(fiearr^));
  1083.   maxfie:=0;fiesiz:=0;
  1084. end;
  1085.  
  1086. {---------------------------------------------------------}
  1087.  
  1088. FUNCTION TMathParser.parse(s : string) : REAL;
  1089.  
  1090. VAR
  1091.   i,h     : INTEGER;
  1092.   value   : REAL;
  1093.  
  1094. BEGIN
  1095.   tfp_ernr:=0;
  1096.  
  1097. {----Test for match on numbers of ( and ) }
  1098.   h:=0;
  1099.   FOR i:=1 TO LENGTH(s) DO
  1100.     CASE s[i] OF
  1101.       '(' : INC(h);
  1102.       ')' : DEC(h);
  1103.     END;
  1104.  
  1105.   IF (h=0)
  1106.     THEN
  1107.       BEGIN
  1108.  
  1109.       {----Continue init}
  1110.         lp:=0;
  1111.  
  1112.       {----Add a CHR(0) as an EOLN marker}
  1113.         line:=S+#00;
  1114.         Skip;
  1115.  
  1116.       {----Try parsing if any characters left}
  1117.         IF (Line[Lp]<>#00)
  1118.           THEN value:=Eval_b_expr
  1119.           ELSE tfp_ernr:=6;
  1120.       END
  1121.     ELSE tfp_ernr:=3;
  1122.  
  1123.   IF (tfp_ernr<>0)
  1124.     THEN parse:=0.0
  1125.     ELSE parse:=value;
  1126.   if tfp_ernr<>0 then raise EMathParser.CreateCode(tfp_ernr);  {added by RRR!}
  1127. END;
  1128.  
  1129. PROCEDURE TMathParser.addobject(a : pointer;n : tfp_fname;t : tfp_ftype);
  1130.  
  1131. VAR
  1132.   i : INTEGER;
  1133.  
  1134. BEGIN
  1135.   {$R-}
  1136.   IF (fiesiz<maxfie)
  1137.     THEN
  1138.       BEGIN
  1139.         INC(fiesiz);
  1140.         WITH fiearr^[fiesiz] DO
  1141.           BEGIN
  1142.             faddr:=a;
  1143.             fname:=n;
  1144.             FOR i:=1 TO LENGTH(fname) DO
  1145.               IF (UPCASE(fname[i]) IN ['0'..'9','_','A'..'Z'])
  1146.                 THEN fname[i]:=UPCASE(fname[i])
  1147.                 ELSE tfp_ernr:=12;
  1148.               IF (LENGTH(fname)>0) AND
  1149.                  NOT (fname[1] IN ['A'..'Z'])
  1150.                 THEN tfp_ernr:=12;
  1151.               ftype:=t;
  1152.           END
  1153.       END
  1154.     ELSE tfp_ernr:=10
  1155.   {$R+}
  1156. END;
  1157.  
  1158. {------------------ Adding routines ----------------------}
  1159.  
  1160. PROCEDURE TMathParser.addgonio;
  1161. BEGIN
  1162.   AddObject(@xARCTAN,'ARCTAN',tfp_1real);
  1163.   AddObject(@xCOS   ,'COS'   ,tfp_1real);
  1164.   AddObject(@xDEG   ,'DEG'   ,tfp_1real);
  1165.   AddObject(@xPI    ,'PI'    ,tfp_noparm);
  1166.   AddObject(@xRAD   ,'RAD'   ,tfp_1real);
  1167.   AddObject(@xSIN   ,'SIN'   ,tfp_1real);
  1168.   AddObject(@xTAN   ,'TAN'   ,tfp_1real);
  1169. END;
  1170.  
  1171. PROCEDURE TMathParser.addlogic;
  1172. BEGIN
  1173.   AddObject(@xAND   ,'AND'   ,tfp_nreal);
  1174.   AddObject(@xFALSE ,'FALSE' ,tfp_noparm);
  1175.   AddObject(@xIOR   ,'OR'    ,tfp_nreal);
  1176.   AddObject(@xTRUE  ,'TRUE'  ,tfp_noparm);
  1177.   AddObject(@xXOR   ,'XOR'   ,tfp_2real);
  1178. END;
  1179.  
  1180. PROCEDURE TMathParser.addmath;
  1181. BEGIN
  1182.   AddObject(@xABS   ,'ABS'   ,tfp_1real);
  1183.   AddObject(@xEXP   ,'EXP'   ,tfp_1real);
  1184. {  AddObject(@xE     ,'E'     ,tfp_noparm);}
  1185.   AddObject(@xRANDOM,'RANDOM',tfp_noparm);
  1186.   AddObject(@xLN    ,'LN'    ,tfp_1real);
  1187.   AddObject(@xLOG   ,'LOG'   ,tfp_1real);
  1188.   AddObject(@xSQR   ,'SQR'   ,tfp_1real);
  1189.   AddObject(@xSQRT  ,'SQRT'  ,tfp_1real);
  1190. END;
  1191.  
  1192. PROCEDURE TMathParser.addmisc;
  1193. BEGIN
  1194.   AddObject(@xFRAC  ,'FRAC'  ,tfp_1real);
  1195.   AddObject(@xINT   ,'INT'   ,tfp_1real);
  1196.   AddObject(@xMAX   ,'MAX'   ,tfp_nreal);
  1197.   AddObject(@xMIN   ,'MIN'   ,tfp_nreal);
  1198.   AddObject(@xROUND ,'ROUND' ,tfp_1real);
  1199.   AddObject(@xSGN   ,'SGN'   ,tfp_1real);
  1200. END;
  1201.  
  1202. end.
  1203.