rm_jvinterpreterparser.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 759 行 · 第 1/2 页

var
  I: Integer;
  L1: Integer;
  T1: Char;
  Ci: Char;
  Point: Boolean;
label { Sorry about labels and gotos - for speed-ups only }
  Any, NotNumber;
begin
  L1 := Length(Token);
  if L1 = 0 then
  begin
    Result := ttEmpty;
    Exit;
  end;
  T1 := Token[1];
  if L1 = 1 then
  begin
    { Result := pa_tokenize_1tag(Token[1]);
    if Result = -1 then goto Any; }
    if T1 in ['('..'>'] then { #40..#62 }
      Result := Asso1Values[T1]
    else if T1 = '[' then
    	Result := ttLS
  	else if T1 = ']' then
    	Result := ttRS
    else if T1 = '"' then
      Result := ttDoubleQuote
    else
    	goto Any;
  end
  else
    case T1 of
      '.':
        { may be '..' }
        begin
          if Token[2] = '.' then
            Result := ttDoublePoint
          else
            goto Any;
        end;
      '$':
        { may be hex constant }
        begin
          for I := 2 to L1 do
{$IFDEF Delphi}
            if not (Token[I] in StConstSymbols) then
{$ELSE}
            if not HasChar(Token[I], StConstSymbols) then
{$ENDIF}
              goto Any;
          Result := ttInteger;
        end;
      '<':
        if L1 = 2 then
          case Token[2] of
            '=': Result := ttEquLess;
            '>': Result := ttNotEqu;
          else
            goto Any;
          end
        else
          goto Any;
      '>':
        if (L1 = 2) and (Token[2] = '=') then
          Result := ttEquGreater
        else
          goto Any;
    else
      begin
        Any: { !!LABEL!! }
        Point := False;
        for I := 1 to L1 do
        begin
          Ci := Token[I];
          if Ci = '.' then
            if Point then
              goto NotNumber {two Points in lexem}
            else
              Point := True
          else
            if (Ci < '0') or (Ci > '9') then
              goto NotNumber { not number }
        end;
        if Point then
          Result := ttDouble
        else
          Result := ttInteger;
        Exit;
        NotNumber: { !!LABEL!! }
        if (L1 >= 2) and (Token[1] = '''') and (Token[L1] = '''') then
          Result := ttString
        else
        begin
          { keywords }
          Result := PaTokenizeTag(Token);
          if Result <> -1 then
          begin
          end
          else
            { may be Identifier }
{$IFDEF Delphi}
            if not (T1 in StIdFirstSymbols) then
{$ELSE}
            if not HasChar(T1, StIdFirstSymbols) then
{$ENDIF}
              Result := ttUnknown
            else
            begin
              for I := 2 to L1 do
{$IFDEF Delphi}
                if not (Token[I] in StIdSymbols) then
{$ELSE}
                if not HasChar(Token[I], StIdSymbols) then
{$ENDIF}
                begin
                  Result := ttUnknown;
                  Exit;
                end;
              Result := ttIdentifier;
            end;
        end;
      end;
    end;
end;

function TypToken(const TTyp: TTokenTyp): string;
begin
  Result := '?? not implemented !!'; { DEBUG !! }
end;

function Prior(const TTyp: TTokenTyp): TPriorLevel;
const
  Priors: array[ttNot..ttEquLess] of TPriorLevel =
  (priorNot, priorMul, priorDiv, priorIntDiv, priorMod, priorAnd, priorPlus,
    priorMinus, priorOr, priorEqu, priorGreater, priorLess,
    priorNotEqu, priorEquGreater, priorEquLess);
begin
  if TTyp in [ttNot..ttEquLess] then
    Result := Priors[TTyp]
  else
    Result := 0;
end;
//=== TJvInterpreterParser ===================================================

constructor TJvInterpreterParser.Create;
begin
  inherited Create;
end;

destructor TJvInterpreterParser.Destroy;
begin
  inherited Destroy;
end;

procedure TJvInterpreterParser.SetSource(Value: string);
begin
  FSource := Value;
  Init;
end;

procedure TJvInterpreterParser.Init;
begin
  FPCPos := PChar(FSource);
end;

function TJvInterpreterParser.Token: string;
var
  P, F: PChar;
  F1: PChar;
  I: Integer;
//  PointCount: Integer;
  procedure Skip;
  begin
    case P[0] of
      '{':
        begin
          F := StrScan(P + 1, '}');
          if F = nil then
            JvInterpreterError(ieBadRemark, P - PChar(FSource));
          P := F + 1;
        end;
      '(':
        if P[1] = '*' then
        begin
          F := P + 2;
          while True do
          begin
            F := StrScan(F, '*');
            if F = nil then
              JvInterpreterError(ieBadRemark, P - PChar(FSource));
            if F[1] = ')' then
            begin
              Inc(F);
              Break;
            end;
            Inc(F);
          end;
          P := F + 1;
        end;
      '}':
        JvInterpreterError(ieBadRemark, P - PChar(FSource));
      '*':
        if (P[1] = ')') then
          JvInterpreterError(ieBadRemark, P - PChar(FSource));
      '/':
        if (P[1] = '/') then
          while not (P[0] in [#10, #13, #00]) do
            Inc(P);
    end;
    while (P[0] in [' ', #10, #13, #9]) do
      Inc(P);
  end;
begin
  { New Token }
  F := FPCPos;
  P := FPCPos;
  { Firstly skip spaces and remarks }
  repeat
    F1 := P;
    Skip;
  until F1 = P;
  F := P;
{$IFDEF Delphi}
  if P[0] in StIdFirstSymbols then
{$ELSE}
  if HasChar(P[0], StIdFirstSymbols) then
{$ENDIF}
  { token }
  begin
{$IFDEF Delphi}
    while P[0] in StIdSymbols do
      Inc(P);
{$ELSE}
    while HasChar(P[0], StIdSymbols) do
      Inc(P);
{$ENDIF}
    SetString(Result, F, P - F);
  end
  else
{$IFDEF Delphi}
    if P[0] in StConstSymbols10 then
{$ELSE}
    if HasChar(P[0], StConstSymbols10) then
{$ENDIF}
  { number }
    begin
{$IFDEF Delphi}
      while (P[0] in StConstSymbols10) or (P[0] = '.') do
      begin
        if (P[0] = '.') and (P[1] = '.') then
          break;
        Inc(P);
      end;
{$ELSE}
      while HasChar(P[0], StConstSymbols10) or (P[0] = '.') do
        Inc(P);
{$ENDIF}
      SetString(Result, F, P - F);
    end
    else
      if ((P[0] = '$') and
{$IFDEF Delphi}
        (P[1] in StConstSymbols)) then
{$ELSE}
        HasChar(P[1], StConstSymbols)) then
{$ENDIF}
  { hex number }
      begin
        Inc(P);
{$IFDEF Delphi}
        while P[0] in StConstSymbols do
          Inc(P);
{$ELSE}
        while HasChar(P[0], StConstSymbols) do
          Inc(P);
{$ENDIF}
        SetString(Result, F, P - F);
      end
      else
        if P[0] = '''' then
  { string constant }
        begin
          Inc(P);
          while P[0] <> #0 do
          begin
            if P[0] = '''' then
              if P[1] = '''' then
                Inc(P)
              else
                Break;
            Inc(P);
          end;
          Inc(P);
          SetString(Result, F, P - F);
          I := 2;
          while I < Length(Result) - 1 do
          begin
            if Result[I] = '''' then
              Delete(Result, I, 1);
            Inc(I);
          end;
        end
        else
          if ((P[0] = '#') and
{$IFDEF Delphi}
            (P[1] in StConstSymbols10)) then
{$ELSE}
            HasChar(P[1], StConstSymbols10)) then
{$ENDIF}
  { Char constant }
          begin
            Inc(P);
{$IFDEF Delphi}
            while P[0] in StConstSymbols10 do
              Inc(P);
{$ELSE}
            while HasChar(P[0], StConstSymbols10) do
              Inc(P);
{$ENDIF}
            SetString(Result, F + 1, P - F - 1);
            Result := '''' + Chr(StrToInt(Result)) + '''';
          end
          else
            if P[0] in ['>', '=', '<', '.'] then
            begin
              if (P[0] = '.') and (P[1] = '.') then
              begin
                Result := '..';
                Inc(P, 2);
              end
              else
                if (P[0] = '>') and (P[1] = '=') then
                begin
                  Result := '>=';
                  Inc(P, 2);
                end
                else
                  if (P[0] = '<') and (P[1] = '=') then
                  begin
                    Result := '<=';
                    Inc(P, 2);
                  end
                  else
                    if (P[0] = '<') and (P[1] = '>') then
                    begin
                      Result := '<>';
                      Inc(P, 2);
                    end
                    else
                    begin
                      Result := P[0];
                      Inc(P);
                    end;
            end
            else
              if P[0] = #0 then
                Result := ''
              else
              begin
                Result := P[0];
                Inc(P);
              end;
  FPCPos := P;
end;

function TJvInterpreterParser.GetPos: Integer;
begin
  Result := FPCPos - PChar(FSource);
end;

procedure TJvInterpreterParser.SetPos(Value: Integer);
begin
  FPCPos := PChar(FSource) + Value;
end;
end.