From 6dafbfb7caf4236a6ae2e641781eb037f7c750c1 Mon Sep 17 00:00:00 2001 From: michael Date: Wed, 30 Dec 2020 08:52:38 +0000 Subject: [PATCH 1/7] * Fix Pointer types as arguments git-svn-id: trunk@47900 - --- packages/fcl-passrc/src/pparser.pp | 7 +++++-- packages/fcl-passrc/tests/tcprocfunc.pas | 22 +++++++++++++++++++++- 2 files changed, 26 insertions(+), 3 deletions(-) diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 26fa383b9b..6e5d8f330a 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -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; diff --git a/packages/fcl-passrc/tests/tcprocfunc.pas b/packages/fcl-passrc/tests/tcprocfunc.pas index 3488fb95de..ef4f1ebcce 100644 --- a/packages/fcl-passrc/tests/tcprocfunc.pas +++ b/packages/fcl-passrc/tests/tcprocfunc.pas @@ -102,6 +102,8 @@ type Procedure TestFunctionArrayOfConstArg; procedure TestProcedureConstArrayOfConstArg; Procedure TestFunctionConstArrayOfConstArg; + procedure TestProcedureOnePointerArg; + Procedure TestProcedureCdecl; Procedure TestFunctionCdecl; Procedure TestProcedureCdeclDeprecated; @@ -354,6 +356,7 @@ procedure TTestProcedureFunction.AssertArg(ProcType: TPasProcedureType; Var A : TPasArgument; + T : TPasType; N : String; begin @@ -361,11 +364,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 +494,13 @@ 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.TestFunctionOneArg; begin ParseFunction('(B : Integer)'); From b5725ac3ed071ec564e8f49a80e89b9d46b54bf6 Mon Sep 17 00:00:00 2001 From: florian Date: Wed, 30 Dec 2020 09:34:22 +0000 Subject: [PATCH 2/7] * while not official supported, bootstrapping with 3.0.4 fixed git-svn-id: trunk@47901 - --- rtl/i386/cpu.pp | 2 ++ 1 file changed, 2 insertions(+) diff --git a/rtl/i386/cpu.pp b/rtl/i386/cpu.pp index 20f9bfa9c5..7ef4af7b53 100644 --- a/rtl/i386/cpu.pp +++ b/rtl/i386/cpu.pp @@ -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; From 46d301b7b2eb4b7f6e9d9b538fa9c1697c1586f0 Mon Sep 17 00:00:00 2001 From: michael Date: Wed, 30 Dec 2020 14:35:30 +0000 Subject: [PATCH 3/7] * Function result can also contain ^ in type git-svn-id: trunk@47911 - --- packages/fcl-passrc/src/pparser.pp | 8 +++++++- packages/fcl-passrc/tests/tcprocfunc.pas | 20 ++++++++++++++++++-- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/packages/fcl-passrc/src/pparser.pp b/packages/fcl-passrc/src/pparser.pp index 6e5d8f330a..c1a115cf46 100644 --- a/packages/fcl-passrc/src/pparser.pp +++ b/packages/fcl-passrc/src/pparser.pp @@ -5347,6 +5347,7 @@ Var OK: Boolean; IsProcType: Boolean; // false = procedure, true = procedure type IsAnonymous: Boolean; + OldForceCaret : Boolean; PTM: TProcTypeModifier; ModTokenCount: Integer; LastToken: TToken; @@ -5364,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 diff --git a/packages/fcl-passrc/tests/tcprocfunc.pas b/packages/fcl-passrc/tests/tcprocfunc.pas index ef4f1ebcce..971f9daf13 100644 --- a/packages/fcl-passrc/tests/tcprocfunc.pas +++ b/packages/fcl-passrc/tests/tcprocfunc.pas @@ -103,6 +103,7 @@ type procedure TestProcedureConstArrayOfConstArg; Procedure TestFunctionConstArrayOfConstArg; procedure TestProcedureOnePointerArg; + procedure TestFUnctionPointerResult; Procedure TestProcedureCdecl; Procedure TestFunctionCdecl; @@ -245,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'; @@ -255,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; @@ -501,6 +511,12 @@ begin AssertArg(ProcType,0,'B',argDefault,'^Integer',''); end; +procedure TTestProcedureFunction.TestFunctionPointerResult; +begin + ParseFunction('()','^LongInt'); + AssertFunc([],[],ccDefault,0); +end; + procedure TTestProcedureFunction.TestFunctionOneArg; begin ParseFunction('(B : Integer)'); From 32999fbaba853286412aed98a5d2a89262a0cd65 Mon Sep 17 00:00:00 2001 From: joost Date: Wed, 30 Dec 2020 15:41:44 +0000 Subject: [PATCH 4/7] * Fixed missing slash in fppkg.cfg when installed in the root git-svn-id: trunk@47913 - --- compiler/utils/samplecfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/utils/samplecfg b/compiler/utils/samplecfg index a278a81e4c..81a82cddbf 100644 --- a/compiler/utils/samplecfg +++ b/compiler/utils/samplecfg @@ -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. From 7032cba91ed5026a738f088df2e6af00ec884e6f Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Wed, 30 Dec 2020 16:12:47 +0000 Subject: [PATCH 5/7] fcl-passrc: resolver: fixed typecast a(b.func) marking implicit call git-svn-id: trunk@47914 - --- packages/fcl-passrc/src/pasresolver.pp | 2 +- packages/pastojs/tests/tcgenerics.pas | 46 ++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) diff --git a/packages/fcl-passrc/src/pasresolver.pp b/packages/fcl-passrc/src/pasresolver.pp index 4ac2905b62..5a3de61d52 100644 --- a/packages/fcl-passrc/src/pasresolver.pp +++ b/packages/fcl-passrc/src/pasresolver.pp @@ -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 diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index e8d5708348..e894cdf841 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -83,6 +83,7 @@ type // generic array procedure TestGen_Array_OtherUnit; procedure TestGen_ArrayOfUnitImplRec; + procedure TestGen_Array_TypecastJSValueResultToArg; // generic procedure type procedure TestGen_ProcType_ProcLocal; @@ -2373,6 +2374,51 @@ begin ''])); end; +procedure TTestGenerics.TestGen_Array_TypecastJSValueResultToArg; +begin + StartProgram(false); + Add([ + '{$mode delphi}', + 'type', + ' TArray = array of T;', + ' TFunc = function: JSValue of object;', + ' TObject = class', + ' f: TFunc;', + ' function Run: jsvalue; virtual; abstract;', + ' end;', + 'procedure Sit(Arr: TArray);', + 'begin', + 'end;', + 'procedure Fly(o: TObject);', + 'begin', + ' Sit(TArray(o.f()));', + ' Sit(TArray(o.Run));', + ' Sit(TArray(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); From 4353d365164ae502be72eba16d6edcadfafbc52b Mon Sep 17 00:00:00 2001 From: marco Date: Wed, 30 Dec 2020 20:37:24 +0000 Subject: [PATCH 6/7] * commited patch(-5) by Andrey Sobol from mantis #38153 . git-svn-id: trunk@47915 - --- utils/fpdoc/dglobals.pp | 28 ++++++++++--- utils/fpdoc/dw_chm.pp | 93 +++++++++++++++++++++++++++++++---------- utils/fpdoc/dw_html.pp | 60 +++++++++++--------------- utils/fpdoc/fpdoc.pp | 13 ++++-- 4 files changed, 129 insertions(+), 65 deletions(-) diff --git a/utils/fpdoc/dglobals.pp b/utils/fpdoc/dglobals.pp index 29e48fd5c8..7738c04902 100644 --- a/utils/fpdoc/dglobals.pp +++ b/utils/fpdoc/dglobals.pp @@ -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. diff --git a/utils/fpdoc/dw_chm.pp b/utils/fpdoc/dw_chm.pp index d12c646e4e..0969c76190 100644 --- a/utils/fpdoc/dw_chm.pp +++ b/utils/fpdoc/dw_chm.pp @@ -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; diff --git a/utils/fpdoc/dw_html.pp b/utils/fpdoc/dw_html.pp index bfeffefd7a..d796115456 100644 --- a/utils/fpdoc/dw_html.pp +++ b/utils/fpdoc/dw_html.pp @@ -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); diff --git a/utils/fpdoc/fpdoc.pp b/utils/fpdoc/fpdoc.pp index 36db342996..bea83836ac 100644 --- a/utils/fpdoc/fpdoc.pp +++ b/utils/fpdoc/fpdoc.pp @@ -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 From c1a2b6279e7e289be8a8fb507f2fc8c9a0d9a48e Mon Sep 17 00:00:00 2001 From: Mattias Gaertner Date: Thu, 31 Dec 2020 01:07:33 +0000 Subject: [PATCH 7/7] pastojs: fixed delay init specialized interface git-svn-id: trunk@47919 - --- packages/pastojs/src/fppas2js.pp | 13 +++-- packages/pastojs/tests/tcgenerics.pas | 69 +++++++++++++++++++++++++++ packages/pastojs/tests/tcmodules.pas | 4 +- 3 files changed, 80 insertions(+), 6 deletions(-) diff --git a/packages/pastojs/src/fppas2js.pp b/packages/pastojs/src/fppas2js.pp index d94033da46..7d5d6756a7 100644 --- a/packages/pastojs/src/fppas2js.pp +++ b/packages/pastojs/src/fppas2js.pp @@ -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 diff --git a/packages/pastojs/tests/tcgenerics.pas b/packages/pastojs/tests/tcgenerics.pas index e894cdf841..8e7dd8b6ec 100644 --- a/packages/pastojs/tests/tcgenerics.pas +++ b/packages/pastojs/tests/tcgenerics.pas @@ -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; @@ -1634,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 = interface', + ' procedure Run(x: T);', + ' end;', + '']), + LinesToStr([ + ''])); + Add([ + '{$mode delphi}', + 'uses UnitA;', + 'type', + ' TArrWord = array of word;', + ' TMyIntf = TAnt;', + ' 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");', + ' 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"', + ' );', + '});'])); + 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); diff --git a/packages/pastojs/tests/tcmodules.pas b/packages/pastojs/tests/tcmodules.pas index faef15a5c9..1ab920c33a 100644 --- a/packages/pastojs/tests/tcmodules.pas +++ b/packages/pastojs/tests/tcmodules.pas @@ -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;',