paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-26 14:50:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

* synchronized with trunk

Browse Source 
git-svn-id: branches/wasm@47920 -
This commit is contained in:
nickysn 2020-12-31 04:00:04 +00:00
commit 361594bafd
12 changed files with 310 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/utils/samplecfg
View File

@ -43,7 +43,7 @@ if [ -w "$sysdir" ] ; then
fpccfgfile="$sysdir"/fpc.cfg
fppkgfile="$sysdir"/fppkg.cfg
defaultfile="$sysdir"/fppkg/default
compilerconfigdir="-d CompilerConfigDir=$sysdir/fppkg"
compilerconfigdir="-d CompilerConfigDir=$sysdir/fppkg/"
fppkgconfdir=$sysdir/fppkg/conf.d
else
echo No write premission in $sysdir.

2
packages/fcl-passrc/src/pasresolver.pp
View File

@ -13938,7 +13938,7 @@ begin
begin
// type cast
Param0:=Params.Params[0];
ComputeElement(Param0,ParamResolved,[]);
ComputeElement(Param0,ParamResolved,Flags);
ComputeTypeCast(ResolvedEl.LoTypeEl,ResolvedEl.HiTypeEl,Param0,
ParamResolved,ResolvedEl,Flags);
end

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

@ -4943,7 +4943,7 @@ procedure TPasParser.ParseArgList(Parent: TPasElement; Args: TFPList; EndToken:
end;
end;
var
IsUntyped, ok, LastHadDefaultValue: Boolean;
OldForceCaret,IsUntyped, ok, LastHadDefaultValue: Boolean;
Name : String;
Value : TPasExpr;
i, OldArgCount: Integer;
@ -5022,9 +5022,11 @@ begin
if not IsUntyped then
begin
Arg := TPasArgument(Args[OldArgCount]);
ArgType := ParseType(Arg,CurSourcePos);
ArgType:=Nil;
ok:=false;
oldForceCaret:=Scanner.SetForceCaret(True);
try
ArgType := ParseType(Arg,CurSourcePos);
NextToken;
if CurToken = tkEqual then
begin
@ -5048,6 +5050,7 @@ begin
UngetToken;
ok:=true;
finally
Scanner.SetForceCaret(oldForceCaret);
if (not ok) and (ArgType<>nil) then
ArgType.Release{$IFDEF CheckPasTreeRefCount}('CreateElement'){$ENDIF};
end;
@ -5344,6 +5347,7 @@ Var
OK: Boolean;
IsProcType: Boolean; // false = procedure, true = procedure type
IsAnonymous: Boolean;
OldForceCaret : Boolean;
PTM: TProcTypeModifier;
ModTokenCount: Integer;
LastToken: TToken;
@ -5361,7 +5365,12 @@ begin
if CurToken = tkColon then
begin
ResultEl:=TPasFunctionType(Element).ResultEl;
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
OldForceCaret:=Scanner.SetForceCaret(True);
try
ResultEl.ResultType := ParseType(ResultEl,CurSourcePos);
finally
Scanner.SetForceCaret(OldForceCaret);
end;
end
// In Delphi mode, the signature in the implementation section can be
// without result as it was declared

42
packages/fcl-passrc/tests/tcprocfunc.pas
View File

@ -102,6 +102,9 @@ type
Procedure TestFunctionArrayOfConstArg;
procedure TestProcedureConstArrayOfConstArg;
Procedure TestFunctionConstArrayOfConstArg;
procedure TestProcedureOnePointerArg;
procedure TestFUnctionPointerResult;
Procedure TestProcedureCdecl;
Procedure TestFunctionCdecl;
Procedure TestProcedureCdeclDeprecated;
@ -243,6 +246,7 @@ end;
function TTestProcedureFunction.ParseFunction(const ASource : String;AResult: string = ''; const AHint: String = ''; CC : TCallingConvention = ccDefault): TPasProcedure;
Var
D :String;
aType : TPasType;
begin
if (AResult='') then
AResult:='Integer';
@ -253,8 +257,16 @@ begin
Self.ParseFunction;
Result:=FFunc;
AssertNotNull('Have function result element',FuncType.ResultEl);
AssertNotNull('Have function result type element',FuncType.ResultEl.ResultType);
AssertEquals('Correct function result type name',AResult,FuncType.ResultEl.ResultType.Name);
aType:=FuncType.ResultEl.ResultType;
AssertNotNull('Have function result type element',aType);
if aResult[1]='^' then
begin
Delete(aResult,1,1);
AssertEquals('Result is pointer type',TPasPointerType,aType.ClassType);
aType:=TPasPointerType(aType).DestType;
AssertNotNull('Result pointer type has destination type',aType);
end;
AssertEquals('Correct function result type name',AResult,aType.Name);
end;
procedure TTestProcedureFunction.ParseOperator;
@ -354,6 +366,7 @@ procedure TTestProcedureFunction.AssertArg(ProcType: TPasProcedureType;
Var
A : TPasArgument;
T : TPasType;
N : String;
begin
@ -361,11 +374,21 @@ begin
N:='Argument '+IntToStr(AIndex+1)+' : ';
if (TypeName='') then
AssertNull(N+' No argument type',A.ArgType)
else
else if TypeName[1]<>'^' then
begin
AssertNotNull(N+' Have argument type',A.ArgType);
AssertEquals(N+' Correct argument type name',TypeName,A.ArgType.Name);
end
else
begin
AssertNotNull(N+' Have argument type',A.ArgType);
T:=A.ArgType;
AssertEquals(N+' type Is pointer type',TPasPointerType,T.CLassType);
T:=TPasPointerType(T).DestType;
AssertNotNull(N+'Have dest type',T);
AssertEquals(N+' Correct argument dest type name',Copy(TypeName,2,MaxInt),T.Name);
end;
end;
procedure TTestProcedureFunction.AssertArrayArg(ProcType: TPasProcedureType;
@ -481,6 +504,19 @@ begin
AssertArg(ProcType,0,'B',argDefault,'Integer','');
end;
procedure TTestProcedureFunction.TestProcedureOnePointerArg;
begin
ParseProcedure('(B : ^Integer)');
AssertProc([],[],ccDefault,1);
AssertArg(ProcType,0,'B',argDefault,'^Integer','');
end;
procedure TTestProcedureFunction.TestFunctionPointerResult;
begin
ParseFunction('()','^LongInt');
AssertFunc([],[],ccDefault,0);
end;
procedure TTestProcedureFunction.TestFunctionOneArg;
begin
ParseFunction('(B : Integer)');

13
packages/pastojs/src/fppas2js.pp
View File

@ -5239,9 +5239,16 @@ end;
procedure TPas2JSResolver.SpecializeGenericIntf(
SpecializedItem: TPRSpecializedItem);
var
El: TPasElement;
begin
inherited SpecializeGenericIntf(SpecializedItem);
RenameSpecialized(SpecializedItem);
El:=SpecializedItem.SpecializedEl;
if (El is TPasGenericType)
and IsFullySpecialized(TPasGenericType(El))
and (SpecializeParamsNeedDelay(SpecializedItem)<>nil) then
TPas2JSResolverHub(Hub).AddJSDelaySpecialize(TPasGenericType(El));
end;
procedure TPas2JSResolver.SpecializeGenericImpl(
@ -5252,11 +5259,6 @@ begin
inherited SpecializeGenericImpl(SpecializedItem);
El:=SpecializedItem.SpecializedEl;
if (El is TPasGenericType)
and IsFullySpecialized(TPasGenericType(El))
and (SpecializeParamsNeedDelay(SpecializedItem)<>nil) then
TPas2JSResolverHub(Hub).AddJSDelaySpecialize(TPasGenericType(El));
if El is TPasMembersType then
begin
if FOverloadScopes=nil then
@ -8208,6 +8210,7 @@ begin
Lib:=TPasLibrary(El);
if Assigned(Lib.LibrarySection) then
AddToSourceElements(Src,ConvertDeclarations(Lib.LibrarySection,IntfContext));
// ToDo AddDelayedInits(Lib,Src,IntfContext);
CreateInitSection(Lib,Src,IntfContext);
end
else

115
packages/pastojs/tests/tcgenerics.pas
View File

@ -55,6 +55,7 @@ type
procedure TestGen_ClassInterface_InterfacedObject;
procedure TestGen_ClassInterface_COM_RTTI;
procedure TestGen_ClassInterface_Helper;
procedure TestGen_ClassInterface_DelayedInitSpec;
// statements
Procedure TestGen_InlineSpec_Constructor;
@ -83,6 +84,7 @@ type
// generic array
procedure TestGen_Array_OtherUnit;
procedure TestGen_ArrayOfUnitImplRec;
procedure TestGen_Array_TypecastJSValueResultToArg;
// generic procedure type
procedure TestGen_ProcType_ProcLocal;
@ -1633,6 +1635,74 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_ClassInterface_DelayedInitSpec;
begin
WithTypeInfo:=true;
StartProgram(true,[supTObject,supTInterfacedObject]);
AddModuleWithIntfImplSrc('UnitA.pas',
LinesToStr([
'{$mode delphi}',
'type',
' TAnt<T> = interface',
' procedure Run(x: T);',
' end;',
'']),
LinesToStr([
'']));
Add([
'{$mode delphi}',
'uses UnitA;',
'type',
' TArrWord = array of word;',
' TMyIntf = TAnt<TArrWord>;',
' TBird = class(TInterfacedObject,TMyIntf)',
' procedure Run(a: TArrWord); external name ''Run'';',
' end;',
'var',
' i: TMyIntf;',
'begin',
' i:=TBird.Create;',
' i.Run([3,4]);',
'end.']);
ConvertProgram;
CheckUnit('UnitA.pas',
LinesToStr([ // statements
'rtl.module("UnitA", ["system"], function () {',
' var $mod = this;',
' $mod.$rtti.$Interface("TAnt<test1.TArrWord>");',
' rtl.createInterface(',
' this,',
' "TAnt$G1",',
' "{B145F21B-2696-32D5-87A5-F16C037A2D45}",',
' ["Run"],',
' pas.system.IUnknown,',
' function () {',
' this.$initSpec = function () {',
' var $r = this.$rtti;',
' $r.addMethod("Run", 0, [["x", pas.program.$rtti["TArrWord"]]]);',
' };',
' },',
' "TAnt<test1.TArrWord>"',
' );',
'});']));
CheckSource('TestGen_ClassInterface_DelayedInitSpec',
LinesToStr([ // statements
'this.$rtti.$DynArray("TArrWord", {',
' eltype: rtl.word',
'});',
'rtl.createClass(this, "TBird", pas.system.TInterfacedObject, function () {',
' rtl.addIntf(this, pas.UnitA.TAnt$G1);',
' rtl.addIntf(this, pas.system.IUnknown);',
'});',
'this.i = null;',
'pas.UnitA.TAnt$G1.$initSpec();',
'']),
LinesToStr([ // $mod.$main
'rtl.setIntfP($mod, "i", rtl.queryIntfT($mod.TBird.$create("Create"), pas.UnitA.TAnt$G1), true);',
'$mod.i.Run([3, 4]);',
'']));
end;
procedure TTestGenerics.TestGen_InlineSpec_Constructor;
begin
StartProgram(false);
@ -2373,6 +2443,51 @@ begin
'']));
end;
procedure TTestGenerics.TestGen_Array_TypecastJSValueResultToArg;
begin
StartProgram(false);
Add([
'{$mode delphi}',
'type',
' TArray<T> = array of T;',
' TFunc = function: JSValue of object;',
' TObject = class',
' f: TFunc;',
' function Run: jsvalue; virtual; abstract;',
' end;',
'procedure Sit(Arr: TArray<TObject>);',
'begin',
'end;',
'procedure Fly(o: TObject);',
'begin',
' Sit(TArray<TObject>(o.f()));',
' Sit(TArray<TObject>(o.Run));',
' Sit(TArray<TObject>(o.Run()));',
'end;',
'begin']);
ConvertProgram;
CheckSource('TestGen_Array_TypecastJSValueResultToArg',
LinesToStr([ // statements
'rtl.createClass(this, "TObject", null, function () {',
' this.$init = function () {',
' this.f = null;',
' };',
' this.$final = function () {',
' this.f = undefined;',
' };',
'});',
'this.Sit = function (Arr) {',
'};',
'this.Fly = function (o) {',
' $mod.Sit(o.f());',
' $mod.Sit(o.Run());',
' $mod.Sit(o.Run());',
'};',
'']),
LinesToStr([ // $mod.$main
'']));
end;
procedure TTestGenerics.TestGen_ProcType_ProcLocal;
begin
StartProgram(false);

4
packages/pastojs/tests/tcmodules.pas
View File

@ -887,7 +887,7 @@ type
Procedure TestAWait_ExternalClassPromise;
Procedure TestAWait_JSValue;
Procedure TestAWait_Result;
Procedure TestAWait_ResultPromiseMissingTypeFail;
Procedure TestAWait_ResultPromiseMissingTypeFail; // await(AsyncCallResultPromise) needs T
Procedure TestAsync_AnonymousProc;
Procedure TestAsync_ProcType;
Procedure TestAsync_ProcTypeAsyncModMismatchFail;
@ -32647,6 +32647,8 @@ begin
'type',
' TJSPromise = class external name ''Promise''',
' end;',
' TJSThenable = class external name ''Thenable''',
' end;',
'function Fly(w: word): TJSPromise;',
'begin',
'end;',

2
rtl/i386/cpu.pp
View File

@ -69,6 +69,7 @@ unit cpu;
function InterlockedCompareExchange128(var Target: Int128Rec; NewValue: Int128Rec; Comperand: Int128Rec): Int128Rec;
begin
{$if FPC_FULLVERSION >= 30101}
{$ifndef FPC_PIC}
if _RTMSupport then
begin
@ -85,6 +86,7 @@ unit cpu;
end
else
{$endif FPC_PIC}
{$endif FPC_FULLVERSION >= 30101}
RunError(217);
end;

28
utils/fpdoc/dglobals.pp
View File

@ -23,7 +23,7 @@ unit dGlobals;
interface
uses Classes, DOM, PasTree, PParser, uriparser;
uses Classes, DOM, PasTree, PParser, uriparser, SysUtils;
Const
CacheSize = 20;
@ -343,9 +343,9 @@ type
constructor Create;
destructor Destroy; override;
procedure SetPackageName(const APackageName: String);
// process the import objects from external .xct file
// The process importing of objects from external .xct file
procedure ReadContentFile(const AFilename, ALinkPrefix: String);
// creation of an own .xct output file
// Creation of an own .xct output file
procedure WriteContentFile(const AFilename: String);
function CreateElement(AClass: TPTreeElement; const AName: String;
@ -385,6 +385,7 @@ type
procedure TranslateDocStrings(const Lang: String);
function DumpExceptionCallStack(E: Exception):String;
Function IsLinkNode(Node : TDomNode) : Boolean;
Function IsExampleNode(Example : TDomNode) : Boolean;
@ -395,7 +396,7 @@ Function IsLinkAbsolute(ALink: String): boolean;
implementation
uses SysUtils, Gettext, XMLRead;
uses Gettext, XMLRead;
const
AbsoluteLinkPrefixes : array[0..2] of string = ('/', 'http://', 'ms-its:');
@ -1133,7 +1134,7 @@ begin
begin
for k:=0 to ClassLikeDecl.Interfaces.count-1 do
begin
write(contentfile,',',CheckImplicitLink(TPasClassType(ClassLikeDecl.Interfaces[k]).PathName));
write(contentfile,',',CheckImplicitLink(TPasType(ClassLikeDecl.Interfaces[k]).PathName));
if TPasElement(ClassLikeDecl.Interfaces[k]) is TPasAliasType then
begin
alias:= TPasAliasType(ClassLikeDecl.Interfaces[k]);
@ -1757,6 +1758,23 @@ begin
end;
end;
function DumpExceptionCallStack(E: Exception):String;
var
I: Integer;
Frames: PPointer;
begin
Result := 'Program exception! ' + LineEnding +
'Stacktrace:' + LineEnding + LineEnding;
if E <> nil then begin
Result := Result + 'Exception class: ' + E.ClassName + LineEnding +
'Message: ' + E.Message + LineEnding;
end;
Result := Result + BackTraceStrFunc(ExceptAddr);
Frames := ExceptFrames;
for I := 0 to ExceptFrameCount - 1 do
Result := Result + LineEnding + BackTraceStrFunc(Frames[I]);
end;
initialization
LEOL:=Length(LineEnding);
end.

93
utils/fpdoc/dw_chm.pp
View File

@ -3,7 +3,7 @@ unit dw_chm;
interface
uses Classes, DOM, DOM_HTML,
dGlobals, PasTree, dwriter, dw_html, ChmWriter, chmtypes;
dGlobals, PasTree, dwriter, dw_html, chmwriter, chmtypes, chmsitemap;
type
@ -34,8 +34,13 @@ type
FOtherFiles: String;
procedure ProcessOptions;
function ResolveLinkIDAbs(const Name: String; Level : Integer = 0): DOMString;
function RetrieveOtherFiles(const DataName: String; out PathInChm: String; out FileName: String; var Stream: TStream): Boolean;
function RetrieveOtherFiles(const DataName: String; out PathInChm: String;
out FileName: String; var Stream: TStream): Boolean;
procedure LastFileAdded(Sender: TObject);
function FindAlphaItem(AItems: TChmSiteMapItems; AName: String): TChmSiteMapItem;
function GetAlphaItem(AItems: TChmSiteMapItems; AName: String): TChmSiteMapItem;
procedure MultiAlphaItem(AItems: TChmSiteMapItems; AName: String;
APasEl: TPasElement; Prefix:String);
procedure GenerateTOC;
procedure GenerateIndex;
public
@ -50,7 +55,7 @@ type
implementation
uses SysUtils, HTMWrite, chmsitemap;
uses SysUtils, HTMWrite;
{ TFpDocChmWriter }
@ -157,7 +162,8 @@ begin
Result := CompareText(LowerCase(Item1.Text), LowerCase(Item2.Text));
end;
function GetAlphaItem(AItems: TChmSiteMapItems; AName: String): TChmSiteMapItem;
function TCHMHTMLWriter.FindAlphaItem(AItems: TChmSiteMapItems; AName: String
): TChmSiteMapItem;
var
x: Integer;
begin
@ -167,10 +173,39 @@ begin
if AItems.Item[x].Text = AName then
Exit(AItems.Item[x]);
end;
end;
function TCHMHTMLWriter.GetAlphaItem(AItems: TChmSiteMapItems; AName: String
): TChmSiteMapItem;
begin
Result := FindAlphaItem(AItems, AName);
if Result <> nil then Exit;
Result := AItems.NewItem;
Result.Text := AName;
end;
procedure TCHMHTMLWriter.MultiAlphaItem(AItems: TChmSiteMapItems; AName: String;
APasEl: TPasElement; Prefix: String);
var
AChmItem, AChmChld: TChmSiteMapItem;
begin
AChmItem:= FindAlphaItem(AItems, AName);
if AChmItem = nil then
begin
// add new
AChmItem := AItems.NewItem;
AChmItem.Text := AName;
AChmItem.addLocal(FixHTMLpath(Allocator.GetFilename(APasEl, 0)));
end
else
begin
// add as child
AChmChld := AChmItem.Children.NewItem;
AChmChld.Text := Prefix + '.' + AName;
AChmChld.addLocal(FixHTMLpath(Allocator.GetFilename(APasEl, 0)));
end;
end;
procedure TCHMHTMLWriter.GenerateTOC;
var
TOC: TChmSiteMap;
@ -279,20 +314,26 @@ begin
fchm.AppendTOC(Stream);
Stream.Free;
DoLog('Generating TOC done');
end;
type
TClassMemberType = (cmtProcedure, cmtFunction, cmtConstructor, cmtDestructor,
cmtInterface, cmtProperty, cmtVariable, cmtUnknown);
cmtInterface, cmtProperty, cmtVariable, cmtOperator, cmtConstant, cmtUnknown);
function ElementType(Element: TPasElement): TClassMemberType;
var
ETypeName: String;
begin
Result := cmtUnknown;
if not Assigned(Element) then Exit;
ETypeName := Element.ElementTypeName;
//overloaded we don't care
if ETypeName[1] = 'o' then ETypeName := Copy(ETypeName, 11, Length(ETypeName));
if Length(ETypeName) = 0 then Exit;
// opearator
if ETypeName[2] = 'p' then Exit(cmtOperator);
if ETypeName[3] = 'n' then Exit(cmtConstant);
// overloaded we don't care
if ETypeName[1] = 'o' then ETypeName := Copy(ETypeName, 12, Length(ETypeName));
if ETypeName[1] = 'f' then Exit(cmtFunction);
if ETypeName[1] = 'c' then Exit(cmtConstructor);
@ -301,7 +342,8 @@ begin
// the p's
if ETypeName[4] = 'c' then Exit(cmtProcedure);
if ETypeName[4] = 'p' then Exit(cmtProperty);
// Unknown
// WriteLn(' Warning El name: '+ Element.Name+' path: '+Element.PathName+' TypeName: '+Element.ElementTypeName);
end;
procedure TCHMHTMLWriter.GenerateIndex;
@ -315,7 +357,7 @@ var
ParentElement: TPasElement;
MemberItem: TChmSiteMapItem;
Stream: TMemoryStream;
RedirectUrl,Urls: String;
RedirectUrl,Urls,SName: String;
begin
DoLog('Generating Index...');
@ -356,7 +398,7 @@ begin
if(trim(RedirectUrl)<>'') and (RedirectUrl<>urls) then
begin
writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl);
//writeln('Hint: Index Resolved:',urls,' to ',RedirectUrl);
urls:=RedirectUrl;
end;
@ -369,6 +411,8 @@ begin
cmtProperty : TmpItem.Text := TmpElement.Name + ' property';
cmtVariable : TmpItem.Text := TmpElement.Name + ' variable';
cmtInterface : TmpItem.Text := TmpElement.Name + ' interface';
cmtOperator : TmpItem.Text := TmpElement.Name + ' operator';
cmtConstant : TmpItem.Text := TmpElement.Name + ' const';
cmtUnknown : TmpItem.Text := TmpElement.Name;
end;
TmpItem.addLocal(Urls);
@ -389,18 +433,24 @@ begin
// routines
for j := 0 to AModule.InterfaceSection.Functions.Count-1 do
begin
ParentElement := TPasProcedureType(AModule.InterfaceSection.Functions[j]);
TmpItem := Index.Items.NewItem;
TmpItem.Text := ParentElement.Name + ' ' + ParentElement.ElementTypeName;
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
// routine name
ParentElement := TPasElement(AModule.InterfaceSection.Functions[j]);
case ElementType(ParentElement) of
cmtProcedure : SName:= ' procedure';
cmtFunction : SName:= ' function';
cmtOperator : SName:= ' operator';
//cmtConstant : SName:= ' const';
else SName:= ' unknown'
end;
SName:= ParentElement.Name + ' ' + SName;
MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name);
end;
// consts
for j := 0 to AModule.InterfaceSection.Consts.Count-1 do
begin
ParentElement := TPasElement(AModule.InterfaceSection.Consts[j]);
TmpItem := Index.Items.NewItem;
TmpItem.Text := ParentElement.Name;
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
SName:= ParentElement.Name + ' const';
MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name);
end;
// types
for j := 0 to AModule.InterfaceSection.Types.Count-1 do
@ -431,9 +481,8 @@ begin
for j := 0 to AModule.InterfaceSection.Variables.Count-1 do
begin
ParentElement := TPasElement(AModule.InterfaceSection.Variables[j]);
TmpItem := Index.Items.NewItem;
TmpItem.Text := ParentElement.Name + ' var';
TmpItem.addLocal(FixHTMLpath(Allocator.GetFilename(ParentElement, 0)));
SName:= ParentElement.Name + ' variable';
MultiAlphaItem(Index.Items, SName, ParentElement, AModule.Name);
end;
// declarations
{
@ -471,6 +520,7 @@ begin
FChm.AppendIndex(Stream);
Stream.Free;
end;
DoLog('Generating Index Done');
end;
procedure TCHMHTMLWriter.WriteHTMLPages;
@ -548,6 +598,7 @@ begin
FChm.Execute;
FChm.Free;
DoLog('Collecting done');
// we don't need to free FTempUncompressed
// FTempUncompressed.Free;
FOutChm.Free;

60
utils/fpdoc/dw_html.pp
View File

@ -53,6 +53,8 @@ type
function GetCSSFilename(ARelativeTo: TPasElement): DOMString; virtual;
end;
{ TLongNameFileAllocator }
TLongNameFileAllocator = class(TFileAllocator)
private
FExtension: String;
@ -255,7 +257,6 @@ type
// Start producing html complete package documentation
procedure WriteHTMLPages; virtual;
procedure WriteXHTMLPages;
function ModuleForElement(AnElement:TPasElement):TPasModule;
Function InterPretOption(Const Cmd,Arg : String) : boolean; override;
Procedure WriteDoc; override;
@ -276,7 +277,6 @@ type
Property ImageFileList : TStrings Read FImageFileList;
end;
Function FixHTMLpath(S : String) : STring;
implementation
@ -310,7 +310,6 @@ begin
end;
constructor TLongNameFileAllocator.Create(const AExtension: String);
begin
inherited Create;
@ -331,12 +330,12 @@ begin
Result := 'index';
excl := True;
end
else if AElement.ClassType = TPasModule then
else if AElement.ClassType = TPasModule then
begin
Result := LowerCase(AElement.Name) + PathDelim + 'index';
excl := True;
end
else
else
begin
if AElement is TPasOperator then
begin
@ -371,9 +370,11 @@ begin
excl := (ASubindex > 0);
end;
// searching for TPasModule - it is on the 2nd level
if Assigned(AElement.Parent) then
while Assigned(AElement.Parent.Parent) do
AElement := AElement.Parent;
if AElement.GetModule <> nil then
AElement := AElement.GetModule
else
Raise EFPDocWriterError.Create(
'TLongNameFileAllocator error: Unresolved module name for element: ' +AElement.PathName);
// cut off Package Name
Result := Copy(Result, Length(AElement.Parent.Name) + 2, MaxInt);
// to skip dots in unit name
@ -834,15 +835,6 @@ begin
end;
end;
function THTMLWriter.ModuleForElement(AnElement:TPasElement):TPasModule;
begin
result:=TPasModule(AnElement);
while assigned(result) and not (result is TPasModule) do
result:=TPasModule(result.parent);
if not (result is TPasModule) then
result:=nil;
end;
procedure THTMLWriter.CreateCSSFile;
@ -1691,7 +1683,7 @@ begin
end else
begin
Result := nil;
AppendText(Parent, Element.Name);
AppendText(Parent, Element.Name); // unresolved items
end;
end else
begin
@ -2294,7 +2286,7 @@ begin
else
AppendText(NewEl,El['id']);
l:=El['id'];
DescrEl := Engine.FindShortDescr(ModuleForElement(AElement),UTF8Encode(L));
DescrEl := Engine.FindShortDescr(AElement.GetModule,UTF8Encode(L));
if Assigned(DescrEl) then
begin
AppendNbSp(CreatePara(CreateTD(TREl)), 2);
@ -2494,7 +2486,7 @@ type
if (PE<>Nil) then
begin
AppendHyperLink(CurOutputNode,PE);
PM:=ModuleForElement(PE);
PM:=PE.GetModule();
if (PM<>Nil) then
begin
AppendText(CurOutputNode,' (');
@ -3157,7 +3149,7 @@ var
i: Integer;
s: String;
t : TPasType;
ah,ol,wt,ct,wc,cc : boolean;
ah,ol,wt,ct,wc,cc : boolean;
isRecord : Boolean;
begin
@ -3172,30 +3164,24 @@ begin
begin
Member := TPasElement(Members[i]);
MVisibility:=Member.Visibility;
cc:=(Member is TPasConst);
ct:=(Member is TPasType);
ol:=(Member is TPasOverloadedProc);
ah:=ol or ((Member is TPasProcedure) and (TPasProcedure(Member).ProcType.Args.Count > 0));
if ol then
Member:=TPasElement((Member as TPasOverloadedProc).Overloads[0]);
if Not Engine.ShowElement(Member) then
continue;
if (CurVisibility <> MVisibility) then
if (CurVisibility <> MVisibility) or (cc <> wc) or (ct <> wt) then
begin
CurVisibility := MVisibility;
wc:=cc;
wt:=ct;
s:=VisibilityNames[MVisibility];
AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), UTF8Decode(s));
if (ct) then AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'type');
if (cc) then AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'const');
end;
ct:=(Member is TPasType);
if ct and (not wt) then
begin
AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'Type');
end;
wt:=ct;
cc:=(Member is TPasConst);
if cc and (not wc) then
begin
AppendKw(CreateCode(CreatePara(CreateTD(CreateTR(TableEl)))), 'Const');
end;
wc:=cc;
TREl := CreateTR(TableEl);
CodeEl := CreateCode(CreatePara(CreateTD_vtop(TREl)));
AppendNbSp(CodeEl, 2);
@ -3218,7 +3204,7 @@ begin
If Assigned(TPasConst(Member).VarType) then
begin
AppendSym(CodeEl, ' = ');
AppendTypeDecl(TPasType(Member),TableEl,CodeEl);
AppendTypeDecl(TPasType(TPasConst(Member).VarType),TableEl,CodeEl);
end;
AppendSym(CodeEl, ' = ');
AppendText(CodeEl,UTF8Decode(TPasConst(Member).Expr.GetDeclaration(True)));
@ -3270,7 +3256,7 @@ begin
else
AppendText(CodeEl, UTF8Decode(Member.Name));
AppendSym(CodeEl, ': ');
AppendHyperlink(CodeEl, TPasVariable(Member).VarType);
AppendType(CodeEl, TableEl, TPasVariable(Member).VarType,False);
AppendSym(CodeEl, ';');
end
else
@ -3490,6 +3476,7 @@ var
AppendText(ParaEl, 'pt');
visPublished:
AppendText(ParaEl, 'pl');
else
end;
AppendNbSp(ParaEl, 1);
@ -3558,6 +3545,7 @@ var
AppendText(ParaEl, 'pt');
visPublished:
AppendText(ParaEl, 'pl');
else
end;
AppendNbSp(ParaEl, 1);

