paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-06 12:10:26 +02:00
Code Issues Packages Projects Releases Wiki Activity

--- Merging r31366 into '.':

Browse Source 
U    utils/fpdoc/fpdocclasstree.pp
U    utils/fpdoc/dglobals.pp
U    utils/fpdoc/fpclasschart.pp
--- Recording mergeinfo for merge of r31366 into '.':
 U   .
--- Merging r31367 into '.':
G    utils/fpdoc/fpclasschart.pp
G    utils/fpdoc/fpdocclasstree.pp
--- Recording mergeinfo for merge of r31367 into '.':
 G   .
--- Merging r32183 into '.':
U    packages/fcl-passrc/tests/tcstatements.pas
U    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r32183 into '.':
 G   .
--- Merging r32360 into '.':
U    utils/fpdoc/fpdoc.css
U    utils/fpdoc/css.inc
--- Recording mergeinfo for merge of r32360 into '.':
 G   .
--- Merging r32374 into '.':
U    utils/fpdoc/dw_html.pp
U    utils/fpdoc/mkfpdoc.pp
G    utils/fpdoc/dglobals.pp
U    utils/fpdoc/fpdoc.pp
--- Recording mergeinfo for merge of r32374 into '.':
 G   .
--- Merging r32376 into '.':
A    utils/fpdoc/examples
A    utils/fpdoc/examples/gentest.sh
A    utils/fpdoc/examples/project
A    utils/fpdoc/examples/project/sample-project.xml
A    utils/fpdoc/examples/project/readme.txt
A    utils/fpdoc/examples/basedir
A    utils/fpdoc/examples/basedir/readme.txt
A    utils/fpdoc/examples/basedir/sample-project.xml
A    utils/fpdoc/examples/simple
A    utils/fpdoc/examples/simple/testunit.xml
A    utils/fpdoc/examples/simple/html.bat
A    utils/fpdoc/examples/simple/readme.txt
A    utils/fpdoc/examples/simple/html.sh
A    utils/fpdoc/examples/simple/testunit.pp
D    utils/fpdoc/testunit.pp
D    utils/fpdoc/testunit.xml
D    utils/fpdoc/gentest.sh
--- Recording mergeinfo for merge of r32376 into '.':
 G   .
--- Recording mergeinfo for merge of r34113 into '.':
 G   .
--- Merging r34114 into '.':
U    packages/fcl-passrc/src/pscanner.pp
--- Recording mergeinfo for merge of r34114 into '.':
 G   .
--- Merging r34132 into '.':
G    packages/fcl-passrc/src/pscanner.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r34132 into '.':
 G   .
--- Merging r34169 into '.':
G    packages/fcl-passrc/src/pscanner.pp
G    packages/fcl-passrc/src/pparser.pp
--- Recording mergeinfo for merge of r34169 into '.':
 G   .

# revisions: 31366,31367,32183,32360,32374,32376,34113,34114,34132,34169

git-svn-id: branches/fixes_3_0@35971 -
This commit is contained in:
marco 2017-04-27 16:09:46 +00:00
parent 414a164463
commit 3803b78124
22 changed files with 644 additions and 239 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
.gitattributes vendored
View File

@ -15449,6 +15449,16 @@ utils/fpdoc/dw_txt.pp svneol=native#text/plain
utils/fpdoc/dw_xml.pp svneol=native#text/plain
utils/fpdoc/dwlinear.pp svneol=native#text/plain
utils/fpdoc/dwriter.pp svneol=native#text/plain
utils/fpdoc/examples/basedir/readme.txt svneol=native#text/plain
utils/fpdoc/examples/basedir/sample-project.xml svneol=native#text/plain
utils/fpdoc/examples/gentest.sh svneol=native#text/plain
utils/fpdoc/examples/project/readme.txt svneol=native#text/plain
utils/fpdoc/examples/project/sample-project.xml svneol=native#text/plain
utils/fpdoc/examples/simple/html.bat svneol=native#text/plain
utils/fpdoc/examples/simple/html.sh svneol=native#text/plain
utils/fpdoc/examples/simple/readme.txt svneol=native#text/plain
utils/fpdoc/examples/simple/testunit.pp svneol=native#text/plain
utils/fpdoc/examples/simple/testunit.xml svneol=native#text/plain
utils/fpdoc/fpclasschart.lpi svneol=native#text/plain
utils/fpdoc/fpclasschart.pp svneol=native#text/plain
utils/fpdoc/fpde/Makefile svneol=native#text/plain
@ -15490,7 +15500,6 @@ utils/fpdoc/fpdocstripper.lpi svneol=native#text/plain
utils/fpdoc/fpdocstripper.pp svneol=native#text/plain
utils/fpdoc/fpdocxmlopts.pas svneol=native#text/plain
utils/fpdoc/fpmake.pp svneol=native#text/plain
utils/fpdoc/gentest.sh svneol=native#text/plain
utils/fpdoc/images/minus.png -text svneol=unset#image/png
utils/fpdoc/images/plus.png -text svneol=unset#image/png
utils/fpdoc/intl/Makefile svneol=native#text/plain
@ -15511,8 +15520,6 @@ utils/fpdoc/mkfpdocproj.pp svneol=native#text/plain
utils/fpdoc/plusimage.inc svneol=native#text/plain
utils/fpdoc/sample-project.xml svneol=native#text/plain
utils/fpdoc/sh_pas.pp svneol=native#text/plain
utils/fpdoc/testunit.pp svneol=native#text/plain
utils/fpdoc/testunit.xml svneol=native#text/plain
utils/fpdoc/unitdiff.pp svneol=native#text/plain
utils/fpgmake/fpgmake.pp svneol=native#text/plain
utils/fpgmake/fpmake.cft svneol=native#text/plain

356
packages/fcl-passrc/src/pparser.pp
View File

