jvinterpreterparser.pas

East make Tray Icon in delphi

    case HVal of
      1:
        HVal := HVal + AssoIndices[(Byte(TokenStr[1]) - Byte('a')) and $1F];
      2:
        begin
          HVal := HVal + AssoIndices[(Byte(TokenStr[1]) - Byte('a')) and $1F];
          HVal := HVal + AssoIndices[(Byte(TokenStr[2]) - Byte('a')) and $1F];
        end;
    else
      begin
        HVal := HVal + AssoIndices[(Byte(TokenStr[1]) - Byte('a')) and $1F];
        HVal := HVal + AssoIndices[(Byte(TokenStr[2]) - Byte('a')) and $1F];
        HVal := HVal + AssoIndices[(Byte(TokenStr[3]) - Byte('a')) and $1F];
      end;
    end;
    HVal := HVal + AssoIndices[(Byte(TokenStr[Len]) - Byte('a')) and $1F];
    HVal := AssoValues[HVal];
  end;
  if HVal <> -1 then
  begin
    if Cmp(WordList[HVal].Token, TokenStr) then
      Result := WordList[HVal].TTyp;
  end;
end;

const
  { !"#$%&'()*+,-./0123456789:;<=>? }
  Asso1Values: array [' '..'?'] of Integer =
    (-1, -1, -1, -1, -1, -1, -1, -1,
     ttLB, ttRB, ttMul, ttPlus, ttCol, ttMinus, ttPoint, ttDiv,
     ttInteger, ttInteger, ttInteger, ttInteger, ttInteger,
     ttInteger, ttInteger, ttInteger, ttInteger, ttInteger,
     ttColon, ttSemicolon, ttLess, ttEqu, ttGreater, -1);

{######################## tokenizer ########################}

function TokenTyp(const Token: string): TTokenKind;
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
            if not (Token[I] in StConstSymbols) then
              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 not (Ci in StConstSymbols10) 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 }
            if not (T1 in StIdFirstSymbols) then
              Result := ttUnknown
            else
            begin
              for I := 2 to L1 do
                if not (Token[I] in StIdSymbols) then
                begin
                  Result := ttUnknown;
                  Exit;
                end;
              Result := ttIdentifier;
            end;
          end;
        end;
    end;
end;

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

function Prior(const TTyp: TTokenKind): 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 } ===============================================

procedure TJvInterpreterParser.SetSource(const 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 [Lf, Cr, #0]) do
            Inc(P);
    end;
    while (P[0] in [' ', Lf, Cr, Tab]) 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;
  if P[0] in StIdFirstSymbols then
  { token }
  begin
    while P[0] in StIdSymbols do
      Inc(P);
    SetString(Result, F, P - F);
  end
  else
  if P[0] in StConstSymbols10 then
  { number }
  begin
    while (P[0] in StConstSymbols10) or (P[0] = '.') do
    begin
      if (P[0] = '.') and (P[1] = '.') then
        Break;
      Inc(P);
    end;
    SetString(Result, F, P - F);
  end
  else
  if ((P[0] = '$') and
    (P[1] in StConstSymbols)) then
  { hex number }
  begin
    Inc(P);
    while P[0] in StConstSymbols do
      Inc(P);
    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
    (P[1] in StConstSymbols10)) then
  { Char constant }
  begin
    Inc(P);
    while P[0] in StConstSymbols10 do
      Inc(P);
    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;

{$IFDEF UNITVERSIONING}
initialization
  RegisterUnitVersion(HInstance, UnitVersioning);

finalization
  UnregisterUnitVersion(HInstance);
{$ENDIF UNITVERSIONING}

end.