uidentparser.pas

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

 ExcpObj := inherited InitExceptionObject(ExcpObj);
 if ExcpObj is EParseException then
  begin
   if not assigned(EParseException(ExcpObj).TheFile) then
    EParseException(ExcpObj).TheFile := FThisFile;
   if not assigned(EParseException(ExcpObj).EffectiveFile) then
    EParseException(ExcpObj).EffectiveFile := FThisFile;
  end;
 Result := ExcpObj;
end;




{Returns the positions of the last returned token.
~result the positions of the last returned token }
function TIdentifierParser.GetLastTokenPositions: TTokenPosition;
begin
 Result := inherited GetLastTokenPositions;     //get the positions
 if not assigned(Result.FEffectiveFile) then    //read from this file?
  Result.FEffectiveFile := FThisFile;             //set this file
end;




{Assigns the position of the last token to the identifier.
~param Identifier     the identifier to assign the position to
~param AlsoForwardPos if it is the forward position or only the
                      implementation }
procedure TIdentifierParser.SetPosition(Identifier: TIdentifier;
                                        AlsoForwardPos: Boolean = True);
var      Positions        :TTokenPosition;   //the position of the last token
begin
 Positions := GetLastTokenPositions;         //get positions of the last token

 Identifier.InFile := FThisFile;             //assign position in this file
 Identifier.Position := Positions.FPosition;

 Identifier.EffectiveFile := Positions.FEffectiveFile; //and effective position
 Identifier.EffectivePosition := Positions.FEffectivePosition;

 if AlsoForwardPos then                      //assign also forward positions?
  begin
   //assign the position of the forward declaration
   Identifier.ForwardDefPos := Positions.FPosition;
   //assign effective position
   Identifier.EffectiveForwardFile := Positions.FEffectiveFile;
   Identifier.EffectiveForwardPosition := Positions.FEffectivePosition;
  end;
end;

{Assigns the position to the identifier.
~param Identifier     the identifier to assign the position to
~param Pos            the position to assign
~param AlsoForwardPos if it is the forward position or only the
                      implementation }
procedure TIdentifierParser.SetOldPosition(Identifier: TIdentifier;
                                           const Pos: TTokenPosition;
                                           AlsoForwardPos: Boolean = True);
begin
 Identifier.InFile := FThisFile;             //assign position in this file
 Identifier.Position := Pos.FPosition;

 Identifier.EffectiveFile := Pos.FEffectiveFile; //assign effective position
 Identifier.EffectivePosition := Pos.FEffectivePosition;

 if AlsoForwardPos then                      //assign also forward position?
  begin
   //assign the position of the forward declaration
   Identifier.ForwardDefPos := Pos.FPosition;
   //assign effective position
   Identifier.EffectiveForwardFile := Pos.FEffectiveFile;
   Identifier.EffectiveForwardPosition := Pos.FEffectivePosition;
  end;
end;









{Skips the next token if it is a semicolon.
~result if the token was a semicolon }
function TIdentifierParser.SkipSemicolon: Boolean;
var      Token            :String;    //the following token
begin
 PushPosition;                        //save position in case of no semicolon
 Result := GetToken(Token) and (Token = ';'); //test if it is a semicolon
 if Result then
  LosePosition                          //delete saved position
 else
  PopPosition;                          //restore position
end;







{Raises an exception, if it is not a valid name.
~param Name the name to check
~param Kind additional hint on the kind of the identifier with the invalid
            name }
procedure TIdentifierParser.CheckIdentifierName(const Name: String;
                                                const Kind: String = '');
var       AddKind          :String;       //string to add for the kind
begin
 if not IsValidIdentifierName(Name) then  //is not a valid string for a name?
  begin                                     //that's an error!
   if Kind <> '' then                       //get stirng to add for the kind
    AddKind := ' (' + Kind + ')'
   else
    AddKind := '';
   ExceptionFmt(etSyntax, 'Invalid string as a name "%s"%s!', [Name, AddKind]);
  end;
end;




{Reads portability directives.
~param Token in: first Token to check for portability directives or '';
             out: the next token after the portability directives or ''
~result the read issues }
function TIdentifierParser.ReadPortabilityIssues(var Token: String):
                                                           TIdentPortabilities;
var      Tok              :String;               //a token
         Index            :Integer;              //index of the directive
begin
 Tok := Token;
 if (Tok = '') and not GetToken(Tok) then        //make sure one token is read
  Exception(etSyntax,
            'Unexpected end of file while reading portability directives!');

 Result := [];
 while IsWordIn(Tok, IdentPortability, Index) do //while directive available
  begin
   Include(Result, TIdentPortability(Index));      //add directive
   if not GetToken(Tok) then                       //read next token
    Exception(etSyntax,
              'Unexpected end of file while reading portability directives!');
  end;
 Token := Tok;                                   //return the last token
end;


{Reads portability directives of this file.
~result the next token after the portability directives or '' }
function TIdentifierParser.ReadOwnPortabilityIssues: String;
begin
 Result := '';
 FThisFile.Portability := FThisFile.Portability +
                          ReadPortabilityIssues(Result);
end;













{Will be called for every pointer and class reference type in the just ended
 block of type definitions and checks for forward references.
~param Ident  an identifier that names a named type
~param Parent the identifier that directly contains it
~param Data   this parameter is not used and must be nil }
procedure TIdentifierParser.CallBackIdentTypeBlockEnd(Ident: TIdentType;
                                                      Parent: TIdentifier;
                                                      Data: TIdentifier);