@ -23,6 +23,53 @@ interface
uses SysUtils, Classes, PasTree, PScanner;
// message numbers
const
nErrNoSourceGiven = 2001;
nErrMultipleSourceFiles = 2002;
nParserError = 2003;
nParserErrorAtToken = 2004;
nParserUngetTokenError = 2005;
nParserExpectTokenError = 2006;
nParserForwardNotInterface = 2007;
nParserExpectVisibility = 2008;
nParserStrangeVisibility = 2009;
nParserExpectToken2Error = 2010;
nParserExpectedCommaRBracket = 2011;
nParserExpectedCommaSemicolon = 2012;
nParserExpectedAssignIn = 2013;
nParserExpectedCommaColon = 2014;
nErrUnknownOperatorType = 2015;
nParserOnlyOneArgumentCanHaveDefault = 2016;
nParserExpectedLBracketColon = 2017;
nParserExpectedSemiColonEnd = 2018;
nParserExpectedConstVarID = 2019;
nParserExpectedNested = 2020;
nParserExpectedColonID = 2021;
nParserSyntaxError = 2022;
nParserTypeSyntaxError = 2023;
nParserArrayTypeSyntaxError = 2024;
nParserExpectedIdentifier = 2026;
nParserNotAProcToken = 2026;
nRangeExpressionExpected = 2027;
nParserExpectCase = 2028;
nParserHelperNotAllowed = 2029;
nLogStartImplementation = 2030;
nLogStartInterface = 2031;
nParserNoConstructorAllowed = 2032;
nParserNoFieldsAllowed = 2033;
nParserInvalidRecordVisibility = 2034;
nErrRecordConstantsNotAllowed = 2035;
nErrRecordMethodsNotAllowed = 2036;
nErrRecordPropertiesNotAllowed = 2037;
nErrRecordVisibilityNotAllowed = 2038;
nParserTypeNotAllowedHere = 2039;
nParserNotAnOperand = 2040;
nParserArrayPropertiesCannotHaveDefaultValue = 2041;
nParserDefaultPropertyMustBeArray = 2042;
nParserUnknownProcedureType = 2043;
// resourcestring patterns of messages
resourcestring
SErrNoSourceGiven = 'No source file specified';
SErrMultipleSourceFiles = 'Please specify only one source file';
@ -62,6 +109,11 @@ resourcestring
SErrRecordMethodsNotAllowed = 'Record methods not allowed at this location.';
SErrRecordPropertiesNotAllowed = 'Record properties not allowed at this location.';
SErrRecordVisibilityNotAllowed = 'Record visibilities not allowed at this location.';
SParserTypeNotAllowedHere = 'Type "%s" not allowed here';
SParserNotAnOperand = 'Not an operand: (%d : %s)';
SParserArrayPropertiesCannotHaveDefaultValue = 'Array properties cannot have default value';
SParserDefaultPropertyMustBeArray = 'The default property must be an array property';
SParserUnknownProcedureType = 'Unknown procedure type "%d"';
type
TPasParserLogHandler = Procedure (Sender : TObject; Const Msg : String) of object;
@ -128,6 +180,12 @@ type
private
FCurModule: TPasModule;
FFileResolver: TBaseFileResolver;
FImplicitUses: TStrings;
FLastMsg: string;
FLastMsgArgs: TMessageArgs;
FLastMsgNumber: integer;
FLastMsgPattern: string;
FLastMsgType: TMessageType;
FLogEvents: TPParserLogEvents;
FOnLog: TPasParserLogHandler;
FOptions: TPOptions;
@ -158,8 +216,8 @@ type
Function SaveComments : String;
Function SaveComments(Const AValue : String) : String;
function LogEvent(E : TPParserLogEvent) : Boolean; inline;
Procedure DoLog(Const Msg : String; SkipSourceInfo : Boolean = False);overload;
Procedure DoLog(Const Fmt : String; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Msg : String; SkipSourceInfo : Boolean = False);overload;
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
function GetProcTypeFromToken(tk: TToken; IsClass: Boolean=False ): TProcType;
procedure ParseRecordFieldList(ARec: TPasRecordType; AEndToken: TToken; AllowMethods : Boolean);
procedure ParseRecordVariantParts(ARec: TPasRecordType; AEndToken: TToken);
@ -170,8 +228,11 @@ type
procedure ReadGenericArguments(List : TFPList;Parent : TPasElement);
function CheckProcedureArgs(Parent: TPasElement; Args: TFPList; Mandatory: Boolean): boolean;
function CheckVisibility(S: String; var AVisibility: TPasMemberVisibility): Boolean;
procedure ParseExc(const Msg: String);
procedure ParseExc(const Fmt: String; Args : Array of const);
procedure ParseExc(MsgNumber: integer; const Msg: String);
procedure ParseExc(MsgNumber: integer; const Fmt: String; Args : Array of const);
procedure ParseExcExpectedIdentifier;
procedure ParseExcSyntaxError;
procedure ParseExcTokenError(const Arg: string);
function OpLevel(t: TToken): Integer;
Function TokenToExprOp (AToken : TToken) : TExprOpCode;
function CreateElement(AClass: TPTreeElement; const AName: String; AParent: TPasElement): TPasElement;overload;
@ -195,6 +256,7 @@ type
public
constructor Create(AScanner: TPascalScanner; AFileResolver: TBaseFileResolver; AEngine: TPasTreeContainer);
Destructor Destroy; override;
procedure SetLastMsg(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const);
// General parsing routines
function CurTokenName: String;
function CurTokenText: String;
@ -262,6 +324,12 @@ type
Property CurModule : TPasModule Read FCurModule;
Property LogEvents : TPParserLogEvents Read FLogEvents Write FLogEvents;
Property OnLog : TPasParserLogHandler Read FOnLog Write FOnLog;
property ImplicitUses: TStrings read FImplicitUses;
property LastMsg: string read FLastMsg write FLastMsg;
property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber;
property LastMsgType: TMessageType read FLastMsgType write FLastMsgType;
property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern;
property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs;
end;
function ParseSource(AEngine: TPasTreeContainer;
@ -546,16 +614,34 @@ end;
TPasParser
---------------------------------------------------------------------}
procedure TPasParser.ParseExc(const Msg: String);
procedure TPasParser.ParseExc(MsgNumber: integer; const Msg: String);
begin
raise EParserError.Create(Format(SParserErrorAtToken, [Msg, CurTokenName, Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn])
ParseExc(MsgNumber,Msg,[]);
end;
procedure TPasParser.ParseExc(MsgNumber: integer; const Fmt: String;
Args: array of const);
begin
SetLastMsg(mtError,MsgNumber,Fmt,Args);
raise EParserError.Create(Format(SParserErrorAtToken,
[FLastMsg, CurTokenName, Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn])
{$ifdef addlocation}+' ('+inttostr(scanner.currow)+' '+inttostr(scanner.curcolumn)+')'{$endif},
Scanner.CurFilename, Scanner.CurRow, Scanner.CurColumn);
end;
procedure TPasParser.ParseExc(const Fmt: String; Args: array of const);
procedure TPasParser.ParseExcExpectedIdentifier;
begin
ParseExc(Format(Fmt,Args));
ParseExc(nParserExpectedIdentifier,SParserExpectedIdentifier);
end;
procedure TPasParser.ParseExcSyntaxError;
begin
ParseExc(nParserSyntaxError,SParserSyntaxError);
end;
procedure TPasParser.ParseExcTokenError(const Arg: string);
begin
ParseExc(nParserExpectTokenError,SParserExpectTokenError,[Arg]);
end;
constructor TPasParser.Create(AScanner: TPascalScanner;
@ -573,10 +659,13 @@ begin
If FEngine.NeedComments then
FScanner.SkipComments:=Not FEngine.NeedComments;
end;
FImplicitUses := TStringList.Create;
FImplicitUses.Add('System'); // system always implicitely first.
end;
destructor TPasParser.Destroy;
begin
FreeAndNil(FImplicitUses);
FreeAndNil(FCommentsBuffer[0]);
FreeAndNil(FCommentsBuffer[1]);
if Assigned(FEngine) then
@ -666,7 +755,7 @@ procedure TPasParser.UngetToken;
begin
if FTokenBufferIndex = 0 then
ParseExc(SParserUngetTokenError)
ParseExc(nParserUngetTokenError,SParserUngetTokenError)
else begin
Dec(FTokenBufferIndex);
if FTokenBufferIndex>0 then
@ -686,7 +775,7 @@ end;
procedure TPasParser.CheckToken(tk: TToken);
begin
if (CurToken<>tk) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tk]]));
ParseExcTokenError(TokenInfos[tk]);
end;
@ -789,7 +878,7 @@ begin
begin
NextToken;
if Not (CurToken in [tkArray, tkRecord, tkObject, tkClass]) then
ParseExc(Format(SParserExpectTokenError,['ARRAY, RECORD, OBJECT or CLASS']))
ParseExcTokenError('ARRAY, RECORD, OBJECT or CLASS');
end;
end;
@ -976,10 +1065,10 @@ begin
if CurToken = tkBraceClose then
Break
else if not (CurToken=tkComma) then
ParseExc(SParserExpectedCommaRBracket);
ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
end
else if not (CurToken=tkComma) then
ParseExc(SParserExpectedCommaRBracket)
ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket)
end;
except
FreeAndNil(Result);
@ -1021,7 +1110,7 @@ begin
begin
CH:=False;
if (CurToken in FullTypeTokens) then
ParseExc('Type '+CurtokenText+' not allowed here');
ParseExc(nParserTypeNotAllowedHere,SParserTypeNotAllowedHere,[CurtokenText]);
end;
Try
case CurToken of
@ -1125,7 +1214,7 @@ begin
end
end
else
ParseExc(SParserArrayTypeSyntaxError);
ParseExc(nParserArrayTypeSyntaxError,SParserArrayTypeSyntaxError);
end;
except
FreeAndNil(Result);
@ -1231,7 +1320,7 @@ begin
tkDot : Result:=eopSubIdent;
tkCaret : Result:=eopDeref;
else
ParseExc(format('Not an operand: (%d : %s)',[AToken,TokenInfos[AToken]]));
ParseExc(nParserNotAnOperand,SParserNotAnOperand,[AToken,TokenInfos[AToken]]);
end;
end;
@ -1294,7 +1383,7 @@ begin
NextToken;
if (length(CurTokenText)=0) or not (CurTokenText[1] in ['A'..'_']) then begin
UngetToken;
ParseExc(SParserExpectedIdentifier);
ParseExcExpectedIdentifier;
end;
x:=TPrimitiveExpr.Create(AParent,pekString, '@'+CurTokenText);
end;
@ -1303,12 +1392,12 @@ begin
NextToken;
if not (length(CurTokenText)=1) or not (CurTokenText[1] in ['A'..'_']) then begin
UngetToken;
ParseExc(SParserExpectedIdentifier);
ParseExcExpectedIdentifier;
end;
x:=TPrimitiveExpr.Create(AParent,pekString, '^'+CurTokenText);
end;
else
ParseExc(SParserExpectedIdentifier);
ParseExcExpectedIdentifier;
end;
if x.Kind<>pekSet then NextToken;
@ -1327,7 +1416,7 @@ begin
else
begin
UngetToken;
ParseExc(SParserExpectedIdentifier);
ParseExcExpectedIdentifier;
end;
x:=b;
end;
@ -1547,7 +1636,7 @@ begin
// Writeln('Bin ',NotBinary ,' or EOE ',isEndOfExp, ' Ex ',Assigned(x),' stack ',ExpStack.Count);
until NotBinary or isEndOfExp;
if not NotBinary then ParseExc(SParserExpectedIdentifier);
if not NotBinary then ParseExcExpectedIdentifier;
while opstack.Count>0 do PopAndPushOperator;
@ -1639,13 +1728,13 @@ begin
else
// Binary expression! ((128 div sizeof(longint)) - 3); ;
Result:=DoParseExpression(AParent,x);
if CurToken<>tkBraceClose then ParseExc(SParserExpectedCommaRBracket);
if CurToken<>tkBraceClose then ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
NextToken;
if CurToken <> tkSemicolon then // the continue of expresion
Result:=DoParseExpression(AParent,Result);
Exit;
end;
if CurToken<>tkBraceClose then ParseExc(SParserExpectedCommaRBracket);
if CurToken<>tkBraceClose then ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
NextToken;
end;
end;
@ -1745,7 +1834,7 @@ begin
else
ungettoken;
ParseProgram(Module,True);
// ParseExc(Format(SParserExpectTokenError, ['unit']));
// ParseExcTokenError('unit');
end;
end;
@ -1777,7 +1866,7 @@ begin
// ExpectToken(tkSemicolon);
ExpectToken(tkInterface);
If LogEvent(pleInterface) then
DoLog(SLogStartInterface );
DoLog(mtInfo,nLogStartInterface,SLogStartInterface);
ParseInterface;
finally
FCurModule:=nil;
@ -1815,14 +1904,14 @@ begin
PP.InputFile:=ExpectIdentifier;
NextToken;
if Not (CurToken in [tkBraceClose,tkComma]) then
ParseExc(SParserExpectedCommaRBracket);
ParseExc(nParserExpectedCommaRBracket,SParserExpectedCommaRBracket);
If (CurToken=tkComma) then
PP.OutPutFile:=ExpectIdentifier;
ExpectToken(tkBraceClose);
NextToken;
end;
if (CurToken<>tkSemicolon) then
ParseExc(Format(SParserExpectTokenError,[';']));
ParseExcTokenError(';');
end;
Section := TProgramSection(CreateElement(TProgramSection, '', CurModule));
PP.ProgramSection := Section;
@ -1850,7 +1939,7 @@ begin
end;
NextToken;
if (CurToken<>tkSemicolon) then
ParseExc(Format(SParserExpectTokenError,[';']));
ParseExcTokenError(';');
Section := TLibrarySection(CreateElement(TLibrarySection, '', CurModule));
PP.LibrarySection := Section;
ParseDeclarations(Section);
@ -1964,7 +2053,7 @@ begin
else
Result:=ptOperator;
else
ParseExc(SParserNotAProcToken);
ParseExc(nParserNotAProcToken,SParserNotAProcToken);
end;
end;
@ -1993,7 +2082,7 @@ begin
tkend:
begin
If (CurModule is TPasProgram) and (CurModule.InitializationSection=Nil) then
ParseExc(Format(SParserExpectTokenError,['begin']));
ParseExcTokenError('begin');
ExpectToken(tkDot);
break;
end;
@ -2003,7 +2092,7 @@ begin
If Not Engine.InterfaceOnly then
begin
If LogEvent(pleImplementation) then
DoLog(SLogStartImplementation);
DoLog(mtInfo,nLogStartImplementation,SLogStartImplementation);
ParseImplementation;
end;
break;
@ -2026,7 +2115,7 @@ begin
if Declarations is TPasSection then
ParseUsesList(TPasSection(Declarations))
else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
tkConst:
CurBlock := declConst;
tkexports:
@ -2158,13 +2247,13 @@ begin
Declarations.properties.add(PropEl);
end;
else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
end;
tkGeneric:
begin
if CurBlock <> declType then
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
TypeName := ExpectIdentifier;
ClassEl := TPasClassType(Engine.CreateElement(TPasClassType,TypeName,Declarations, Scanner.CurFilename, Scanner.CurRow));
ClassEl.ObjKind:=okGeneric;
@ -2196,7 +2285,7 @@ begin
break;
end
else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
tklabel:
begin
@ -2204,7 +2293,7 @@ begin
ParseLabels(Declarations);
end;
else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
end;
end;
@ -2226,9 +2315,15 @@ procedure TPasParser.ParseUsesList(ASection: TPasSection);
var
AUnitName: String;
Element: TPasElement;
i: Integer;
begin
If not (Asection.ClassType=TImplementationSection) Then // interface,program,library,package
Element:=CheckUnit('System'); // system always implicitely first.
begin
// load implicit units, like 'System'
for i:=0 to ImplicitUses.Count-1 do
CheckUnit(ImplicitUses[i]);
end;
Repeat
AUnitName := ExpectIdentifier;
NextToken;
@ -2250,7 +2345,7 @@ begin
end;
if Not (CurToken in [tkComma,tkSemicolon]) then
ParseExc(SParserExpectedCommaSemicolon);
ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon);
Until (CurToken=tkSemicolon);
end;
@ -2305,8 +2400,8 @@ begin
List.Add(CreateElement(TPasGenericTemplateType,N,Parent));
NextToken;
if not (CurToken in [tkComma, tkGreaterThan]) then
ParseExc(Format(SParserExpectToken2Error,
[TokenInfos[tkComma], TokenInfos[tkGreaterThan]]));
ParseExc(nParserExpectToken2Error,SParserExpectToken2Error,
[TokenInfos[tkComma], TokenInfos[tkGreaterThan]]);
until CurToken = tkGreaterThan;
end;
@ -2323,14 +2418,14 @@ begin
if Full then
begin
If not (CurToken=tkEqual) then
ParseExc(Format(SParserExpectTokenError,[TokenInfos[tkEqual]]));
ParseExcTokenError(TokenInfos[tkEqual]);
end;
NextToken;
PE:=DoParseExpression(Result,Nil);
if not ((PE is TBinaryExpr) and (TBinaryExpr(PE).Kind=pekRange)) then
begin
FreeAndNil(PE);
ParseExc(SRangeExpressionExpected);
ParseExc(nRangeExpressionExpected,SRangeExpressionExpected);
end;
Result.RangeExpr:=PE as TBinaryExpr;
UngetToken;
@ -2362,7 +2457,7 @@ begin
E.ExportName:=DoParseExpression(E,Nil)
end;
if not (CurToken in [tkComma,tkSemicolon]) then
ParseExc(SParserExpectedCommaSemicolon);
ParseExc(nParserExpectedCommaSemicolon,SParserExpectedCommaSemicolon);
until (CurToken=tkSemicolon);
end;
@ -2488,12 +2583,12 @@ begin
if (CurToken in [tkString,tkIdentifier]) then
Result := Result + CurTokenText
else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
ExportName:=CurTokenText;
NextToken;
end
else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
end;
end;
@ -2520,7 +2615,7 @@ begin
VarNames.Add(CurTokenString);
NextToken;
if Not (CurToken in [tkComma,tkColon]) then
ParseExc(SParserExpectedCommaColon);
ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon);
if CurToken=tkComma then
ExpectIdentifier;
Until (CurToken=tkColon);
@ -2590,19 +2685,31 @@ begin
Result:=E in FLogEvents;
end;
procedure TPasParser.DoLog(const Msg: String; SkipSourceInfo: Boolean);
procedure TPasParser.SetLastMsg(MsgType: TMessageType; MsgNumber: integer;
const Fmt: String; Args: array of const);
begin
If Assigned(FOnLog) then
if SkipSourceInfo or not assigned(scanner) then
FOnLog(Self,Msg)
else
FOnLog(Self,Format('%s(%d) : %s',[Scanner.CurFilename,SCanner.CurRow,Msg]));
FLastMsgType := MsgType;
FLastMsgNumber := MsgNumber;
FLastMsgPattern := Fmt;
FLastMsg := Format(Fmt,Args);
CreateMsgArgs(FLastMsgArgs,Args);
end;
procedure TPasParser.DoLog(const Fmt: String; Args: array of const;
SkipSourceInfo: Boolean);
procedure TPasParser.DoLog(MsgType: TMessageType; MsgNumber: integer;
const Msg: String; SkipSourceInfo: Boolean);
begin
DoLog(Format(Fmt,Args),SkipSourceInfo);
DoLog(MsgType,MsgNumber,Msg,[],SkipSourceInfo);
end;
procedure TPasParser.DoLog(MsgType: TMessageType; MsgNumber: integer;
const Fmt: String; Args: array of const; SkipSourceInfo: Boolean);
begin
SetLastMsg(MsgType,MsgNumber,Fmt,Args);
If Assigned(FOnLog) then
if SkipSourceInfo or not assigned(scanner) then
FOnLog(Self,FLastMsg)
else
FOnLog(Self,Format('%s(%d) : %s',[Scanner.CurFilename,Scanner.CurRow,FLastMsg]));
end;
procedure TPasParser.ParseInlineVarDecl(Parent: TPasElement; List: TFPList;
@ -2616,7 +2723,7 @@ begin
if ClosingBrace then
include(tt,tkBraceClose);
if not (CurToken in tt) then
ParseExc(SParserExpectedSemiColonEnd);
ParseExc(nParserExpectedSemiColonEnd,SParserExpectedSemiColonEnd);
end;
// Starts after the variable name
@ -2668,7 +2775,7 @@ begin
end else if CurToken = tkIdentifier then
Name := CurTokenString
else
ParseExc(SParserExpectedConstVarID);
ParseExc(nParserExpectedConstVarID,SParserExpectedConstVarID);
ArgNames.Add(Name);
NextToken;
if CurToken = tkColon then
@ -2682,7 +2789,7 @@ begin
break
end
else if CurToken <> tkComma then
ParseExc(SParserExpectedCommaColon);
ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon);
end;
Value:=Nil;
if not IsUntyped then
@ -2695,7 +2802,7 @@ begin
if (ArgNames.Count>1) then
begin
FreeAndNil(ArgType);
ParseExc(SParserOnlyOneArgumentCanHaveDefault);
ParseExc(nParserOnlyOneArgumentCanHaveDefault,SParserOnlyOneArgumentCanHaveDefault);
end;
NextToken;
Value := DoParseExpression(Parent,Nil);
@ -2744,7 +2851,7 @@ begin
if not Result then
begin
if Mandatory then
ParseExc(SParserExpectedLBracketColon)
ParseExc(nParserExpectedLBracketColon,SParserExpectedLBracketColon)
else
UngetToken;
end
@ -2795,7 +2902,7 @@ begin
begin
NextToken;
if not (CurToken in [tkString,tkIdentifier]) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkString]]));
ParseExcTokenError(TokenInfos[tkString]);
E:=DoParseExpression(Parent);
if Assigned(P) then
P.LibrarySymbolName:=E;
@ -2820,19 +2927,19 @@ begin
begin
NextToken; // Should be export name string.
if not (CurToken in [tkString,tkIdentifier]) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkString]]));
ParseExcTokenError(TokenInfos[tkString]);
E:=DoParseExpression(Parent);
if parent is TPasProcedure then
TPasProcedure(Parent).PublicName:=E;
if (CurToken <> tkSemicolon) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkSemicolon]]));
ParseExcTokenError(TokenInfos[tkSemicolon]);
end;
end
else if (pm=pmForward) then
begin
if (Parent.Parent is TInterfaceSection) then
begin
ParseExc(SParserForwardNotInterface);
ParseExc(nParserForwardNotInterface,SParserForwardNotInterface);
UngetToken;
end;
end
@ -2912,7 +3019,7 @@ begin
if (CurToken=tkColon) then
TPasFunctionType(Element).ResultEl.Name := 'Result'
else
ParseExc(SParserExpectedColonID);
ParseExc(nParserExpectedColonID,SParserExpectedColonID);
TPasFunctionType(Element).ResultEl.ResultType := ParseType(Parent)
end;
end;
@ -2928,7 +3035,7 @@ begin
begin
expectToken(tkIdentifier);
if (lowerCase(CurTokenString)<>'nested') then
ParseExc(SParserExpectedNested);
ParseExc(nParserExpectedNested,SParserExpectedNested);
Element.isNested:=True;
end
else
@ -3109,13 +3216,13 @@ begin
else if CurToken = tkIdentifier then
Result.StoredAccessorName := CurTokenString
else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
NextToken;
end;
if CurTokenIsIdentifier('DEFAULT') then
begin
if isArray then
ParseExc('Array properties cannot have default value');
ParseExc(nParserArrayPropertiesCannotHaveDefaultValue,SParserArrayPropertiesCannotHaveDefaultValue);
NextToken;
Result.DefaultExpr := DoParseExpression(Result);
// NextToken;
@ -3131,7 +3238,7 @@ begin
if CurTokenIsIdentifier('DEFAULT') then
begin
if (Result.VarType<>Nil) and (not isArray) then
ParseExc('The default property must be an array property');
ParseExc(nParserDefaultPropertyMustBeArray,SParserDefaultPropertyMustBeArray);
NextToken;
if CurToken = tkSemicolon then
begin
@ -3318,7 +3425,7 @@ begin
TPasImplTry(CurBlock).ElseBranch:=TPasImplTryExceptElse(el);
CurBlock:=TPasImplTryExceptElse(el);
end else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
tkwhile:
begin
// while Condition do
@ -3347,7 +3454,7 @@ begin
Left:=Nil;
Right:=Nil;
if Not (CurToken in [tkAssign,tkIn]) then
ParseExc(SParserExpectedAssignIn);
ParseExc(nParserExpectedAssignIn,SParserExpectedAssignIn);
if (CurToken=tkAssign) then
lt:=ltNormal
else
@ -3358,14 +3465,14 @@ begin
if (Lt=ltNormal) then
begin
if Not (CurToken in [tkTo,tkDownTo]) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkTo]]));
ParseExcTokenError(TokenInfos[tkTo]);
if CurToken=tkdownto then
Lt:=ltDown;
NextToken;
Right:=DoParseExpression(Parent);
end;
if (CurToken<>tkDo) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkDo]]));
ParseExcTokenError(TokenInfos[tkDo]);
except
FreeAndNil(Left);
FreeAndNil(Right);
@ -3392,7 +3499,7 @@ begin
repeat
if CurToken=tkdo then break;
if CurToken<>tkComma then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkdo]]));
ParseExcTokenError(TokenInfos[tkdo]);
NextToken;
Left:=DoParseExpression(Parent);
//writeln(i,'WITH ...,Expr="',Expr,'" Token=',CurTokenText);
@ -3416,7 +3523,7 @@ begin
tkend:
begin
if CurBlock.Elements.Count=0 then
ParseExc(SParserExpectCase);
ParseExc(nParserExpectCase,SParserExpectCase);
break; // end without else
end;
tkelse:
@ -3429,24 +3536,33 @@ begin
end
else
// read case values
repeat
Left:=DoParseExpression(Parent);
//writeln(i,'CASE value="',Expr,'" Token=',CurTokenText);
if CurBlock is TPasImplCaseStatement then
TPasImplCaseStatement(CurBlock).Expressions.Add(Left)
else
begin
el:=TPasImplCaseStatement(CreateElement(TPasImplCaseStatement,'',CurBlock));
TPasImplCaseStatement(el).AddExpression(Left);
CurBlock.AddElement(el);
CurBlock:=TPasImplCaseStatement(el);
end;
//writeln(i,'CASE after value Token=',CurTokenText);
if (CurToken=tkComma) then
NextToken
else if (CurToken<>tkColon) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkComma]]))
until Curtoken=tkColon;
if (curToken=tkIdentifier) and (LowerCase(CurtokenString)='otherwise') then
begin
// create case-else block
el:=TPasImplCaseElse(CreateElement(TPasImplCaseElse,'',CurBlock));
TPasImplCaseOf(CurBlock).ElseBranch:=TPasImplCaseElse(el);
CreateBlock(TPasImplCaseElse(el));
break;
end
else
repeat
Left:=DoParseExpression(Parent);
//writeln(i,'CASE value="',Expr,'" Token=',CurTokenText);
if CurBlock is TPasImplCaseStatement then
TPasImplCaseStatement(CurBlock).Expressions.Add(Left)
else
begin
el:=TPasImplCaseStatement(CreateElement(TPasImplCaseStatement,'',CurBlock));
TPasImplCaseStatement(el).AddExpression(Left);
CurBlock.AddElement(el);
CurBlock:=TPasImplCaseStatement(el);
end;
//writeln(i,'CASE after value Token=',CurTokenText);
if (CurToken=tkComma) then
NextToken
else if (CurToken<>tkColon) then
ParseExcTokenError(TokenInfos[tkComma]);
until Curtoken=tkColon;
// read statement
ParseStatement(CurBlock,SubBlock);
CloseBlock;
@ -3454,7 +3570,7 @@ begin
begin
NextToken;
if not (CurToken in [tkSemicolon,tkelse,tkend]) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkSemicolon]]));
ParseExcTokenError(TokenInfos[tkSemicolon]);
if CurToken<>tkSemicolon then
UngetToken;
end;
@ -3484,7 +3600,7 @@ begin
TPasImplTry(CurBlock).FinallyExcept:=TPasImplTryFinally(el);
CurBlock:=TPasImplTryFinally(el);
end else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
tkexcept:
begin
@ -3500,7 +3616,7 @@ begin
TPasImplTry(CurBlock).FinallyExcept:=TPasImplTryExcept(el);
CurBlock:=TPasImplTryExcept(el);
end else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
tkon:
begin
@ -3530,7 +3646,7 @@ begin
CurBlock:=TPasImplExceptOn(el);
ExpectToken(tkDo);
end else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
tkraise:
begin
@ -3573,7 +3689,7 @@ begin
if CloseBlock then break; // close try
if CloseStatement(false) then break;
end else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
tkSemiColon:
if CloseStatement(true) then break;
@ -3593,7 +3709,7 @@ begin
//WriteLn(i,'UNTIL Condition="',Condition,'" Token=',CurTokenString);
if CloseBlock then break;
end else
ParseExc(SParserSyntaxError);
ParseExcSyntaxError;
end;
else
left:=DoParseExpression(nil);
@ -3619,7 +3735,7 @@ begin
tkColon:
begin
if not (left is TPrimitiveExpr) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkSemicolon]]));
ParseExcTokenError(TokenInfos[tkSemicolon]);
// label mark. todo: check mark identifier in the list of labels
el:=TPasImplLabelMark(CreateElement(TPasImplLabelMark,'', CurBlock));
TPasImplLabelMark(el).LabelId:=TPrimitiveExpr(left).Value;
@ -3651,7 +3767,7 @@ begin
Labels.Labels.Add(ExpectIdentifier);
NextToken;
if not (CurToken in [tkSemicolon, tkComma]) then
ParseExc(Format(SParserExpectTokenError, [TokenInfos[tkSemicolon]]));
ParseExcTokenError(TokenInfos[tkSemicolon]);
until CurToken=tkSemicolon;
end;
@ -3671,7 +3787,7 @@ begin
ptOperator : Result:=TPasOperator;
ptClassOperator : Result:=TPasClassOperator;
else
ParseExc('Unknown procedure Type '+intToStr(Ord(ProcType)));
ParseExc(nParserUnknownProcedureType,SParserUnknownProcedureType,[Ord(ProcType)]);
end;
end;
@ -3710,7 +3826,7 @@ begin
else
OT:=TPasOperator.NameToOperatorType(CurTokenString);
if (ot=otUnknown) then
ParseExc(SErrUnknownOperatorType,[CurTokenString]);
ParseExc(nErrUnknownOperatorType,SErrUnknownOperatorType,[CurTokenString]);
Name:=OperatorNames[Ot];
end;
PC:=GetProcedureClass(ProcType);
@ -3772,7 +3888,7 @@ begin
NextToken;
V.Values.Add(DoParseExpression(ARec));
if Not (CurToken in [tkComma,tkColon]) then
ParseExc(SParserExpectedCommaColon);
ParseExc(nParserExpectedCommaColon,SParserExpectedCommaColon);
Until (curToken=tkColon);
ExpectToken(tkBraceOpen);
NextToken;
@ -3826,7 +3942,7 @@ begin
tkConst:
begin
if Not AllowMethods then
ParseExc(SErrRecordConstantsNotAllowed);
ParseExc(nErrRecordConstantsNotAllowed,SErrRecordConstantsNotAllowed);
ExpectToken(tkIdentifier);
Cons:=ParseConstDecl(ARec);
Cons.Visibility:=v;
@ -3835,15 +3951,15 @@ begin
tkClass:
begin
if Not AllowMethods then
ParseExc(SErrRecordMethodsNotAllowed);
ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed);
if isClass then
ParseExc(SParserTypeSyntaxError);
ParseExc(nParserTypeSyntaxError,SParserTypeSyntaxError);
isClass:=True;
end;
tkProperty:
begin
if Not AllowMethods then
ParseExc(SErrRecordPropertiesNotAllowed);
ParseExc(nErrRecordPropertiesNotAllowed,SErrRecordPropertiesNotAllowed);
ExpectToken(tkIdentifier);
Prop:=ParseProperty(ARec,CurtokenString,v);
Prop.isClass:=isClass;
@ -3854,7 +3970,7 @@ begin
tkFunction :
begin
if Not AllowMethods then
ParseExc(SErrRecordMethodsNotAllowed);
ParseExc(nErrRecordMethodsNotAllowed,SErrRecordMethodsNotAllowed);
ProcType:=GetProcTypeFromtoken(CurToken,isClass);
Proc:=ParseProcedureOrFunctionDecl(ARec,ProcType,v);
if Proc.Parent is TPasOverloadedProc then
@ -3868,9 +3984,9 @@ begin
if CheckVisibility(CurtokenString,v) then
begin
If not (po_delphi in Scanner.Options) then
ParseExc(SErrRecordVisibilityNotAllowed);
ParseExc(nErrRecordVisibilityNotAllowed,SErrRecordVisibilityNotAllowed);
if not (v in [visPrivate,visPublic,visStrictPrivate]) then
ParseExc(SParserInvalidRecordVisibility);
ParseExc(nParserInvalidRecordVisibility,SParserInvalidRecordVisibility);
NextToken;
Continue;
end;
@ -3894,7 +4010,7 @@ begin
ParseRecordVariantParts(ARec,AEndToken);
end;
else
ParseExc(SParserTypeSyntaxError);
ParseExc(nParserTypeSyntaxError,SParserTypeSyntaxError);
end;
If CurToken<>tkClass then
isClass:=False;
@ -3963,11 +4079,11 @@ begin
visPrivate : AVisibility:=visStrictPrivate;
visProtected : AVisibility:=visStrictProtected;
else
ParseExc(Format(SParserStrangeVisibility,[S]));
ParseExc(nParserStrangeVisibility,SParserStrangeVisibility,[S]);
end
end
else if B then
ParseExc(SParserExpectVisibility);
ParseExc(nParserExpectVisibility,SParserExpectVisibility);
end;
procedure TPasParser.ProcessMethod(AType: TPasClassType; IsClass : Boolean; AVisibility : TPasMemberVisibility);
@ -4073,7 +4189,7 @@ begin
tkIdentifier:
begin
if (AType.ObjKind=okInterface) then
ParseExc(SParserNoFieldsAllowed);
ParseExc(nParserNoFieldsAllowed,SParserNoFieldsAllowed);
if CurToken=tkVar then
ExpectToken(tkIdentifier);
SaveComments;
@ -4084,7 +4200,7 @@ begin
begin
SaveComments;
if (Curtoken in [tkConstructor,tkDestructor]) and (AType.ObjKind in [okInterface,okRecordHelper]) then
ParseExc(SParserNoConstructorAllowed);
ParseExc(nParserNoConstructorAllowed,SParserNoConstructorAllowed);
ProcessMethod(AType,False,CurVisibility);
end;
tkclass:
@ -4104,7 +4220,7 @@ begin
AType.Members.Add(ParseProperty(AType,CurtokenString,CurVisibility));
end
else
ParseExc(SParserTypeSyntaxError)
ParseExc(nParserTypeSyntaxError,SParserTypeSyntaxError)
end;
tkProperty:
begin
@ -4155,7 +4271,7 @@ begin
if (AType.ObjKind in [okClassHelper,okRecordHelper]) then
begin
if (CurToken<>tkFor) then
ParseExc(Format(SParserExpectTokenError,[TokenInfos[tkFor]]));
ParseExcTokenError(TokenInfos[tkFor]);
AType.HelperForType:=ParseType(Nil);
NextToken;
end;
@ -4168,7 +4284,7 @@ begin
NextToken;
AType.GUIDExpr:=DoParseExpression(AType);
if (CurToken<>tkSquaredBraceClose) then
ParseExc(Format(SParserExpectTokenError,[TokenInfos[tkSquaredBraceClose]]));
ParseExcTokenError(TokenInfos[tkSquaredBraceClose]);
NextToken;
end;
ParseClassMembers(AType);
@ -4202,7 +4318,7 @@ begin
if (CurToken = tkHelper) then
begin
if Not (AObjKind in [okClass,okRecordHelper]) then
ParseExc(Format(SParserHelperNotAllowed,[ObjKindNames[AObjKind]]));
ParseExc(nParserHelperNotAllowed,SParserHelperNotAllowed,[ObjKindNames[AObjKind]]);
if (AObjKind = okClass) then
AObjKind:=okClassHelper;
NextToken;

