dibpasparser.pas

Delphi控件

function TPascalToken.GetText: string;
var
  PrevPosition: Integer;
begin
  PrevPosition := FOwner.Position;
  FOwner.Position := FPosition;
  SetString(Result, FOwner.Origin, Length);
  FOwner.Position := PrevPosition;
end;

function TPascalToken.GetFirst: Boolean;
var
  P: PChar;
begin
  P := FOwner.FBuffer;
  Inc(P, FPosition);
  while P > FOwner.FBuffer do
    if P^ in [#10, #13, #33..#255] then
      Break
  else
    Inc(P);
  Result := (P = FOwner.FBuffer) or (P^ in CRLF);
end;

function TPascalToken.GetLast: Boolean;
var
  P: PChar;
begin
  P := FOwner.FBuffer;
  Inc(P, FPosition + FLength);
  while P^ > #0 do
    if P^ in [#10, #13, #33..#255] then
      Break
  else
    Inc(P);
  Result := P^ in [#0, #10, #13];
end;

{ EPascalTokenError }

constructor EPascalTokenError.CreateFromToken(AToken: TPascalToken);
begin
  FToken := AToken;
  inherited CreateFmt(SUnexpectedToken, [FToken.Position]);
end;

{ TPascalParser }

constructor TPascalParser.Create(Buffer: PChar; Size: Integer);
begin
  inherited Create;
  Initialize(Buffer, Size);
end;

destructor TPascalParser.Destroy;
begin
  FLines.Free;
  FToken.Free;
  FScratchToken.Free;
  inherited Destroy;
end;

procedure TPascalParser.Initialize(Buffer: PChar; Size: Integer);
begin
  FreeAndNil(FLines);
  FreeAndNil(FToken);
  FreeAndNil(FScratchToken);
  FLines := TTextLines.Create;
  FLines.Add(Buffer);
  FToken := TPascalToken.Create(Self);
  FScratchToken := TPascalToken.Create(Self);
  FBuffer := Buffer;
  FEndOfBuffer := Buffer;
  FOrigin := Buffer;
  Inc(FEndOfBuffer, Size);
end;

function TPascalParser.GetPosition: Integer;
begin
  Result := FOrigin - FBuffer;
end;

procedure TPascalParser.SetToken(Value: TPascalToken);
begin
  if Value.FOwner = Self then
    with FToken do
    begin
      Copy(Value);
      Self.Position := Position + Length;
    end
  else
    raise EPascalTokenError.Create(SInvalidPropertyValue);
end;

procedure TPascalParser.SetPosition(Value: Integer);
begin
  if Value <> Position then
  begin
    FOrigin := FBuffer;
    Inc(FOrigin, Value)
  end;
end;

function TPascalParser.Next: TPascalTokenKind;

  function GetCommentLength: Integer;
  var
    P: PChar;
  begin
    P := FOrigin;
    case FToken.Kind of
      tkAnsiComment:
        repeat
          Inc(P)
        until (P = FEndOfBuffer) or (P[0] in CRLF);
      tkCComment:
        begin
          Inc(P);
          if @P[1] < FEndOfBuffer then
          begin
            repeat
              Inc(P);
            until (@P[1] = FEndOfBuffer) or ((P[0] = '*') and (P[1] = ')'));
            if @P[1] < FEndOfBuffer then
              Inc(P, 2)
            else
              Inc(P);
          end;
        end;
      tkPascalComment:
        begin
          repeat
            Inc(P);
          until (P = FEndOfBuffer) or (P[0] = '}');
          if P < FEndOfBuffer then
            Inc(P);
        end;
    end;
    Result := P - FOrigin;
  end;
var
  P: PChar;
  S: string;
begin
  while (FOrigin < FEndOfBuffer) and (FOrigin[0] in Whitespace) do
    if (FOrigin[0] = #13) and (FOrigin[1] = #10) then
    begin
      Inc(FOrigin, 2);
      FLines.Add(FOrigin);
    end
  else
    Inc(FOrigin);
  if FOrigin < FEndOfBuffer then
    case FOrigin[0] of
      { tkText }
      '''':
        begin
          P := FOrigin;
          FToken.FKind := tkText;
          repeat
            Inc(P);
            while (P < FEndOfBuffer) and (P[0] = '''') and (P[1] = '''') do
              Inc(P, 2);
          until (P = FEndOfBuffer) or (P[0] = '''') or (P[0] in CRLF);
          if (P < FEndOfBuffer) and (P[0] = '''') then
            Inc(P)
          else
            FToken.FKind := tkGarbage;
          FToken.FLength := P - FOrigin;
        end;
      { tkComma }
      ',':
        begin
          FToken.FKind := tkComma;
          FToken.FLength := 1;
        end;
      { tkPoint, tkRightBracket, tkRange }
      '.':
        if @FOrigin[1] < FEndOfBuffer then
          case FOrigin[1] of
            ')':
              begin
                FToken.FKind := tkRightBracket;
                FToken.FLength := 2;
              end;
            '.':
              begin
                FToken.FKind := tkRange;
                FToken.FLength := 2;
              end;
            else
              begin
                FToken.FKind := tkPoint;
                FToken.FLength := 1;
              end;
          end
        else
          begin
            FToken.FKind := tkPoint;
            FToken.FLength := 1;
          end;
        { tkEqual }
        '=':
        begin
          FToken.FKind := tkEqual;
          FToken.FLength := 1;
        end;
      { tkLessThan, tkLessThanOrEqual }
      '<':
        if (@FOrigin[1] < FEndOfBuffer) and (Origin[1] = '=') then
        begin
          FToken.FKind := tkLessThanOrEqual;
          FToken.FLength := 2;
        end
        else
          begin
            FToken.FKind := tkLessThan;
            FToken.FLength := 1;
          end;
        { tkGreaterThan, tkGreaterThanOrEqual }
        '>':
        if (@FOrigin[1] < FEndOfBuffer) and (Origin[1] = '=') then
        begin
          FToken.FKind := tkGreaterThanOrEqual;
          FToken.FLength := 2;
        end
        else
          begin
            FToken.FKind := tkGreaterThan;
            FToken.FLength := 1;
          end;
        { tkGets, tkColon }
        ':':
        if (@FOrigin[1] < FEndOfBuffer) and (Origin[1] = '=') then
        begin
          FToken.FKind := tkGets;
          FToken.FLength := 2;
        end
        else
          begin
            FToken.FKind := tkColon;
            FToken.FLength := 1;
          end;
        { tkSemiColon }
        ';':
        begin
          FToken.FKind := tkSemiColon;
          FToken.FLength := 1;
        end;
      { tkAnsiComment, tkOperator }
      '+', '-', '/', '*':
        if (@FOrigin[1] < FEndOfBuffer) and (Origin[0] = '/') and (Origin[1] = '/') then
        begin
          FToken.FKind := tkAnsiComment;
          FToken.FLength := GetCommentLength;
        end
        else
          begin
            FToken.FKind := tkOperator;
            FToken.FLength := 1;
          end;
        { tkAddressOf }
        '@':
        begin
          FToken.FKind := tkAddressOf;
          FToken.FLength := 1;
        end;
      { tkPointerTo }
      '^':
        begin
          FToken.FKind := tkPointerTo;
          FToken.FLength := 1;
        end;
      { tkLeftBracket, tkCComment, tkLeftParenthesis }
      '(':
        if @FOrigin[1] < FEndOfBuffer then
          case FOrigin[1] of
            '.':
              begin
                FToken.FKind := tkLeftBracket;
                FToken.FLength := 2;
              end;
            '*':
              begin
                FToken.FKind := tkCComment;
                if FOrigin[2] = '$' then
                begin
                  FToken.FLength := GetCommentLength;
                  FToken.FKind := tkDirective;
                end
                else
                  FToken.FLength := GetCommentLength;
              end;
            else
              begin
                FToken.FKind := tkLeftParenthesis;
                FToken.FLength := 1;
              end;
          end
        else
          begin
            FToken.FKind := tkLeftParenthesis;
            FToken.FLength := 1;
          end;
        { tkRightParenthesis }
        ')':
        begin
          FToken.FKind := tkRightParenthesis;
          FToken.FLength := 1;
        end;
      { tkLeftBracket }
      '[':
        begin
          FToken.FKind := tkLeftBracket;
          FToken.FLength := 1;
        end;
      { tkRightBracket }
      ']':
        begin
          FToken.FKind := tkRightBracket;
          FToken.FLength := 1;
        end;
      { tkSpecialSymbol }
      '#', '$':
        begin
          FToken.FKind := tkSpecialSymbol;
          FToken.FLength := 1;
        end;
      { tkPascalComment }
      '{':
        begin
          FToken.FKind := tkPascalComment;
          if FOrigin[1] = '$' then
          begin
            FToken.FLength := GetCommentLength;
            FToken.FKind := tkDirective;
          end
          else
            FToken.FLength := GetCommentLength;
        end;
      { token in the range of tkAnd..tkNumber, tkGarbage }
      else
        begin
          P := FOrigin;
          repeat
            Inc(P);
          until (P = FEndOfBuffer) or (P[0] in Space);
          SetString(S, FOrigin, P - FOrigin);
          FToken.FKind := StrToTokenKind(S);
          FToken.FLength := Length(S);
        end;
    end
    { token is tkNull }
  else
  begin
    FOrigin := FEndOfBuffer;
    FToken.FKind := tkNull;
    FToken.FLength := 0;
  end;
  FToken.FPosition := Position;
  Inc(FOrigin, FToken.FLength);
  Result := FToken.FKind;
end;

function TPascalParser.Skip(const SkipKinds: TPascalTokenKinds): TPascalTokenKind;
begin
  repeat
    Result := Next;
  until (not (Result in SkipKinds)) or (Result = tkNull);
end;

function TPascalParser.Scan(ScanKinds: TPascalTokenKinds): TPascalTokenKind;
begin
  repeat
    Result := Next;
  until (Result in ScanKinds) or (Result = tkNull);
end;

function TPascalParser.Peek(const SkipKinds: TPascalTokenKinds = []): TPascalTokenKind;
var
  P: PChar;
begin
  P := FOrigin;
  FScratchToken.Copy(Token);
  repeat
    Result := Next;
  until (Result = tkNull) or (not (Result in SkipKinds));
  FToken.Copy(FScratchToken);
  FOrigin := P;
end;

end.