13
utils/fpdoc/fpdoc.pp
View File

@ -55,8 +55,9 @@ Type
procedure OutputLog(Sender: TObject; const Msg: String);
procedure ParseCommandLine;
procedure ParseOption(const S: String);
Procedure Usage(AnExitCode : Byte);
Procedure DoRun; override;
procedure Usage(AnExitCode : Byte);
procedure ExceptProc(Sender: TObject; E: Exception);
procedure DoRun; override;
Public
Constructor Create(AOwner : TComponent); override;
Destructor Destroy; override;
@ -64,7 +65,7 @@ Type
end;
Procedure TFPDocApplication.Usage(AnExitCode : Byte);
procedure TFPDocApplication.Usage(AnExitCode: Byte);
Var
I,P : Integer;
@ -148,6 +149,11 @@ begin
Halt(AnExitCode);
end;
procedure TFPDocApplication.ExceptProc(Sender: TObject; E: Exception);
begin
OutputLog(Sender, DumpExceptionCallStack(E));
end;
destructor TFPDocApplication.Destroy;
begin
@ -427,6 +433,7 @@ begin
StopOnException:=true;
FCreator:=TFPDocCreator.Create(Self);
FCreator.OnLog:=@OutputLog;
OnException:= @ExceptProc;
end;
begin