171
packages/fcl-passrc/src/pscanner.pp
View File

@ -23,6 +23,24 @@ interface
uses SysUtils, Classes;
// message numbers
const
nErrInvalidCharacter = 1001;
nErrOpenString = 1002;
nErrIncludeFileNotFound = 1003;
nErrIfXXXNestingLimitReached = 1004;
nErrInvalidPPElse = 1005;
nErrInvalidPPEndif = 1006;
nLogOpeningFile = 1007;
nLogLineNumber = 1008;
nLogIFDefAccepted = 1009;
nLogIFDefRejected = 1010;
nLogIFNDefAccepted = 1011;
nLogIFNDefRejected = 1012;
nLogIFOPTIgnored = 1013;
nLogIFIgnored = 1014;
// resourcestring patterns of messages
resourcestring
SErrInvalidCharacter = 'Invalid character ''%s''';
SErrOpenString = 'string exceeds end of line';
@ -40,6 +58,18 @@ resourcestring
SLogIFIgnored = 'IF %s found, ignoring (rejected).';
type
TMessageType = (
mtFatal,
mtError,
mtWarning,
mtNote,
mtHint,
mtInfo,
mtDebug
);
TMessageTypes = set of TMessageType;
TMessageArgs = array of string;
TToken = (
tkEOF,
@ -305,6 +335,11 @@ type
TPascalScanner = class
private
FLastMsg: string;
FLastMsgArgs: TMessageArgs;
FLastMsgNumber: integer;
FLastMsgPattern: string;
FLastMsgType: TMessageType;
FFileResolver: TBaseFileResolver;
FCurSourceFile: TLineReader;
FCurFilename: string;
@ -332,10 +367,11 @@ type
function GetCurColumn: Integer;
procedure SetOptions(AValue: TPOptions);
protected
Procedure DoLog(Const Msg : String; SkipSourceInfo : Boolean = False);overload;
Procedure DoLog(Const Fmt : String; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
procedure Error(const Msg: string);overload;
procedure Error(const Msg: string; Args: array of Const);overload;
procedure SetCurMsg(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const);
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Msg : String; SkipSourceInfo : Boolean = False);overload;
Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
procedure Error(MsgNumber: integer; const Msg: string);overload;
procedure Error(MsgNumber: integer; const Fmt: string; Args: array of Const);overload;
procedure HandleDefine(Param: String); virtual;
procedure HandleIncludeFile(Param: String); virtual;
procedure HandleUnDefine(Param: String);virtual;
@ -372,6 +408,12 @@ type
Property Options : TPOptions Read FOptions Write SetOptions;
Property LogEvents : TPScannerLogEvents Read FLogEvents Write FLogEvents;
Property OnLog : TPScannerLogHandler Read FOnLog Write FOnLog;
property LastMsg: string read FLastMsg write FLastMsg;
property LastMsgNumber: integer read FLastMsgNumber write FLastMsgNumber;
property LastMsgType: TMessageType read FLastMsgType write FLastMsgType;
property LastMsgPattern: string read FLastMsgPattern write FLastMsgPattern;
property LastMsgArgs: TMessageArgs read FLastMsgArgs write FLastMsgArgs;
end;
const
@ -496,6 +538,8 @@ function FilenameIsWinAbsolute(const TheFilename: string): boolean;
function FilenameIsUnixAbsolute(const TheFilename: string): boolean;
function IsNamedToken(Const AToken : String; Out T : TToken) : Boolean;
procedure CreateMsgArgs(var MsgArgs: TMessageArgs; Args: array of const);
implementation
Var
@ -576,6 +620,39 @@ begin
T:=SortedTokens[I];
end;
procedure CreateMsgArgs(var MsgArgs: TMessageArgs; Args: array of const);
var
i: Integer;
begin
SetLength(MsgArgs, High(Args)-Low(Args)+1);
for i:=Low(Args) to High(Args) do
begin
case Args[i].VType of
vtInteger: MsgArgs[i] := IntToStr(Args[i].VInteger);
vtBoolean: MsgArgs[i] := BoolToStr(Args[i].VBoolean);
vtChar: MsgArgs[i] := Args[i].VChar;
{$ifndef FPUNONE}
vtExtended: ; // Args[i].VExtended^;
{$ENDIF}
vtString: MsgArgs[i] := Args[i].VString^;
vtPointer: ; // Args[i].VPointer;
vtPChar: MsgArgs[i] := Args[i].VPChar;
vtObject: ; // Args[i].VObject;
vtClass: ; // Args[i].VClass;
vtWideChar: MsgArgs[i] := AnsiString(Args[i].VWideChar);
vtPWideChar: MsgArgs[i] := Args[i].VPWideChar;
vtAnsiString: MsgArgs[i] := AnsiString(Args[i].VAnsiString);
vtCurrency: ; // Args[i].VCurrency^);
vtVariant: ; // Args[i].VVariant^);
vtInterface: ; // Args[i].VInterface^);
vtWidestring: MsgArgs[i] := AnsiString(WideString(Args[i].VWideString));
vtInt64: MsgArgs[i] := IntToStr(Args[i].VInt64^);
vtQWord: MsgArgs[i] := IntToStr(Args[i].VQWord^);
vtUnicodeString:MsgArgs[i] := AnsiString(UnicodeString(Args[i].VUnicodeString));
end;
end;
end;
type
TIncludeStackItem = class
SourceFile: TLineReader;
@ -1020,7 +1097,7 @@ begin
Clearfiles;
FCurSourceFile := FileResolver.FindSourceFile(AFilename);
if LogEvent(sleFile) then
DoLog(SLogOpeningFile,[AFileName],True);
DoLog(mtInfo,nLogOpeningFile,SLogOpeningFile,[AFileName],True);
FCurFilename := AFilename;
FileResolver.BaseDirectory := IncludeTrailingPathDelimiter(ExtractFilePath(AFilename));
end;
@ -1069,14 +1146,17 @@ begin
// Writeln(Result, '(',CurTokenString,')');
end;
procedure TPascalScanner.Error(const Msg: string);
procedure TPascalScanner.Error(MsgNumber: integer; const Msg: string);
begin
SetCurMsg(mtError,MsgNumber,Msg,[]);
raise EScannerError.Create(Msg);
end;
procedure TPascalScanner.Error(const Msg: string; Args: array of Const);
procedure TPascalScanner.Error(MsgNumber: integer; const Fmt: string;
Args: array of const);
begin
raise EScannerError.CreateFmt(Msg, Args);
SetCurMsg(mtError,MsgNumber,Fmt,Args);
raise EScannerError.CreateFmt(Fmt, Args);
end;
function TPascalScanner.DoFetchTextToken:TToken;
@ -1122,7 +1202,7 @@ begin
break;
if TokenStr[0] = #0 then
Error(SErrOpenString);
Error(nErrOpenString,SErrOpenString);
Inc(TokenStr);
end;
@ -1141,7 +1221,7 @@ begin
end;
Procedure TPascalScanner.PushStackItem;
procedure TPascalScanner.PushStackItem;
Var
SI: TIncludeStackItem;
@ -1160,7 +1240,7 @@ begin
FCurRow := 0;
end;
Procedure TPascalScanner.HandleIncludeFile(Param : String);
procedure TPascalScanner.HandleIncludeFile(Param: String);
begin
PushStackItem;
@ -1171,12 +1251,12 @@ begin
end;
FCurSourceFile := FileResolver.FindIncludeFile(Param);
if not Assigned(FCurSourceFile) then
Error(SErrIncludeFileNotFound, [Param]);
Error(nErrIncludeFileNotFound, SErrIncludeFileNotFound, [Param]);
FCurFilename := Param;
if FCurSourceFile is TFileLineReader then
FCurFilename := TFileLineReader(FCurSourceFile).Filename; // nicer error messages
If LogEvent(sleFile) then
DoLog(SLogOpeningFile,[FCurFileName],True);
DoLog(mtInfo,nLogOpeningFile,SLogOpeningFile,[FCurFileName],True);
end;
function TPascalScanner.HandleMacro(AIndex : integer) : TToken;
@ -1196,7 +1276,7 @@ begin
// Writeln(Result,Curtoken);
end;
Procedure TPascalScanner.HandleDefine(Param : String);
procedure TPascalScanner.HandleDefine(Param: String);
Var
Index : Integer;
@ -1220,7 +1300,7 @@ begin
end;
end;
Procedure TPascalScanner.HandleUnDefine(Param : String);
procedure TPascalScanner.HandleUnDefine(Param: String);
Var
Index : integer;
@ -1257,7 +1337,7 @@ function TPascalScanner.DoFetchToken: TToken;
Result := true;
Inc(FCurRow);
if LogEvent(sleLineNumber) and ((FCurRow Mod 100) = 0) then
DoLog(SLogLineNumber,[FCurRow],True);
DoLog(mtInfo,nLogLineNumber,SLogLineNumber,[FCurRow],True);
end;
end;
@ -1660,7 +1740,7 @@ begin
if (Directive = 'IFDEF') then
begin
if PPSkipStackIndex = High(PPSkipModeStack) then
Error(SErrIfXXXNestingLimitReached);
Error(nErrIfXXXNestingLimitReached,SErrIfXXXNestingLimitReached);
PPSkipModeStack[PPSkipStackIndex] := PPSkipMode;
PPIsSkippingStack[PPSkipStackIndex] := PPIsSkipping;
Inc(PPSkipStackIndex);
@ -1682,14 +1762,14 @@ begin
PPSkipMode := ppSkipElseBranch;
If LogEvent(sleConditionals) then
if PPSkipMode=ppSkipElseBranch then
DoLog(SLogIFDefAccepted,[Param])
DoLog(mtInfo,nLogIFDefAccepted,sLogIFDefAccepted,[Param])
else
DoLog(SLogIFDefRejected,[Param])
DoLog(mtInfo,nLogIFDefRejected,sLogIFDefRejected,[Param])
end;
end else if Directive = 'IFNDEF' then
begin
if PPSkipStackIndex = High(PPSkipModeStack) then
Error(SErrIfXXXNestingLimitReached);
Error(nErrIfXXXNestingLimitReached,sErrIfXXXNestingLimitReached);
PPSkipModeStack[PPSkipStackIndex] := PPSkipMode;
PPIsSkippingStack[PPSkipStackIndex] := PPIsSkipping;
Inc(PPSkipStackIndex);
@ -1709,14 +1789,14 @@ begin
PPSkipMode := ppSkipElseBranch;
If LogEvent(sleConditionals) then
if PPSkipMode=ppSkipElseBranch then
DoLog(SLogIFNDefAccepted,[Param])
DoLog(mtInfo,nLogIFNDefAccepted,sLogIFNDefAccepted,[Param])
else
DoLog(SLogIFNDefRejected,[Param])
DoLog(mtInfo,nLogIFNDefRejected,sLogIFNDefRejected,[Param])
end;
end else if Directive = 'IFOPT' then
begin
if PPSkipStackIndex = High(PPSkipModeStack) then
Error(SErrIfXXXNestingLimitReached);
Error(nErrIfXXXNestingLimitReached,sErrIfXXXNestingLimitReached);
PPSkipModeStack[PPSkipStackIndex] := PPSkipMode;
PPIsSkippingStack[PPSkipStackIndex] := PPIsSkipping;
Inc(PPSkipStackIndex);
@ -1732,11 +1812,11 @@ begin
PPIsSkipping := true;
end;
If LogEvent(sleConditionals) then
DoLog(SLogIFOPTIgnored,[Uppercase(Param)])
DoLog(mtInfo,nLogIFOPTIgnored,sLogIFOPTIgnored,[Uppercase(Param)])
end else if Directive = 'IF' then
begin
if PPSkipStackIndex = High(PPSkipModeStack) then
Error(SErrIfXXXNestingLimitReached);
Error(nErrIfXXXNestingLimitReached,sErrIfXXXNestingLimitReached);
PPSkipModeStack[PPSkipStackIndex] := PPSkipMode;
PPIsSkippingStack[PPSkipStackIndex] := PPIsSkipping;
Inc(PPSkipStackIndex);
@ -1751,12 +1831,12 @@ begin
PPSkipMode := ppSkipIfBranch;
PPIsSkipping := true;
If LogEvent(sleConditionals) then
DoLog(SLogIFIgnored,[Uppercase(Param)])
DoLog(mtInfo,nLogIFIgnored,sLogIFIgnored,[Uppercase(Param)])
end;
end else if Directive = 'ELSE' then
begin
if PPSkipStackIndex = 0 then
Error(SErrInvalidPPElse);
Error(nErrInvalidPPElse,sErrInvalidPPElse);
if PPSkipMode = ppSkipIfBranch then
PPIsSkipping := false
else if PPSkipMode = ppSkipElseBranch then
@ -1764,7 +1844,7 @@ begin
end else if ((Directive = 'ENDIF') or (Directive='IFEND')) then
begin
if PPSkipStackIndex = 0 then
Error(SErrInvalidPPEndif);
Error(nErrInvalidPPEndif,sErrInvalidPPEndif);
Dec(PPSkipStackIndex);
PPSkipMode := PPSkipModeStack[PPSkipStackIndex];
PPIsSkipping := PPIsSkippingStack[PPSkipStackIndex];
@ -1800,7 +1880,7 @@ begin
if PPIsSkipping then
Inc(TokenStr)
else
Error(SErrInvalidCharacter, [TokenStr[0]]);
Error(nErrInvalidCharacter, SErrInvalidCharacter, [TokenStr[0]]);
end;
FCurToken := Result;
@ -1819,18 +1899,21 @@ begin
Result:=0;
end;
procedure TPascalScanner.DoLog(const Msg: String;SkipSourceInfo : Boolean = False);
procedure TPascalScanner.DoLog(MsgType: TMessageType; MsgNumber: integer;
const Msg: String; SkipSourceInfo: Boolean);
begin
If Assigned(FOnLog) then
if SkipSourceInfo then
FOnLog(Self,Msg)
else
FOnLog(Self,Format('%s(%d) : %s',[FCurFileName,FCurRow,Msg]));
DoLog(MsgType,MsgNumber,Msg,[],SkipSourceInfo);
end;
procedure TPascalScanner.DoLog(const Fmt: String; Args: array of const;SkipSourceInfo : Boolean = False);
procedure TPascalScanner.DoLog(MsgType: TMessageType; MsgNumber: integer;
const Fmt: String; Args: array of const; SkipSourceInfo: Boolean);
begin
DoLog(Format(Fmt,Args),SkipSourceInfo);
SetCurMsg(MsgType,MsgNumber,Fmt,Args);
If Assigned(FOnLog) then
if SkipSourceInfo then
FOnLog(Self,FLastMsg)
else
FOnLog(Self,Format('%s(%d) : %s',[FCurFileName,FCurRow,FLastMsg]));
end;
procedure TPascalScanner.SetOptions(AValue: TPOptions);
@ -1839,14 +1922,24 @@ begin
FOptions:=AValue;
end;
Procedure TPascalScanner.AddDefine(S : String);
procedure TPascalScanner.SetCurMsg(MsgType: TMessageType; MsgNumber: integer;
const Fmt: String; Args: array of const);
begin
FLastMsgType := MsgType;
FLastMsgNumber := MsgNumber;
FLastMsgPattern := Fmt;
FLastMsg := Format(Fmt,Args);
CreateMsgArgs(FLastMsgArgs,Args);
end;
procedure TPascalScanner.AddDefine(S: String);
begin
If FDefines.IndexOf(S)=-1 then
FDefines.Add(S);
end;
Procedure TPascalScanner.RemoveDefine(S : String);
procedure TPascalScanner.RemoveDefine(S: String);
Var
I : Integer;

18
packages/fcl-passrc/tests/tcstatements.pas
View File

@ -75,6 +75,7 @@ Type
Procedure TestCase2Cases;
Procedure TestCaseBlock;
Procedure TestCaseElseBlockEmpty;
procedure TestCaseOtherwiseBlockEmpty;
Procedure TestCaseElseBlockAssignment;
Procedure TestCaseElseBlock2Assignments;
Procedure TestCaseIfCaseElse;
@ -974,6 +975,23 @@ begin
AssertEquals('Zero statements ',0,TPasImplCaseElse(C.ElseBranch).Elements.Count);
end;
procedure TTestStatementParser.TestCaseOtherwiseBlockEmpty;
Var
C : TPasImplCaseOf;
S : TPasImplCaseStatement;
B : TPasImplbeginBlock;
begin
DeclareVar('integer');
TestStatement(['case a of','1 : begin end;','otherwise',' end;']);
C:=AssertStatement('Case statement',TpasImplCaseOf) as TpasImplCaseOf;
AssertNotNull('Have case expression',C.CaseExpr);
AssertNotNull('Have else branch',C.ElseBranch);
AssertEquals('Correct else branch class',TPasImplCaseElse,C.ElseBranch.ClassType);
AssertEquals('Zero statements ',0,TPasImplCaseElse(C.ElseBranch).Elements.Count);
end;
procedure TTestStatementParser.TestCaseElseBlockAssignment;
Var
C : TPasImplCaseOf;

91
utils/fpdoc/css.inc
View File

@ -1,6 +1,6 @@
Const
DefaultCSS : Array[0..2254] of byte = (
DefaultCSS : Array[0..2649] of byte = (
47, 42, 10, 32, 32, 36, 73,100, 58, 32,102,112,100,111, 99, 46, 99,
115,115, 44,118, 32, 49, 46, 49, 32, 50, 48, 48, 51, 47, 48, 51, 47,
49, 55, 32, 50, 51, 58, 48, 51, 58, 50, 48, 32,109,105, 99,104, 97,
@ -100,37 +100,60 @@ Const
111,108,111,114, 58, 32, 35,102,102,102,102, 99, 48, 59, 10,125, 10,
10,116, 97, 98,108,101, 46, 98, 97,114, 32,123, 10, 32, 32, 98, 97,
99,107,103,114,111,117,110,100, 45, 99,111,108,111,114, 58, 32, 35,
97, 48, 99, 48,102,102, 59, 10,125, 10, 10,115,112, 97,110, 46, 98,
97,114,116,105,116,108,101, 32,123, 10, 32, 32,102,111,110,116, 45,
119,101,105,103,104,116, 58, 32, 98,111,108,100, 59, 10, 32, 32,102,
111,110,116, 45,115,116,121,108,101, 58, 32,105,116, 97,108,105, 99,
59, 10, 32, 32, 99,111,108,111,114, 58, 32,100, 97,114,107, 98,108,
117,101, 10,125, 10, 10,115,112, 97,110, 46,102,111,111,116,101,114,
32,123, 10, 32, 32,102,111,110,116, 45,115,116,121,108,101, 58, 32,
105,116, 97,108,105, 99, 59, 10, 32, 32, 99,111,108,111,114, 58, 32,
100, 97,114,107, 98,108,117,101, 10,125, 10, 10, 47, 42, 32,100,101,
102,105,110,105,116,105,111,110, 32,108,105,115,116, 32, 42, 47, 10,
100,108, 32,123, 10, 32, 98,111,114,100,101,114, 58, 32, 51,112,120,
32,100,111,117, 98,108,101, 32, 35, 99, 99, 99, 59, 10, 32,112, 97,
100,100,105,110,103, 58, 32, 48, 46, 53,101,109, 59, 10,125, 10, 10,
97, 48, 99, 48,102,102, 59, 10,125, 10, 10,116,100, 32,112, 32,123,
10, 32,109, 97,114,103,105,110, 58, 32, 48, 59, 10,125, 10, 10,115,
112, 97,110, 46, 98, 97,114,116,105,116,108,101, 32,123, 10, 32, 32,
102,111,110,116, 45,119,101,105,103,104,116, 58, 32, 98,111,108,100,
59, 10, 32, 32,102,111,110,116, 45,115,116,121,108,101, 58, 32,105,
116, 97,108,105, 99, 59, 10, 32, 32, 99,111,108,111,114, 58, 32,100,
97,114,107, 98,108,117,101, 10,125, 10, 10,115,112, 97,110, 46,102,
111,111,116,101,114, 32,123, 10, 32, 32,102,111,110,116, 45,115,116,
121,108,101, 58, 32,105,116, 97,108,105, 99, 59, 10, 32, 32, 99,111,
108,111,114, 58, 32,100, 97,114,107, 98,108,117,101, 10,125, 10, 10,
47, 42, 32,100,101,102,105,110,105,116,105,111,110, 32,108,105,115,
116, 58, 32,116,101,114,109, 32, 42, 47, 10,100,116, 32,123, 10, 32,
102,108,111, 97,116, 58, 32,108,101,102,116, 59, 10, 32, 99,108,101,
97,114, 58, 32,108,101,102,116, 59, 10, 32,119,105,100,116,104, 58,
32, 97,117,116,111, 59, 32, 47, 42, 32,110,111,114,109, 97,108,108,
121, 32, 98,114,111,119,115,101,114,115, 32,100,101,102, 97,117,108,
116, 32,119,105,100,116,104, 32,111,102, 32,108, 97,114,103,101,115,
116, 32,105,116,101,109, 32, 42, 47, 10, 32,112, 97,100,100,105,110,
103, 45,114,105,103,104,116, 58, 32, 50, 48,112,120, 59, 10, 32,102,
111,110,116, 45,119,101,105,103,104,116, 58, 32, 98,111,108,100, 59,
10, 32, 99,111,108,111,114, 58, 32,100, 97,114,107,103,114,101,101,
110, 59, 10,125, 10, 10, 47, 42, 32,100,101,102,105,110,105,116,105,
111,110, 32,108,105,115,116, 58, 32,100,101,115, 99,114,105,112,116,
105,111,110, 32, 42, 47, 10,100,100, 32,123, 10, 32,109, 97,114,103,
105,110, 58, 32, 48, 32, 48, 32, 48, 32, 49, 49, 48,112,120, 59, 10,
32,112, 97,100,100,105,110,103, 58, 32, 48, 32, 48, 32, 48, 46, 53,
101,109, 32, 48, 59, 10,125, 10, 10, 47, 42, 32,102,111,114, 32, 98,
114,111,119,115,101,114,115, 32,105,110, 32,115,116, 97,110,100, 97,
114,100,115, 32, 99,111,109,112,108,105, 97,110, 99,101, 32,109,111,
100,101, 32, 42, 47, 10,116,100, 32,112, 32,123, 10, 32, 32,109, 97,
114,103,105,110, 58, 32, 48, 59, 10,125, 10);
116, 32, 42, 47, 10,100,108, 32,123, 10, 32, 98,111,114,100,101,114,
58, 32, 51,112,120, 32,100,111,117, 98,108,101, 32, 35, 99, 99, 99,
59, 10, 32,112, 97,100,100,105,110,103, 58, 32, 48, 46, 53,101,109,
59, 10,125, 10, 10, 47, 42, 32,100,101,102,105,110,105,116,105,111,
110, 32,108,105,115,116, 58, 32,116,101,114,109, 32, 42, 47, 10,100,
116, 32,123, 10, 32,102,108,111, 97,116, 58, 32,108,101,102,116, 59,
10, 32, 99,108,101, 97,114, 58, 32,108,101,102,116, 59, 10, 32,119,
105,100,116,104, 58, 32, 97,117,116,111, 59, 32, 47, 42, 32,110,111,
114,109, 97,108,108,121, 32, 98,114,111,119,115,101,114,115, 32,100,
101,102, 97,117,108,116, 32,119,105,100,116,104, 32,111,102, 32,108,
97,114,103,101,115,116, 32,105,116,101,109, 32, 42, 47, 10, 32,112,
97,100,100,105,110,103, 45,114,105,103,104,116, 58, 32, 50, 48,112,
120, 59, 10, 32,102,111,110,116, 45,119,101,105,103,104,116, 58, 32,
98,111,108,100, 59, 10, 32, 99,111,108,111,114, 58, 32,100, 97,114,
107,103,114,101,101,110, 59, 10,125, 10, 10, 47, 42, 32,100,101,102,
105,110,105,116,105,111,110, 32,108,105,115,116, 58, 32,100,101,115,
99,114,105,112,116,105,111,110, 32, 42, 47, 10,100,100, 32,123, 10,
32,109, 97,114,103,105,110, 58, 32, 48, 32, 48, 32, 48, 32, 49, 49,
48,112,120, 59, 10, 32,112, 97,100,100,105,110,103, 58, 32, 48, 32,
48, 32, 48, 46, 53,101,109, 32, 48, 59, 10,125, 10, 10, 47, 42, 32,
102,111,114, 32, 98,114,111,119,115,101,114,115, 32,105,110, 32,115,
116, 97,110,100, 97,114,100,115, 32, 99,111,109,112,108,105, 97,110,
99,101, 32,109,111,100,101, 32, 42, 47, 10,116,100, 32,112, 32,123,
10, 32, 32,109, 97,114,103,105,110, 58, 32, 48, 59, 10,125, 10, 10,
115,112, 97,110, 46,116,111,103,103,108,101,116,114,101,101, 99,108,
111,115,101, 32,123, 10, 32, 32, 32, 32, 98, 97, 99,107,103,114,111,
117,110,100, 58, 32,117,114,108, 40,109,105,110,117,115, 46,112,110,
103, 41, 32, 99,101,110,116,101,114, 32,108,101,102,116, 32,110,111,
45,114,101,112,101, 97,116, 59, 10, 32, 32, 32, 32,112, 97,100,100,
105,110,103, 45,108,101,102,116, 58, 32, 50, 48,112,120, 59, 10,125,
10,115,112, 97,110, 46,116,111,103,103,108,101,116,114,101,101,111,
112,101,110, 32,123, 10, 32, 32, 32, 32, 98, 97, 99,107,103,114,111,
117,110,100, 58, 32,117,114,108, 40,112,108,117,115, 46,112,110,103,
41, 32, 99,101,110,116,101,114, 32,108,101,102,116, 32,110,111, 45,
114,101,112,101, 97,116, 59, 10, 32, 32, 32, 32,112, 97,100,100,105,
110,103, 45,108,101,102,116, 58, 32, 50, 48,112,120, 59, 10,125, 10,
10,117,108, 46, 99,108, 97,115,115,116,114,101,101,108,105,115,116,
32,108,105, 32,123, 32,112, 97,100,100,105,110,103, 45,108,101,102,
116, 58, 32, 48,112,120, 59, 32,125, 10, 10,117,108, 46, 99,108, 97,
115,115,116,114,101,101,108,105,115,116, 32,123, 32,108,105,115,116,
45,115,116,121,108,101, 45,116,121,112,101, 58,110,111,110,101, 59,
32,125, 10, 10,108,105, 46, 99,108, 97,115,115,116,114,101,101, 32,
117,108, 32,123, 32,100,105,115,112,108, 97,121, 58, 32, 98,108,111,
99,107, 59, 32,125, 10, 32, 10,108,105, 46, 99,108, 97,115,115,116,
114,101,101, 99,108,111,115,101,100, 32,117,108, 32,123, 32,100,105,
115,112,108, 97,121, 58, 32,110,111,110,101, 59, 32,125, 10);

12
utils/fpdoc/dglobals.pp
View File

@ -144,6 +144,8 @@ resourcestring
SCopyright2 = '(c) 2005 - 2012 various FPC contributors';
SCmdLineHelp = 'Usage: %s [options]';
SUsageOption008 = '--base-descr-dir=DIR prefix all description files with this directory';
SUsageOption009 = '--base-input-dir=DIR prefix all input files with this directory';
SUsageOption010 = '--content Create content file for package cross-references';
SUsageOption020 = '--cputarget=value Set the target CPU for the scanner.';
SUsageOption030 = '--descr=file use file as description file, e.g.: ';
@ -711,9 +713,9 @@ var
end;
end;
function ResolvePackageModule(AName:String;var pkg:TPasPackage;var module:TPasModule;createnew:boolean):String;
function ResolvePackageModule(AName:String;out pkg:TPasPackage;out module:TPasModule;createnew:boolean):String;
var
DotPos, DotPos2, i,j: Integer;
DotPos, DotPos2, i: Integer;
s: String;
HPackage: TPasPackage;
@ -809,7 +811,6 @@ var
function CreateClass(const AName: String;InheritanceStr:String): TPasClassType;
var
DotPos, DotPos2, i,j: Integer;
s: String;
HPackage: TPasPackage;
Module: TPasModule;
@ -1446,9 +1447,7 @@ Var
end;
var
i: Integer;
Node, Subnode, Subsubnode: TDOMNode;
Element: TDOMElement;
Doc: TXMLDocument;
PackageDocNode, TopicNode,ModuleDocNode: TDocNode;
@ -1601,9 +1600,6 @@ end;
function TFPDocEngine.FindLinkedNode(ANode : TDocNode) : TDocNode;
Var
S: String;
begin
If (ANode.Link='') then
Result:=Nil

2
utils/fpdoc/dw_html.pp
View File

@ -2471,7 +2471,7 @@ begin
try
B.BuildTree(AList);
// Classes
WriteXMLFile(B.ClassTree,'tree.xml');
// WriteXMLFile(B.ClassTree,'tree.xml');
// Dummy TObject
E:=B.ClassTree.DocumentElement;
PushClassList;

11
utils/fpdoc/examples/basedir/readme.txt Normal file
View File

@ -0,0 +1,11 @@
This directory demonstrates the use of a fpdoc project file.
It uses the files in the examples/simple directory.
The project file contains the names of the files without paths.
That means that fpdoc must be executed from this directory,
supplying the paths to the input and description files
fpdoc --project=sample-project.xml --base-input-dir=../simple --base-descr-dir=../simple
The docs will be written to a subdirectory doc.
This directory can be deleted if it is no longer necessary.

29
utils/fpdoc/examples/basedir/sample-project.xml Normal file
View File

@ -0,0 +1,29 @@
<docproject>
<packages>
<!-- Multiple packages can be entered.
If only one is specified, it is selected.
"name" is a mandatory attribute
a "units" tag is required, and a "descriptions" tag as well
-->
<package name="fpdocsample" output="doc" contentfile="fpdocsample.cnt">
<!-- All input files, one "unit" tag per unit -->
<units>
<!-- "file" is a mandatory attribute, "options" is not mandatory -->
<unit file="testunit.pp" options="-S2"/>
</units>
<descriptions>
<!-- Description files here. One "description" tag per file.
"file" is the only mandatory attribute -->
<description file="testunit.xml"/>
</descriptions>
</package>
</packages>
<options>
<!-- All command-line options can be specified here with the same name
and value as on the actual command-line. Boolean options must have
a value of 'true', '1' or 'yes' -->
<option name="format" value="html"/>
<option name="hide-protected" value="true"/>
<option name="footer-date" value="yyyy-mm-dd"/>
</options>
</docproject>

0
utils/fpdoc/gentest.sh → utils/fpdoc/examples/gentest.sh
View File

10
utils/fpdoc/examples/project/readme.txt Normal file
View File

@ -0,0 +1,10 @@
This directory demonstrates the use of a fpdoc project file.
It uses the files in the examples/simple directory.
The project file contains the names of the files with relative paths.
That means that fpdoc must be executed from this directory:
fpdoc --project=sample-project.xml
The docs will be written to a subdirectory doc.
This directory can be deleted if it is no longer necessary.

29
utils/fpdoc/examples/project/sample-project.xml Normal file
View File

@ -0,0 +1,29 @@
<docproject>
<packages>
<!-- Multiple packages can be entered.
If only one is specified, it is selected.
"name" is a mandatory attribute
a "units" tag is required, and a "descriptions" tag as well
-->
<package name="fpdocsample" output="doc" contentfile="fpdocsample.cnt">
<!-- All input files, one "unit" tag per unit -->
<units>
<!-- "file" is a mandatory attribute, "options" is not mandatory -->
<unit file="../simple/testunit.pp" options="-S2"/>
</units>
<descriptions>
<!-- Description files here. One "description" tag per file.
"file" is the only mandatory attribute -->
<description file="../simple/testunit.xml"/>
</descriptions>
</package>
</packages>
<options>
<!-- All command-line options can be specified here with the same name
and value as on the actual command-line. Boolean options must have
a value of 'true', '1' or 'yes' -->
<option name="format" value="html"/>
<option name="hide-protected" value="true"/>
<option name="footer-date" value="yyyy-mm-dd"/>
</options>
</docproject>

2
utils/fpdoc/examples/simple/html.bat Normal file
View File

@ -0,0 +1,2 @@
rem Command line to create html docs.
fpdoc --package=fpdocsample --output=doc --format=html --input="-S2 testunit.pp" --descr=testunit.xml

2
utils/fpdoc/examples/simple/html.sh Normal file
View File

@ -0,0 +1,2 @@
#!/bin/sh
fpdoc --package=fpdocsample --output=doc --format=html --input='-S2 testunit.pp' --descr=testunit.xml

9
utils/fpdoc/examples/simple/readme.txt Normal file
View File

@ -0,0 +1,9 @@
This directory contains the files for the projects.
You can create HTML documentation using just the command-line by executing the
following command in this directory:
(on 1 line)
fpdoc --package=fpdocsample --output=doc --format=html --input='-S2 testunit.pp' --descr=testunit.xml
Sample command-lines can be found in html.sh and html.bat

0
utils/fpdoc/testunit.pp → utils/fpdoc/examples/simple/testunit.pp
View File

0
utils/fpdoc/testunit.xml → utils/fpdoc/examples/simple/testunit.xml
View File

18
utils/fpdoc/fpclasschart.pp
View File

@ -25,7 +25,6 @@ resourcestring
STitle = 'fpClassTree - Create class tree from pascal sources';
SVersion = 'Version %s [%s]';
SCopyright = '(c) 2008 - Michael Van Canneyt, michael@freepascal.org';
SCmdLineHelp = 'See documentation for usage.';
SCmdLineInvalidOption = 'Ignoring unknown option "%s"';
SDone = 'Done.';
SSkipMerge = 'Cannot merge %s into %s tree.';
@ -213,7 +212,6 @@ end;
procedure TClassChartFormatter.EmitClass(E : TDomElement; HasSiblings: Boolean);
Var
DidSub : Boolean;
N : TDomNode;
I : Integer;
L : TFPList;
@ -235,7 +233,6 @@ begin
end;
DoEmitClass(E);
N:=E.FirstChild;
DidSub:=False;
L:=TFPList.Create;
try
While (N<>Nil) do
@ -432,8 +429,6 @@ function TClassTreeEngine.CreateElement(AClass: TPTreeElement; const AName: Stri
AParent: TPasElement; AVisibility : TPasMemberVisibility;
const ASourceFilename: String; ASourceLinenumber: Integer): TPasElement;
Var
DN : TDocNode;
begin
Result := AClass.Create(AName, AParent);
@ -478,6 +473,7 @@ Var
begin
Result:=0;
N:=Source.FirstChild;
While (N<>Nil) do
begin
@ -503,7 +499,6 @@ Function MergeTrees (Dest,Source : TXMLDocument) : Integer;
Var
S,D : TDomElement;
Count : Integer;
begin
Result:=0;
@ -524,28 +519,30 @@ Var
Engine: TClassTreeEngine;
begin
Result:='';
ACount:=0;
XML:=TXMLDocument.Create;
Try
//XML.
XML.AppendChild(XML.CreateElement(ObjKindNames[AObjectKind]));
XML.AppendChild(XML.CreateElement('TObject'));
For I:=0 to MergeFiles.Count-1 do
begin
XMl2:=TXMLDocument.Create;
ReadXMLFile(XML2,MergeFiles[i]);
try
ACount:=MergeTrees(XML,XML2);
ACount:=ACount+MergeTrees(XML,XML2);
WriteLn(StdErr,Format(SMergedFile,[ACount,MergeFiles[i]]));
Finally
FreeAndNil(XML2);
end;
end;
ACount:=0;
For I:=0 to InputFiles.Count-1 do
begin
Engine := TClassTreeEngine.Create(XML,AObjectKind);
Try
ParseSource(Engine,InputFiles[I],OSTarget,CPUTarget);
ACount:=ACount+Engine.Ftree.BuildTree(Engine.FObjects);
Engine.Ftree.BuildTree(Engine.FObjects);
ACount:=ACount+MergeTrees(XML,Engine.FTree.ClassTree);
Finally
FreeAndNil(Engine);
end;
@ -586,7 +583,6 @@ var
InputFiles,
MergeFiles : TStringList;
DocLang : String;
PackageName,
OutputName: String;
procedure InitOptions;

21
utils/fpdoc/fpdoc.css
View File

@ -127,6 +127,10 @@ table.bar {
background-color: #a0c0ff;
}
td p {
margin: 0;
}
span.bartitle {
font-weight: bold;
font-style: italic;
@ -164,3 +168,20 @@ dd {
td p {
margin: 0;
}
span.toggletreeclose {
background: url(minus.png) center left no-repeat;
padding-left: 20px;
}
span.toggletreeopen {
background: url(plus.png) center left no-repeat;
padding-left: 20px;
}
ul.classtreelist li { padding-left: 0px; }
ul.classtreelist { list-style-type:none; }
li.classtree ul { display: block; }
li.classtreeclosed ul { display: none; }

6
utils/fpdoc/fpdoc.pp
View File

@ -73,6 +73,8 @@ Var
begin
Writeln(Format(SCmdLineHelp,[ExtractFileName(Paramstr(0))]));
Writeln(SUsageOption008);
Writeln(SUsageOption009);
Writeln(SUsageOption010);
Writeln(SUsageOption020);
Writeln(SUsageOption030);
@ -321,6 +323,8 @@ begin
AddToFileList(SelectedPackage.Descriptions, Arg)
else if (Cmd = '--descr-dir') then
AddDirToFileList(SelectedPackage.Descriptions, Arg, '*.xml')
else if (Cmd = '--base-descr-dir') then
FCreator.BaseDescrDir:=Arg
else if (Cmd = '-f') or (Cmd = '--format') then
begin
Arg:=UpperCase(Arg);
@ -333,6 +337,8 @@ begin
FCreator.Options.Language := Arg
else if (Cmd = '-i') or (Cmd = '--input') then
AddToFileList(SelectedPackage.Inputs, Arg)
else if (Cmd = '--base-input-dir') then
FCreator.BaseInputDir:=Arg
else if (Cmd = '--input-dir') then
begin
AddDirToFileList(SelectedPackage.Inputs, Arg,'*.pp');

16
utils/fpdoc/fpdocclasstree.pp
View File

@ -30,8 +30,7 @@ implementation
constructor TClassTreeBuilder.Create(APackage : TPasPackage;
AObjectKind: TPasObjKind);
Var
N : TDomNode;
begin
FCLassTree:=TXMLDocument.Create;
FPackage:=APAckage;
@ -82,7 +81,7 @@ begin
S:=N.NodeName;
if NoPath then
Begin
Result:= (CompareText(S,AElement.Name)=0);
Result:=(CompareText(S,AElement.Name)=0);
end
else
begin
@ -132,10 +131,11 @@ Var
N : TDomNode;
begin
//Writeln('Enter TClassTreeBuilder.AddToClassTree');
// Writeln('Enter TClassTreeBuilder.AddToClassTree');
//if Assigned(AElement) then
//Writeln('Addtoclasstree : ',aElement.Name);
Result:=Nil; N:=Nil;PE:=NIL;
Result:=Nil; M:=Nil; N:=Nil;PE:=NIL;PC:=Nil;
If (AElement=Nil) then
begin
Result:=FTreeStart;
@ -145,9 +145,7 @@ begin
begin
N:=LookForElement(FTreeStart,AElement,True);
If (N=Nil) then
begin
PE:=FTreeStart;
end
end
else If (AElement is TPasClassType) then
begin
@ -164,8 +162,6 @@ begin
end;
If (N<>Nil) then
begin
// if Assigned(PC) then
// Writeln(PC.Name,' already in tree');
Result:=N as TDomElement
end
else if AElement.Name<>'' then
@ -180,10 +176,8 @@ begin
end;
if PE=Nil then
begin
//Writeln('PE = nil detected for ',AElement.PathName);
PE:=FTreeStart
end;
//Writeln('Appending to ',PE.NodeName);
// if not assigned, probably needs to be assigned to something else.
if assigned(PE) then
PE.AppendChild(Result);

67
utils/fpdoc/mkfpdoc.pp
View File

@ -19,6 +19,8 @@ Type
TFPDocCreator = Class(TComponent)
Private
FBaseDescrDir: String;
FBaseInputDir: String;
FCurPackage : TFPDocPackage;
FProcessedUnits : TStrings;
FOnLog: TPasParserLogHandler;
@ -28,7 +30,11 @@ Type
FVerbose: Boolean;
function GetOptions: TEngineOptions;
function GetPackages: TFPDocPackages;
procedure SetBaseDescrDir(AValue: String);
procedure SetBaseInputDir(AValue: String);
Protected
Function FixInputFile(Const AFileName : String) : String;
Function FixDescrFile(Const AFileName : String) : String;
Procedure DoBeforeEmitNote(Sender : TObject; Note : TDomElement; Var EmitNote : Boolean); virtual;
procedure HandleOnParseUnit(Sender: TObject; const AUnitName: String; out AInputFile, OSTarget, CPUTarget: String);
procedure SetVerbose(AValue: Boolean); virtual;
@ -49,6 +55,9 @@ Type
// Easy access
Property Options : TEngineOptions Read GetOptions;
Property Packages : TFPDocPackages Read GetPackages;
// When set, they will be prepended to non-absolute filenames.
Property BaseInputDir : String Read FBaseInputDir Write SetBaseInputDir;
Property BaseDescrDir : String Read FBaseDescrDir Write SetBaseDescrDir;
end;
implementation
@ -72,13 +81,13 @@ begin
end;
end;
procedure TFPDocCreator.DoLog(const Msg: String);
Procedure TFPDocCreator.DoLog(Const Msg: String);
begin
If Assigned(OnLog) then
OnLog(Self,Msg);
end;
procedure TFPDocCreator.DoLog(const Fmt: String; Args: array of const);
procedure TFPDocCreator.DoLog(Const Fmt: String; Args: Array of Const);
begin
DoLog(Format(Fmt,Args));
end;
@ -103,7 +112,7 @@ begin
SplitInputFIleOption(S,UN,Opts);
if CompareText(ChangeFileExt(ExtractFileName(Un),''),AUnitName)=0 then
begin
AInputFile:=S;
AInputFile:=FixInputFile(UN)+' '+Opts;
OSTarget:=FProject.Options.OSTarget;
CPUTarget:=FProject.Options.CPUTarget;
FProcessedUnits.Add(UN);
@ -123,13 +132,45 @@ begin
Result:=FProject.Packages;
end;
procedure TFPDocCreator.DoBeforeEmitNote(Sender: TObject; Note: TDomElement;
var EmitNote: Boolean);
Function TFPDocCreator.FixInputFile(Const AFileName: String): String;
begin
Result:=AFileName;
If Result='' then exit;
if (ExtractFileDrive(Result)='') and (Result[1]<>PathDelim) then
Result:=BaseInputDir+Result;
end;
Function TFPDocCreator.FixDescrFile(Const AFileName: String): String;
begin
Result:=AFileName;
If Result='' then exit;
if (ExtractFileDrive(Result)='') and (Result[1]<>PathDelim) then
Result:=BaseDescrDir+Result;
end;
procedure TFPDocCreator.SetBaseDescrDir(AValue: String);
begin
if FBaseDescrDir=AValue then Exit;
FBaseDescrDir:=AValue;
If FBaseDescrDir<>'' then
FBaseDescrDir:=IncludeTrailingPathDelimiter(FBaseDescrDir);
end;
procedure TFPDocCreator.SetBaseInputDir(AValue: String);
begin
if FBaseInputDir=AValue then Exit;
FBaseInputDir:=AValue;
If FBaseInputDir<>'' then
FBaseInputDir:=IncludeTrailingPathDelimiter(FBaseInputDir);
end;
Procedure TFPDocCreator.DoBeforeEmitNote(Sender: TObject; Note: TDomElement;
Var EmitNote: Boolean);
begin
EmitNote:=True;
end;
constructor TFPDocCreator.Create(AOwner: TComponent);
Constructor TFPDocCreator.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FProject:=TFPDocProject.Create(Self);
@ -139,7 +180,7 @@ begin
FProcessedUnits:=TStringList.Create;
end;
destructor TFPDocCreator.Destroy;
Destructor TFPDocCreator.Destroy;
begin
FreeAndNil(FProcessedUnits);
FreeAndNil(FProject);
@ -180,7 +221,8 @@ begin
Engine.WriteContentFile(APackage.ContentFile);
end;
procedure TFPDocCreator.CreateDocumentation(APackage: TFPDocPackage; ParseOnly : Boolean);
Procedure TFPDocCreator.CreateDocumentation(APackage: TFPDocPackage;
ParseOnly: Boolean);
var
i,j: Integer;
@ -201,7 +243,7 @@ begin
Engine.ReadContentFile(Arg, Cmd);
end;
for i := 0 to APackage.Descriptions.Count - 1 do
Engine.AddDocFile(APackage.Descriptions[i],Options.donttrim);
Engine.AddDocFile(FixDescrFile(APackage.Descriptions[i]),Options.donttrim);
Engine.SetPackageName(APackage.Name);
Engine.Output:=APackage.Output;
Engine.OnLog:=Self.OnLog;
@ -216,10 +258,11 @@ begin
for i := 0 to APackage.Inputs.Count - 1 do
try
SplitInputFileOption(APackage.Inputs[i],Cmd,Arg);
Cmd:=FixInputFIle(Cmd);
if FProcessedUnits.IndexOf(Cmd)=-1 then
begin
FProcessedUnits.Add(Cmd);
ParseSource(Engine, APackage.Inputs[i], Options.OSTarget, Options.CPUTarget);
ParseSource(Engine,Cmd+' '+Arg, Options.OSTarget, Options.CPUTarget);
end;
except
on e: EParserError do
@ -239,7 +282,7 @@ begin
end;
end;
procedure TFPDocCreator.CreateProjectFile(Const AFileName: string);
Procedure TFPDocCreator.CreateProjectFile(Const AFileName: string);
begin
With TXMLFPDocOptions.Create(Self) do
try
@ -249,7 +292,7 @@ begin
end;
end;
procedure TFPDocCreator.LoadProjectFile(const AFileName: string);
Procedure TFPDocCreator.LoadProjectFile(Const AFileName: string);
begin
With TXMLFPDocOptions.Create(self) do
try