utokenparser.pas

DelphiDoc is a program for automatic generation of documentation on a Delphi-Project. At the momen

       Token := Copy(Token, 1, CommentEnd + Ord(BraceStar));
       Inc(FTokenSearchPos.Column, Length(Token)); //and advance position
      end
     else
      begin
       Token := Token + CommentEnds[BraceStar];    //end comment validly
       SeekToEndOfComment(BraceStar);      //skip to the end of the comment
      end;


    end
   else
    //special longer (2 chars) tokens: '' .. := <>
    //(. .) are replaced with [ ]
    if (Length(Token) > 1) and
       (((Token[1] = '.') and (Token[2] in ['.', ')'])) or
        ((Token[1] = '(') and (Token[2] = '.')) or
        ((Token[1] = ':') and (Token[2] = '=')) or
        ((Token[1] = '<') and (Token[2] = '>')) or
        ((Token[2] = '=') and (Token[1] in ['>', '<'])) or
        ((Token[1] = '''') and (Token[2] = '''') and
         ((Length(Token) = 2) or (Token[3] <> '''')))) then
     begin
      //search next token behind this
      Inc(FTokenSearchPos.Column, 2);
      if Token[1] = '(' then
       Token := '['
      else
       if Token[2] = ')' then
        Token := ']'
       else
        Token := Copy(Token, 1, 2); //extract character-combination token
     end
    else
     if Token[1] = '''' then     //a string?
      begin
       if Length(Token) <= 1 then
        WarningMessage(etNoPascal, 'Encountered unclosed string-constant!');
       pc := Pointer(Token);     //run through string
       repeat
         Inc(pc);                  //run through string
         while not (pc^ in [#0, '''']) do
          Inc(pc);
         if pc^ = #0 then
          begin
           WarningMessage(etNoPascal,
                          'Encountered unclosed string-constant!');
           Token := Token + '''';   //add the missing "'"
           pc := Pointer(Token);
           Inc(pc, length(Token));  //and end search of it
          end
         else
          inc(pc);                 //next character after the '
       until pc^ <> '''';        //is not a quoted ' inside the string?

       Token := Copy(Token, 1, pc - Pointer(Token)); //extract string
       //search next token behind this
       Inc(FTokenSearchPos.Column, Length(Token));
      end
     else
      if Token[1] = '$' then      //followed by a hexadecimal number
       begin                      //$ = $0 = 0
        pc := Pointer(Token);
        Inc(pc);           //run through the hexadecimal digits
        while pc^ in ['0'..'9', 'A'..'F', 'a'..'f'] do
         Inc(pc);
        //copy the hexadecimal number
        Token := Copy(Token, 1, pc - Pointer(Token));
        //search next token behind this
        Inc(FTokenSearchPos.Column, Length(Token));
       end
      else
       //followed by an octal number;

       //this is broken now, as '&' is used as prefix for keywords to handle
       //them as normal identifiers in Delphi 8+, see StartIdentifierChars
       if (Token[1] = '&') and (FPascalDialect = pdFreePascal) then
        begin                      //& = &0 = 0
         pc := Pointer(Token);
         Inc(pc);           //run through the octal digits
         while pc^ in ['0'..'7'] do
          Inc(pc);
         //copy the octal number
         Token := Copy(Token, 1, pc - Pointer(Token));
         //search next token behind this
         Inc(FTokenSearchPos.Column, Length(Token));
        end
       else
        //followed by a binary number
        if (Token[1] = '%') and (FPascalDialect = pdFreePascal) then
         begin                      //% = %0 = 0
          pc := Pointer(Token);
          inc(pc);           //run through the binary digits
          while pc^ in ['0'..'1'] do
           Inc(pc);
          //copy the binary number
          Token := Copy(Token, 1, pc - Pointer(Token));
          //search next token behind this
          Inc(FTokenSearchPos.Column, Length(Token));
         end
        else
         begin
          Inc(FTokenSearchPos.Column); //search next token behind it
          Token := Token[1];           //return just the single character
         end;

 Assert(Result = (Token <> ''));
 ResToken := Token;
end;











{Returns the next token (after the current position).
~param Token returns the found token or '' if no token could be found
~result whether a token could be found }
function TTokenParser.DoGetToken(var Token: String): Boolean;
begin
 repeat
   Result := DoDoGetToken(Token);       //get the token
 until not Result or
       //ignore comments with compiler options
       ((Token[1] <> '{') and
        ((Token[1] <> '(') or (Length(Token) <= 1) or (Token[2] <> '*')));
end;


















{Returns the next token (after the current position). If the token should be
 read from the stack it is used, else ~[link DoGetToken] called to to get a new
 one.
~param Token returns the found token or '' if no token could be found
~result whether a token could be found }
function TTokenParser.GetToken(var Token: String): Boolean;
var      TokenInfo   :TTokenInfo;         //information about the token
begin
 if FTokenOnStackIndex = -1 then          //don't get tokens from stack?
  begin
   Result := DoGetToken(Token);             //get a new token

   if Result and (FTokenPosStackFreeIndex <> 0) then //position on stack?
    begin
     TokenInfo.Token := Token;
     TokenInfo.Position := GetLastTokenPositions;
     FTokenStack.Add(TokenInfo);                       //put token on stack

{$IFOPT C+}
     if FTokenStack.Count > MaxTokensOnStack then
      MaxTokensOnStack := FTokenStack.Count;
{$ENDIF}

    end;
  end //if FTokenOnStackIndex = -1
 else
  begin //get the token from the stack
   Assert(FTokenOnStackIndex < FTokenStack.Count);

   TokenInfo := FTokenStack[FTokenOnStackIndex];       //get token from the
   Token := TokenInfo.Token;                               //stack and
   FAbsoluteLastTokenStartPos := TokenInfo.Position.FPosition; //its position
   FEffectiveLastTokenFile := TokenInfo.Position.FEffectiveFile;
   FEffectiveLastTokenStartPos := TokenInfo.Position.FEffectivePosition;

   if FTokenPosStackFreeIndex = 0 then    //no positions on stack?
    begin
     Assert(FTokenOnStackIndex = 0);
     FTokenStack.Delete(0);                 //delete the token
     //the just read and deleted token is the last token before the tokens on
     //the stack, save its position
     FBeforeStackTokenPosition := TokenInfo.Position
    end
   else
    Inc(FTokenOnStackIndex);                //next time get following token
   if FTokenOnStackIndex >= FTokenStack.Count then  //all tokens of stack used?
    FTokenOnStackIndex := -1;                         //don't use stack anymore

   Result := True;
  end; //else FTokenOnStackIndex = -1
end;


{Returns the next token, and if it is a opening brace or bracket the whole
 expression to the closing brace/bracked is returned. Nesting of braces and
 brackets will be correctly recognized, but a wrong order of them will not be
 recognized as error, f.i.: ~[code ( ~[[ ) ~[]] will be returned as is.
~param Token returns the found token or '' if no token could be found
~result whether a token could be found }
function TTokenParser.GetBalancedToken(var Token: String): Boolean;
var      Braces, Brackets       :Cardinal;  //number of opened braces/brackets
         AToken                 :String;    //a token
         Positions              :TTokenPosition; //position of the first token
begin
 Result := GetToken(Token); //get first token

 //first token is a brace or bracket?
 if Result and (length(Token) = 1) and (Token[1] in ['(', '[']) then
  begin
   //save position of first token
   Positions.FPosition := FAbsoluteLastTokenStartPos;
   Positions.FEffectiveFile := FEffectiveLastTokenFile;
   Positions.FEffectivePosition := FEffectiveLastTokenStartPos;

   if Token[1] = '(' then //initialize number of opened braces and brackets
    begin
     Braces := 1;
     Brackets := 0;
    end
   else
    begin
     Braces := 0;
     Brackets := 1;
    end;

   //while braces or brackets are opened
   while (Braces <> 0) or (Brackets <> 0) do
    begin
     if not GetToken(AToken) then
      ExceptionPos(Positions, etNoPascal,
                   'Missing ")" and/or "]" in (un)balanced expression!');

     if length(AToken) = 1 then
      case AToken[1] of          //handle braces/brackets
        '(': inc(Braces);
        ')': begin
              if Braces = 0 then
               ExceptionPos(Positions, etNoPascal,
                            'Unbalanced Expression, unexpected ")"!');
              dec(Braces);
             end;
        '[': inc(Brackets);
        ']': begin
              if Brackets = 0 then
               ExceptionPos(Positions, etNoPascal,
                            'Unbalanced Expression, unexpected "]"!');
              dec(Brackets);
             end;
      end;
     Token := Token + ' ' + AToken;         //append token to the result
    end;

   FAbsoluteLastTokenStartPos := Positions.FPosition;   //restore position of
   FEffectiveLastTokenFile := Positions.FEffectiveFile;  //the first token
   FEffectiveLastTokenStartPos := Positions.FEffectivePosition;
  end;
end;

{Returns the positions of the last returned token.
~result the positions of the last returned token }
function TTokenParser.GetLastTokenPositions: TTokenPosition;
begin
 Result.FPosition := FAbsoluteLastTokenStartPos;
 Result.FEffectiveFile := FEffectiveLastTokenFile;
 Result.FEffectivePosition := FEffectiveLastTokenStartPos;
end;


{Returns the next token, and if it is a chain of identifiers separated by dots,
 the whole chain is returned.
~param Token returns the found token/chain of identifiers or '' if no token
             could be found
~result if a token could be found }
function TTokenParser.GetIdentWithPointsToken(var Token: String): Boolean;
var      AToken              :String;      //a token
begin
 Result := GetToken(Token);  //get first token
 //is token an identifier?
 if Result and (Token <> '') and (Token[1] in StartIdentifierChars) then
  begin
   PushPosition;       //save position for the next token
   try
     //while next token is a dot append the dot and the following identifier
     while GetToken(AToken) and (AToken = '.') and GetToken(AToken) do
      begin
       Token := Token + '.' + AToken;
       LosePosition;
       PushPosition;
      end;
   finally
    PopPosition;       //restore the search position after the last identifier
   end;
  end;
end;




{Puts the position to start the search for the next token on the stack. The
 position can be pulled from the stack with ~[link PopPosition] to parse the
 tokens after the current position again. If they should not be parsed again
 the position can be removed from the stack without changing the current
 position with ~[link LosePosition]. }
procedure TTokenParser.PushPosition;
var       Stack       :PInteger;      //current item on the stack
begin
 if FTokenPosStackFreeIndex = FTokenPosStackSize then //stack is full?
  begin
   inc(FTokenPosStackSize, 64);                         //grow stack
   ReallocMem(FTokenPosStack, SizeOf(FTokenPosStack^) * FTokenPosStackSize);
  end;
 Stack := FTokenPosStack;             //get current item on stack
 inc(Stack, FTokenPosStackFreeIndex);

 if FTokenOnStackIndex = -1 then      //currently not re-reading tokens?
  begin
   Stack^ := FTokenStack.Count;         //set position on stack
   if Stack^ = 0 then                   //currently no positions on the stack?
    //save position of the last token before the new ones will be put on the
    FBeforeStackTokenPosition := GetLastTokenPositions;         //stack
  end
 else
  Stack^ := FTokenOnStackIndex;

 inc(FTokenPosStackFreeIndex);        //another position is on the stack

{$IFOPT C+}
 if FTokenPosStackFreeIndex > MaxStackSizeOfPositions then
  MaxStackSizeOfPositions := FTokenPosStackFreeIndex;
{$ENDIF}

end;

{Pulls the position to start the search for the next token from the stack. The
 subsequent returned tokens will be searched after the pulled position.
~see PushPosition
~see LosePosition }
procedure TTokenParser.PopPosition;
var       Stack       :PInteger;     //topmost item on the stack
begin
 if FTokenPosStackFreeIndex = 0 then //are there any positions on the stack?
  raise SysUtils.Exception.Create('No positions to pop/pull from the stack!');
 dec(FTokenPosStackFreeIndex);       //remove from stack
 Stack := FTokenPosStack;
 inc(Stack, FTokenPosStackFreeIndex);
 FTokenOnStackIndex := Stack^;       //get tokens from stack

 //the first token on the stack will be re-read?
 if FTokenOnStackIndex = 0 then
  begin                                //restore position of the token before
   FAbsoluteLastTokenStartPos := FBeforeStackTokenPosition.FPosition;
   FEffectiveLastTokenFile := FBeforeStackTokenPosition.FEffectiveFile;
   FEffectiveLastTokenStartPos := FBeforeStackTokenPosition.FEffectivePosition;
  end;

 if FTokenOnStackIndex = FTokenStack.Count then  //position is off the stack?
  FTokenOnStackIndex := -1;
end;

{Deletes the topmost position from the stack.
~see PopPosition
~see LosePosition }
procedure TTokenParser.LosePosition;
begin
 if FTokenPosStackFreeIndex = 0 then //are there any positions on the stack?
  raise SysUtils.Exception.Create('No positions to lose from the stack!');

 dec(FTokenPosStackFreeIndex);       //remove from stack

 if FTokenPosStackFreeIndex = 0 then //no positions left on the stack?
  if FTokenOnStackIndex = -1 then      //not reading any tokens from the stack
   FTokenStack.Clear                     //clear the stack
  else
   if FTokenOnStackIndex > 0 then      //not at the first token on the stack?
    begin

     //save the position of the last read position, it will be the position of
     //the last token before the tokens on the stack
     FBeforeStackTokenPosition := FTokenStack[FTokenOnStackIndex -
                                              1].Position;

     while FTokenOnStackIndex > 0 do     //delete all unused tokens at the top
      begin                               //of the stack
       FTokenStack.Delete(0);
       dec(FTokenOnStackIndex);
      end;

    end; //if FTokenOnStackIndex > 0
end;









{$IFOPT C+}
{$IFNDEF LINUX}

initialization

finalization

 OutputDebugString(PChar(Format('MaxTokensOnStack, MaxStackSizeOfPositions: %d, %d',
                                [MaxTokensOnStack, MaxStackSizeOfPositions])));

{$ENDIF}
{$ENDIF}

end.