rm_pars.pas.~1~

胜天进销存源码,国产优秀的进销存

            ci := StrToInt(Calc(params[1]));
            cn := StrToInt(Calc(params[2]));
            nm[st] := Copy(Calc(params[0]), ci, cn);
          end
          else if s1 = 'IF' then
          begin
            if Boolean(Calc(params[0])) then
//            if Int(StrToFloat(Calc(params[0]))) > 0 then
              s1 := params[1]
            else
              s1 := params[2];
            nm[st] := Calc(s1);
          end
          else if s1 = 'STRTODATE' then
            nm[st] := StrToDate(Calc(params[0]))
          else if s1 = 'STRTOTIME' then
            nm[st] := StrToTime(Calc(params[0]))
          else if s1 = 'CNUMBER' then
            nm[st] := RMChineseNumber(Calc(params[0]))
          else if Assigned(FOnFunction) then
            FOnFunction(s1, params, nm[st]);
          Dec(k);
        end
        else if Assigned(FOnGetValue) then
          FOnGetValue(AnsiUpperCase(s1), nm[st]);
      end;
      i := k;
      Inc(st);
    end; //case

    if s[j] in ['+', '-', '*', '/', '>', '<', '=', ttGe, ttLe, ttNe, ttOr, ttAnd, ttMod] then
      Dec(st);
    Inc(i);
  end; // do
  Result := nm[1];
end;

function TRMParser.GetIdentify(const s: string; var i: Integer): string;
var
  k, n: Integer;
