Delphi实现Js中的Eval函数

procedure Eval(Formula: string; {   要计算的表达式   }
  var Value: Real; {   返回数值   }
  var ErrPos: Integer); {   错误信息   }
const
  Digit: set of Char = ['0'..'9'];
var
  Posn: Integer; {   算式当前位置   }
  CurrChar: Char; {   算式当前字符   }

  procedure ParseNext;
  begin
    repeat
      Posn := Posn + 1;
      if Posn <= Length(Formula) then
        CurrChar := Formula[Posn]
      else
        CurrChar := ^M;
    until CurrChar <> '   ';
  end {   ParseNext   };

  function add_subt: Real;
  var
    E: Real;
    Opr: Char;

    function mult_DIV: Real;
    var
      S: Real;
      Opr: Char;

      function Power: Real;
      var
        T: Real;

        function SignedOp: Real;

          function UnsignedOp: Real;
          type
            StdFunc = (fabs, fsqrt, fsqr, fsin, fcos,
              farctan, fln, flog, fexp, ffact);
            StdFuncList = array[StdFunc] of string[6];

          const
            StdFuncName: StdFuncList =
            ('ABS', 'SQRT', 'SQR', 'SIN', 'COS',
              'ARCTAN', 'LN', 'LOG', 'EXP', 'FACT');
          var
            E, L, Start: Integer;
            Funnet: Boolean;
            F: Real;
            Sf: StdFunc;

            function Fact(I: Integer): Real;
            begin
              if I > 0 then
              begin
                Fact := I * Fact(I - 1);
              end
              else
                Fact := 1;
            end {   Fact   };

          begin
            if CurrChar in Digit then
            begin
              Start := Posn;
              repeat ParseNext until not (CurrChar in Digit);
              if CurrChar = '.' then
                repeat ParseNext until not (CurrChar in Digit);
              if CurrChar = 'E' then
              begin
                ParseNext;
                repeat ParseNext until not (CurrChar in Digit);
              end;
              Val(Copy(Formula, Start, Posn - Start), F, ErrPos);
            end
            else if CurrChar = '(' then
            begin
              ParseNext;
              F := add_subt;
              if CurrChar = ')' then
                ParseNext
              else
                ErrPos := Posn;
            end
            else
            begin
              Funnet := False;
              for sf := fabs to ffact do
                if not Funnet then
                begin
                  l := Length(StdFuncName[sf]);
                  if Copy(Formula, Posn, l) = StdFuncName[sf] then
                  begin
                    Posn := Posn + l - 1;
                    ParseNext;
                    f := UnsignedOp;
                    case sf of
                      fabs: f := abs(f);
                      fsqrt: f := SqrT(f);
                      fsqr: f := Sqr(f);
                      fsin: f := Sin(f);
                      fcos: f := Cos(f);
                      farctan: f := ArcTan(f);
                      fln: f := LN(f);
                      flog: f := LN(f) / LN(10);
                      fexp: f := EXP(f);
                      ffact: f := fact(Trunc(f));
                    end;
                    Funnet := True;
                  end;
                end;
              if not Funnet then
              begin
                ErrPos := Posn;
                f := 0;
              end;
            end;
            UnsignedOp := F;
          end {   UnsignedOp};

        begin {   SignedOp   }
          if CurrChar = '-' then
          begin
            ParseNext;
            SignedOp := -UnsignedOp;
          end
          else
            SignedOp := UnsignedOp;
        end {   SignedOp   };

      begin {   Power   }
        T := SignedOp;
        while CurrChar = '^' do
        begin
          ParseNext;
          if t <> 0 then
            t := EXP(LN(abs(t)) * SignedOp)
          else
            t := 0;
        end;
        Power := t;
      end {   Power   };

    begin
      s := Power;
      while CurrChar in ['*', '/'] do
      begin
        Opr := CurrChar;
        ParseNext;
        case Opr of
          '*': s := s * Power;
          '/': s := s / Power;
        end;
      end;
      mult_DIV := s;
    end;

  begin
    E := mult_DIV;
    while CurrChar in ['+', '-'] do
    begin
      Opr := CurrChar;
      ParseNext;
      case Opr of
        '+': e := e + mult_DIV;
        '-': e := e - mult_DIV;
      end;
    end;
    add_subt := E;
  end;

begin
  if Formula[1] = '.' then
    Formula := '0' + Formula;
  if Formula[1] = '+' then
    Delete(Formula, 1, 1);
  for Posn := 1 to Length(Formula) do
    Formula[Posn] := Upcase(Formula[Posn]);
  Posn := 0;
  ParseNext;
  Value := add_subt;
  if CurrChar = ^M then
    ErrPos := 0
  else
    ErrPos := Posn;
end;