* Second patch xml-node-dump-defs.patch from J. Gareth Moreton from bug report 36882.

     With same changes to ensure that xmllint find no errors in generated xml files.

git-svn-id: trunk@47667 -

compiler/pdecl.pas

@@ -1187,6 +1187,11 @@ implementation
            if assigned(rtti_attrs_def) and (rtti_attrs_def.get_attribute_count>0) then
              Message1(parser_e_unbound_attribute,trtti_attribute(rtti_attrs_def.rtti_attributes[0]).typesym.prettyname);
 
+ {$ifdef DEBUG_NODE_XML}
+          if Assigned(hdef) then
+            hdef.XMLPrintDef(newtype);
+ {$endif DEBUG_NODE_XML}
+
          until ((token<>_ID) and (token<>_LECKKLAMMER)) or
                (in_structure and
                 ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or

compiler/symdef.pas

@@ -322,6 +322,10 @@ interface
        tabstractrecorddef= class(tstoreddef)
        private
           rttistring     : string;
+{$ifdef DEBUG_NODE_XML}
+       protected
+          procedure XMLPrintDefData(var T: Text; Sym: TSym); override;
+{$endif DEBUG_NODE_XML}
        public
           objname,
           objrealname    : PShortString;
@@ -376,6 +380,10 @@ interface
        end;
 
        trecorddef = class(tabstractrecorddef)
+{$ifdef DEBUG_NODE_XML}
+       protected
+          function XMLPrintType: ansistring; override;
+{$endif DEBUG_NODE_XML}
        public
           variantrecdesc : pvariantrecdesc;
           isunion       : boolean;
@@ -450,6 +458,12 @@ interface
        tobjectdef = class(tabstractrecorddef)
        private
           fcurrent_dispid: longint;
+{$ifdef DEBUG_NODE_XML}
+       protected
+          function XMLPrintType: ansistring; override;
+          procedure XMLPrintDefInfo(var T: Text; Sym: TSym); override;
+          procedure XMLPrintDefData(var T: Text; Sym: TSym); override;
+{$endif DEBUG_NODE_XML}
        public
           childof        : tobjectdef;
           childofderef   : tderef;
@@ -4898,6 +4912,92 @@ implementation
         result:=false;
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure tabstractrecorddef.XMLPrintDefData(var T: Text; Sym: TSym);
+
+      procedure WriteSymOptions(SourceSym: TSym);
+        var
+          i: TSymOption;
+          first: Boolean;
+        begin
+          First := True;
+          for i := Low(TSymOption) to High(TSymOption) do
+            if i in SourceSym.symoptions then
+              begin
+                if First then
+                  begin
+                    Write(T, '" symoptions="', i);
+                    First := False;
+                  end
+                else
+                  Write(T, ',', i)
+              end;
+        end;
+
+      var
+        List: TFPHashObjectList;
+        i: Integer;
+      begin
+        WriteLn(T, PrintNodeIndention, '<size>', size, '</size>');
+
+        if (alignment = structalignment) and (alignment = aggregatealignment) then
+          begin
+            { Straightforward and simple }
+            WriteLn(T, PrintNodeIndention, '<alignment>', alignment, '</alignment>');
+          end
+        else
+          begin
+            WriteLn(T, PrintNodeIndention, '<alignment>');
+            printnodeindent;
+            WriteLn(T, PrintNodeIndention, '<basic>', alignment, '</basic>');
+
+            if (structalignment <> alignment) then
+              WriteLn(T, PrintNodeIndention, '<struct>', structalignment, '</struct>');
+
+            if (aggregatealignment <> alignment) and (aggregatealignment <> structalignment) then
+              WriteLn(T, PrintNodeIndention, '<aggregate>', aggregatealignment, '</aggregate>');
+
+            printnodeunindent;
+            WriteLn(T, PrintNodeIndention, '</alignment>');
+          end;
+
+        { List the fields }
+        List := Symtable.SymList;
+        for i := 0 to List.Count - 1 do
+          case TSym(List[i]).typ of
+{            staticvarsym,localvarsym,paravarsym,fieldvarsym,
+            typesym,procsym,unitsym,}
+            constsym:
+              with TConstSym(List[i]) do
+                begin
+                  Write(T, PrintNodeIndention, '<const name="', RealName, '" pos="', fileinfo.line, ',', fileinfo.column);
+                  WriteSymOptions(TSym(List[i]));
+                  WriteLn(T, '">');
+                  PrintNodeIndent;
+                  XMLPrintConstData(T);
+                  PrintNodeUnindent;
+                  WriteLn(T, PrintNodeIndention, '</const>');
+                end;
+ {
+            errorsym,syssym,labelsym,absolutevarsym,propertysym,
+            macrosym,namespacesym,undefinedsym,programparasym
+}
+            fieldvarsym:
+              with TFieldVarSym(List[i]) do
+                begin
+                  Write(T, PrintNodeIndention, '<field name="', RealName, '" pos="', fileinfo.line, ',', fileinfo.column);
+                  WriteSymOptions(TSym(List[i]));
+                  WriteLn(T, '">');
+                  PrintNodeIndent;
+                  XMLPrintFieldData(T);
+                  PrintNodeUnindent;
+                  WriteLn(T, PrintNodeIndention, '</field>');
+                end;
+            else
+              ;
+          end;
+      end;
+{$endif DEBUG_NODE_XML}
 
 {***************************************************************************
                                   trecorddef
@@ -5227,6 +5327,12 @@ implementation
          GetTypeName:='<record type>'
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    function TRecordDef.XMLPrintType: ansistring;
+      begin
+        Result := '&lt;record&gt;';
+      end;
+{$endif DEBUG_NODE_XML}
 
 {***************************************************************************
                        TABSTRACTPROCDEF
@@ -8343,6 +8449,54 @@ implementation
         self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    function TObjectDef.XMLPrintType: ansistring;
+      begin
+        if (oo_is_forward in objectoptions) then
+          Result := '&lt;class prototype&gt;'
+        else
+          Result := '&lt;class&gt;';
+      end;
+
+
+    procedure TObjectDef.XMLPrintDefInfo(var T: Text; Sym: TSym);
+      var
+        i: TObjectOption;
+        first: Boolean;
+      begin
+        inherited XMLPrintDefInfo(T, Sym);
+
+        First := True;
+        for i := Low(TObjectOption) to High(TObjectOption) do
+          if i in objectoptions then
+            begin
+              if First then
+                begin
+                  Write(T, ' objectoptions="', i);
+                  First := False;
+                end
+              else
+                Write(T, ',', i)
+            end;
+
+        if not first then
+          Write(T, '"');
+      end;
+
+
+    procedure TObjectDef.XMLPrintDefData(var T: Text; Sym: TSym);
+      begin
+        { There's nothing useful yet if the type is only forward-declared }
+        if not (oo_is_forward in objectoptions) then
+          begin
+            if Assigned(childof) then
+              WriteLn(T, printnodeindention, '<ancestor>', SanitiseXMLString(childof.typesym.RealName), '</ancestor>');
+
+            inherited XMLPrintDefData(T, Sym);
+          end;
+      end;
+{$endif DEBUG_NODE_XML}
+
 
 {****************************************************************************
                              TImplementedInterface

compiler/symsym.pas

@@ -234,6 +234,10 @@ interface
           procedure set_externalname(const s:string);virtual;
           function mangledname:TSymStr;override;
           destructor destroy;override;
+{$ifdef DEBUG_NODE_XML}
+        public
+          procedure XMLPrintFieldData(var T: Text);
+{$endif DEBUG_NODE_XML}
       end;
       tfieldvarsymclass = class of tfieldvarsym;
 
@@ -410,6 +414,10 @@ interface
           { do not override this routine in platform-specific subclasses,
             override ppuwrite_platform instead }
           procedure ppuwrite(ppufile:tcompilerppufile);override;final;
+{$ifdef DEBUG_NODE_XML}
+        public
+          procedure XMLPrintConstData(var T: Text);
+{$endif DEBUG_NODE_XML}
        end;
        tconstsymclass = class of tconstsym;
 
@@ -1961,6 +1969,15 @@ implementation
         inherited destroy;
       end;
 
+{$ifdef DEBUG_NODE_XML}
+      procedure TFieldVarSym.XMLPrintFieldData(var T: Text);
+        begin
+          WriteLn(T, PrintNodeIndention, '<type>', SanitiseXMLString(vardef.GetTypeName), '</type>');
+          WriteLn(T, PrintNodeIndention, '<visibility>', visibility, '</visibility>');
+          WriteLn(T, PrintNodeIndention, '<offset>', fieldoffset, '</offset>');
+          WriteLn(T, PrintNodeIndention, '<size>', vardef.size, '</size>');
+        end;
+{$endif DEBUG_NODE_XML}
 
 {****************************************************************************
                         TABSTRACTNORMALVARSYM
@@ -2684,6 +2701,47 @@ implementation
         writeentry(ppufile,ibconstsym);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TConstSym.XMLPrintConstData(var T: Text);
+      begin
+        WriteLn(T, PrintNodeIndention, '<type>', SanitiseXMLString(constdef.GetTypeName), '</type>');
+
+        case consttyp of
+          constnone:
+            ;
+          conststring,
+          constresourcestring,
+          constwstring:
+            begin
+              WriteLn(T, PrintNodeIndention, '<length>', value.len, '</length>');
+              if value.len = 0 then
+                WriteLn(T, PrintNodeIndention, '<value />')
+              else
+                WriteLn(T, PrintNodeIndention, '<value>', SanitiseXMLString(PChar(value.valueptr)), '</value>');
+            end;
+          constord,
+          constset:
+            WriteLn(T, PrintNodeIndention, '<value>', tostr(value.valueord), '</value>');
+          constpointer:
+            WriteLn(T, PrintNodeIndention, '<value>', WriteConstPUInt(value.valueordptr), '</value>');
+          constreal:
+            WriteLn(T, PrintNodeIndention, '<value>', PBestReal(value.valueptr)^, '</value>');
+          constnil:
+            WriteLn(T, PrintNodeIndention, '<value>nil</value>');
+          constguid:
+            WriteLn(T, PrintNodeIndention, '<value>', WriteGUID(PGUID(value.valueptr)^), '</value>');
+        end;
+
+        WriteLn(T, PrintNodeIndention, '<visibility>', visibility, '</visibility>');
+
+        if not (consttyp in [conststring, constresourcestring, constwstring]) then
+          { constdef.size will return an internal error for string
+            constants because constdef is an open array internally }
+          WriteLn(T, PrintNodeIndention, '<size>', constdef.size, '</size>');
+
+//        WriteLn(T, PrintNodeIndention, '<const_type>', consttyp, '</const_type>');
+      end;
+{$endif DEBUG_NODE_XML}
 
 {****************************************************************************
                                   TENUMSYM

compiler/symtype.pas

@@ -58,6 +58,12 @@ interface
          { initialize the defid field; only call from a constructor as it threats
            0 as an invalid value! }
          procedure init_defid;
+{$ifdef DEBUG_NODE_XML}
+         procedure XMLPrintDefTree(var T: Text; Sym: TSym); virtual;
+         procedure XMLPrintDefInfo(var T: Text; Sym: TSym); dynamic;
+         procedure XMLPrintDefData(var T: Text; Sym: TSym); virtual;
+         function XMLPrintType: ansistring; virtual;
+{$endif DEBUG_NODE_XML}
         public
          typesym    : tsym;  { which type the definition was generated this def }
          { stabs debugging }
@@ -102,6 +108,9 @@ interface
            has been requested; otherwise, first call register_def }
          function  deflist_index: longint;
          procedure register_def; virtual; abstract;
+{$ifdef DEBUG_NODE_XML}
+         procedure XMLPrintDef(Sym: TSym);
+{$endif DEBUG_NODE_XML}
          property is_registered: boolean read registered;
       end;
 
@@ -282,6 +291,84 @@ implementation
           defid:=defid_not_registered;
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure tdef.XMLPrintDefTree(var T: Text; Sym: TSym);
+      begin
+        Write(T, PrintNodeIndention, '<definition');
+        XMLPrintDefInfo(T, Sym);
+        WriteLn(T, '>');
+        PrintNodeIndent;
+        { Printing the type here instead of in XMLPrintDefData ensures it
+          always appears first no matter how XMLPrintDefData is overridden }
+        WriteLn(T, PrintNodeIndention, '<type>', XMLPrintType, '</type>');
+        XMLPrintDefData(T, Sym);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</definition>');
+        WriteLn(T, PrintNodeIndention);
+      end;
+
+
+    procedure tdef.XMLPrintDefInfo(var T: Text; Sym: TSym);
+      var
+        i: TSymOption;
+        first: Boolean;
+      begin
+        { Note that if we've declared something like "INT = Integer", the
+          INT name gets lost in the system and 'typename' just returns
+          Integer, so the correct details can be found via Sym }
+        Write(T, ' name="', SanitiseXMLString(Sym.RealName),
+          '" pos="', Sym.fileinfo.line, ',', Sym.fileinfo.column);
+
+        First := True;
+        for i := Low(TSymOption) to High(TSymOption) do
+          if i in Sym.symoptions then
+            begin
+              if First then
+                begin
+                  Write(T, '" symoptions="', i);
+                  First := False;
+                end
+              else
+                Write(T, ',', i)
+            end;
+
+        Write(T, '"');
+      end;
+
+
+    procedure tdef.XMLPrintDefData(var T: Text; Sym: TSym);
+      begin
+        WriteLn(T, PrintNodeIndention, '<size>', size, '</size>');
+
+        if (alignment = structalignment) and (alignment = aggregatealignment) then
+          begin
+            { Straightforward and simple }
+            WriteLn(T, PrintNodeIndention, '<alignment>', alignment, '</alignment>');
+          end
+        else
+          begin
+            WriteLn(T, PrintNodeIndention, '<alignment>');
+            printnodeindent;
+            WriteLn(T, PrintNodeIndention, '<basic>', alignment, '</basic>');
+
+            if (structalignment <> alignment) then
+              WriteLn(T, PrintNodeIndention, '<struct>', structalignment, '</struct>');
+
+            if (aggregatealignment <> alignment) and (aggregatealignment <> structalignment) then
+              WriteLn(T, PrintNodeIndention, '<aggregate>', aggregatealignment, '</aggregate>');
+
+            printnodeunindent;
+            WriteLn(T, PrintNodeIndention, '</alignment>');
+          end;
+      end;
+
+
+    function tdef.XMLPrintType: ansistring;
+      begin
+        Result := SanitiseXMLString(GetTypeName);
+      end;
+
+{$endif DEBUG_NODE_XML}
 
     constructor tdef.create(dt:tdeftyp);
       begin
@@ -462,6 +549,33 @@ implementation
           internalerror(2015102502)
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TDef.XMLPrintDef(Sym: TSym);
+      var
+        T: Text;
+
+      begin
+        if current_module.ppxfilefail then
+          Exit;
+
+        Assign(T, current_module.ppxfilename);
+        {$push} {$I-}
+        Append(T);
+        if IOResult <> 0 then
+          begin
+            Message1(exec_e_cant_create_archivefile,current_module.ppxfilename);
+            current_module.ppxfilefail := True;
+            Exit;
+          end;
+        {$pop}
+
+        XMLPrintDefTree(T, Sym);
+        Close(T);
+      end;
+
+{$endif DEBUG_NODE_XML}
+
+
 {****************************************************************************
                           TSYM (base for all symtypes)
 ****************************************************************************}

compiler/verbose.pas

@@ -132,6 +132,7 @@ interface
 {$ifdef DEBUG_NODE_XML}
      function SanitiseXMLString(const S: ansistring): ansistring;
      function WritePointer(const P: Pointer): ansistring;
+     function WriteConstPUInt(const P: TConstPtrUInt): ansistring;
      function WriteGUID(const GUID: TGUID): ansistring;
 {$endif DEBUG_NODE_XML}
 
@@ -1063,6 +1064,23 @@ implementation
       end;
 
 
+    function WriteConstPUInt(const P: TConstPtrUInt): ansistring;
+      begin
+        case P of
+          0:
+            WriteConstPUInt := 'nil';
+          1..$FFFF:
+            WriteConstPUInt := '$' + hexstr(P, 4);
+          $10000..$FFFFFFFF:
+            WriteConstPUInt := '$' + hexstr(P, 8);
+    {$ifdef CPU64BITADDR}
+          else
+            WriteConstPUInt := '$' + hexstr(P, 16);
+    {$endif CPU64BITADDR}
+        end;
+      end;
+
+
     function WriteGUID(const GUID: TGUID): ansistring;
       var
         i: Integer;