begin
  n := 0;
  while (i <= Length(s)) and (s[i] <= ' ') do
    Inc(i);
  k := i; Dec(i);
  repeat
    Inc(i);
    while (i <= Length(s)) and
      not (s[i] in [' ', #13, '+', '-', '*', '/', '>', '<', '=', '(', ')', '[']) do
    begin
      if s[i] = '"' then
        Inc(n);
      Inc(i);
    end;
  until (n mod 2 = 0) or (i >= Length(s));
  Result := Copy(s, k, i - k);
end;

function TRMParser.GetString(const s: string; var i: Integer): string;
var
  k: Integer;
  f: Boolean;
begin
  k := i; Inc(i);
  repeat
    while (i <= Length(s)) and (s[i] <> '''') do
      Inc(i);
    f := True;
    if (i < Length(s)) and (s[i + 1] = '''') then
    begin
      f := False;
      Inc(i, 2);
    end;
  until f;
  Result := Copy(s, k, i - k + 1);
  Inc(i);
end;

procedure TRMParser.GetParameters(const s: string; var Index: Integer; var params: array of Variant);
var
  c, d, oi, ci: Integer;
  i: Integer;
begin
  c := 1; d := 1; oi := Index + 1; ci := 1;
  repeat
    Inc(Index);
    if s[Index] = '''' then
    begin
      if d = 1 then
        Inc(d)
      else
        d := 1;
    end;
    if d = 1 then
    begin
      if s[Index] = '(' then
        Inc(c)
      else if s[Index] = ')' then
        Dec(c);
      if (s[Index] = ',') and (c = 1) then
      begin
        params[ci - 1] := Copy(s, oi, Index - oi);
        oi := Index + 1; Inc(ci);
      end;
    end;
  until (c = 0) or (Index >= Length(s));

  params[ci - 1] := Copy(s, oi, Index - oi);
  if c <> 0 then
    raise Exception.Create('');
  Inc(Index);
  for i := ci to High(params) do
    params[i] := '';
end;

function TRMParser.Str2OPZ(s: string): string;
label 1;
var
  i, i1, j, p: Integer;
  stack: string;
  res, s1, s2: string;
  params: array[0..10] of Variant;
  vr: Boolean;
  c: Char;

  function Priority(c: Char): Integer;
  begin
    case c of
      '(': Priority := 5;
      ')': Priority := 4;
      '=', '>', '<', ttGe, ttLe, ttNe: Priority := 3;
      '+', '-', ttUnMinus, ttUnPlus: Priority := 2;
      '*', '/', ttOr, ttAnd, ttNot, ttMod: Priority := 1;
      ttInt, ttFrac, ttRound, ttStr: Priority := 0;
    else
      Priority := 0;
    end;
  end;

  procedure ProcessQuotes(var s: string);
  var
    i: Integer;
  begin
    if (Length(s) = 0) or (s[1] <> '''') then
      Exit;
    i := 2;
    if Length(s) > 2 then
      while i <= Length(s) do
      begin
        if (s[i] = '''') and (i < Length(s)) then
        begin
          Insert('''', s, i);
          Inc(i);
        end;
        Inc(i);
      end;
  end;

begin
  res := '';
  stack := '';
  i := 1; vr := False;
  while i <= Length(s) do
  begin
    case s[i] of
      '(':
        begin
          stack := '(' + stack;
          vr := False;
        end;
      ')':
        begin
          p := Pos('(', stack);
          res := res + Copy(stack, 1, p - 1);
          stack := Copy(stack, p + 1, Length(stack) - p);
        end;
      '+', '-', '*', '/', '>', '<', '=':
        begin
          if (s[i] = '<') and (s[i + 1] = '>') then
          begin
            Inc(i);
            s[i] := ttNe;
          end
          else if (s[i] = '>') and (s[i + 1] = '=') then
          begin
            Inc(i);
            s[i] := ttGe;
          end
          else if (s[i] = '<') and (s[i + 1] = '=') then
          begin
            Inc(i);
            s[i] := ttLe;
          end;

          1: if not vr then
          begin
            if s[i] = '-' then
              s[i] := ttUnMinus;
            if s[i] = '+' then
              s[i] := ttUnPlus;
          end;
          vr := False;
          if stack = '' then
            stack := s[i] + stack
          else if Priority(s[i]) < Priority(stack[1]) then
            stack := s[i] + stack
          else
          begin
            repeat
              res := res + stack[1];
              stack := Copy(stack, 2, Length(stack) - 1);
            until (stack = '') or (Priority(stack[1]) > Priority(s[i]));
            stack := s[i] + stack;
          end;
        end;
      ';': break;
      ' ', #13: ;
    else
      vr := True;
      s2 := '';
      i1 := i;
      if s[i] = '%' then
      begin
        s2 := '%' + s[i + 1];
        Inc(i, 2);
      end;
      if s[i] = '''' then
        s2 := s2 + GetString(s, i)
      else if s[i] = '[' then
      begin
        s2 := s2 + '[' + RMGetBrackedVariable(s, i, j) + ']';
        i := j + 1;
      end
      else
      begin
        s2 := s2 + GetIdentify(s, i);
        if s[i] = '[' then
        begin
          s2 := s2 + '[' + RMGetBrackedVariable(s, i, j) + ']';
          i := j + 1;
        end;
      end;
      c := s[i];
      if (Length(s2) > 0) and (s2[1] in ['0'..'9', '.', ',']) then
        res := res + s2 + ' '
      else
      begin
        s1 := AnsiUpperCase(s2);
        if s1 = 'INT' then
        begin
          s[i - 1] := ttInt;
          Dec(i);
          goto 1;
        end
        else if s1 = 'FRAC' then
        begin
          s[i - 1] := ttFrac;
          Dec(i);
          goto 1;
        end
        else if s1 = 'ROUND' then
        begin
          s[i - 1] := ttRound;
          Dec(i);
          goto 1;
        end
        else if s1 = 'OR' then
        begin
          s[i - 1] := ttOr;
          Dec(i);
          goto 1;
        end
        else if s1 = 'AND' then
        begin
          s[i - 1] := ttAnd;
          Dec(i);
          goto 1;
        end
        else if s1 = 'NOT' then
        begin
          s[i - 1] := ttNot;
          Dec(i);
          goto 1;
        end
        else if s1 = 'STR' then
        begin
          s[i - 1] := ttStr;
          Dec(i);
          goto 1;
        end
        else if s1 = 'MOD' then
        begin
          s[i - 1] := ttMod;
          Dec(i);
          goto 1;
        end
        else if c = '(' then
        begin
          GetParameters(s, i, params);
          res := res + Copy(s, i1, i - i1);
        end
        else
          res := res + s2 + ' ';
      end;
      Dec(i);
    end;
    Inc(i);
  end;

  if stack <> '' then
    res := res + stack;
  Result := res;
end;

function TRMParser.Calc(const s: string): Variant;
begin
  Result := CalcOPZ(Str2OPZ(s));
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMFunctionSplitter}

constructor TRMFunctionSplitter.Create(MatchFuncs, SplitTo: TStrings; Variables: TRMVariables);
begin
  inherited Create;
  FParser := TRMParser.Create;
  FMatchFuncs := MatchFuncs;
  FSplitTo := SplitTo;
  FVariables := Variables;
end;

destructor TRMFunctionSplitter.Destroy;
begin
  FParser.Free;
  inherited Destroy;
end;

procedure TRMFunctionSplitter.Split(s: string);
var
  i, k: Integer;
  s1: string;
  params: array[0..10] of Variant;
begin
  i := 1;
  s := Trim(s);
  if (Length(s) > 0) and (s[1] = '''') then
    Exit;
  while i <= Length(s) do
  begin
    k := i;
    if s[1] = '[' then
    begin
      s1 := RMGetBrackedVariable(s, k, i);
      if FVariables.IndexOf(s1) <> -1 then
        s1 := FVariables[s1];
      Split(s1);
      k := i + 1;
    end
    else
    begin
      s1 := FParser.GetIdentify(s, k);
      if s[k] = '(' then
      begin
        FParser.GetParameters(s, k, params);
        Split(params[0]);
        Split(params[1]);
        Split(params[2]);
        if FMatchFuncs.IndexOf(s1) <> -1 then
          FSplitTo.Add(Copy(s, i, k - i));
      end
      else if FVariables.IndexOf(s1) <> -1 then
      begin
        s1 := FVariables[s1];
        Split(s1);
      end
      else if s[k] in [' ', #13, '+', '-', '*', '/', '>', '<', '='] then
        Inc(k)
      else if s1 = '' then
        break;
    end;
    i := k;
  end;
end;

end.