var       Identifier       :TIdentifier;      //identifier of the type
begin
 assert(not assigned(Data));
 assert(not assigned(Ident.TheType));
 //for every pointer and class reference-type that doesn't reference
 if ((Parent is TPointerType) or (Parent is TClassReferenceType)) and
    (pos('.', Ident.DefIdent) = 0) then         //an identifier in another unit
  begin
   //search identifier in the same scope (file/function)
   Identifier := FActualIdents.GetIdentByName(Ident.DefIdent);
   if assigned(Identifier) then               //referenced identifier found?
    begin
     if not (Identifier is TType) then
      ExceptionIdentFmt(Ident, etSyntax,
                        'Defined pointer-type/class-reference not on a type-identifier, "%s"!',
                        [Ident.DefIdent]);
     if (Parent is TClassReferenceType) and
        not (Identifier is TIdentType) and
        (not (Identifier is TRecordType) or
         (TRecordType(Identifier).Kind <> rkClass)) then
      ExceptionIdentFmt(Ident, etSyntax,
                        'Class-reference not on a class, "%s"!',
                        [Ident.DefIdent]);

     Ident.TheType := TType(Identifier);        //save the found identifier
    end;
  end;
end;

{Will be called when a block of type definitions has been ended. For every
 new pointer and class reference will be checked it is a forward reference to
 an identifier in the same block. In the case it's referencing an identifier in
 the same block the identifiers will be linked.
~param StartIndex the index of the first defined identifier in the just ended
                  block of type definitions }
procedure TIdentifierParser.TypeBlockHasEnded(StartIndex: Integer);
var       i     :Integer; //counter through all identifiers of the block
begin
 //for all identifiers of the block check for forward references
 for i := StartIndex to FActualIdents.Count - 1 do
  FActualIdents[i].ForEachIdentType(CallBackIdentTypeBlockEnd, nil);
end;









{Parses the list of ancestors/parents of a class or interface.
~param TheRec    the record-like type from which the list of ancestors should
                 be parsed
~param Ancestors the string of the definitions of the ancestors, this means the
                 parent and all implemented interfaces }
procedure TIdentifierParser.ParseRecordLikeParents(TheRec: TRecordType;
                                                   Ancestors: String);
var       i          :Integer;     //index in the strings
          S          :String;      //string to split the parent-list
          ImplInterf :TIdentType;  //an interface implemented by the class
begin
 assert(not assigned(TheRec.IdentParent));
 assert(TheRec.Implementing.IsEmpty);

 //valid type for ancestors?
 if not (TheRec.Kind in RecordKindCanInherit) then
  ExceptionIdentFmt(TheRec, etSyntax,
                    '%s with a parent!', [RecordKindNames[TheRec.Kind]]);

 S := Ancestors;                   //extract parent
 i := pos(',', S);
 if i <> 0 then
  begin
   S := copy(S, 1, i - 1);
   Delete(Ancestors, 1, i);
   Ancestors := Trim(Ancestors);   //remove parent from list of ancestors
  end
 else
  Ancestors := '';
 S := Trim(S);

 i := pos('.', S);
 if i <> 0 then                    //check name of parent
  begin
   assert(copy(S, i - 1, 3) = ' . ');
   Delete(S, i, 2);
   if pos('.', S) <> 0 then
    ExceptionIdentFmt(TheRec, etSyntax, 'Parent-Name of %s %s invalid!',
                      [RecordKindNames[TheRec.Kind], TheRec.Name]);
   S[i - 1] := '.';
   if pos(' ', S) <> 0 then
    ExceptionIdentFmt(TheRec, etSyntax, 'Parent-Name of %s %s invalid!',
                      [RecordKindNames[TheRec.Kind], TheRec.Name]);
  end;

 TheRec.IdentParent := TIdentType.Create;  //add identifier for the parent
 TheRec.IdentParent.DefIdent := S;

 if Ancestors <> '' then           //further ancestors given?
  begin
   if TheRec.Kind <> rkClass then    //must be a class
    ExceptionIdentFmt(TheRec, etSyntax, '%s with multiple parents!',
                      [RecordKindNames[TheRec.Kind]]);

   repeat                            //for all implemented interfaces
     i := pos(',', Ancestors);
     if i <> 0 then                    //extract the next interface
      begin
       S := copy(Ancestors, 1, i - 1);
       Delete(Ancestors, 1, i);
      end
     else
      begin
       S := Ancestors;
       Ancestors := '';
      end;
     S := Trim(S);

     i := pos('.', S);                 //check if name of interface valid?
     if i <> 0 then
      begin
       assert(copy(S, i - 1, 3) = ' . ');
       Delete(S, i, 2);
       if pos('.', S) <> 0 then
        ExceptionIdent(TheRec, etSyntax,
                       'Name of implemented interface invalid!');
       S[i - 1] := '.';
       if pos(' ', S) <> 0 then
        ExceptionIdent(TheRec, etSyntax,
                       'Name of implemented interface invalid!');
      end;

     ImplInterf := TIdentType.Create;     //create identifier for interface
     try
       ImplInterf.DefIdent := S;          //add implemented interface
       TheRec.Implementing.AddIdent(ImplInterf);
     except
       ImplInterf.Free;
       raise;
     end;

   until Ancestors = '';               //until all interfaces parsed
  end;
end;

















{Parses a constant expression, like used in types (sub ranges with ..) and as
 initialisation of variables and constants.
~param ExprTokens    the tokens of the expression
                     (in: the first token and
                      out: all tokens of the expression)
~param EndDirectives if equal signs, "absolute", portability directives and
                     "name"/"index" are not part of the expression:
                     ~[preformatted
                     var a: 4 = 5..(5 = 5); //correct
                         b: 4 = 5..5 = 5;   //error: incompatible, boolean (..) and integer, i.e.:
                     //    (4 = 5..5) = 5;]