* synchronized with trunk

git-svn-id: branches/wasm@47920 -

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.

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

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;
@@ -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

packages/fcl-passrc/tests/tcprocfunc.pas

@@ -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)');

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

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;
@@ -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);

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;',

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;
 

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.

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;

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);
 

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