Commit of new debug feature implemented by J. Gareth Moreton

  Allows compilation of compiler using -dDEBUG_NODE_XML
  which will generate a NAME-node-dump.xml file for each 
  unit, program or library compiled,
  containing a XML description of the nodes handled during
  compilation of the unit, program or library.

git-svn-id: trunk@42271 -

compiler/finput.pas

@@ -145,6 +145,9 @@ interface
           objfilename,              { fullname of the objectfile }
           asmfilename,              { fullname of the assemblerfile }
           ppufilename,              { fullname of the ppufile }
+{$ifdef DEBUG_NODE_XML}
+          ppxfilename,              { fullname of the intermediate node XML file }
+{$endif DEBUG_NODE_XML}
           importlibfilename,        { fullname of the import libraryfile }
           staticlibfilename,        { fullname of the static libraryfile }
           sharedlibfilename,        { fullname of the shared libraryfile }
@@ -154,6 +157,9 @@ interface
           dbgfilename,              { fullname of the debug info file }
           path,                     { path where the module is find/created }
           outputpath   : TPathStr;  { path where the .s / .o / exe are created }
+{$ifdef DEBUG_NODE_XML}
+          ppxfilefail: Boolean;     { If the ppxfile could not be accessed, flag it }
+{$endif DEBUG_NODE_XML}
           constructor create(const s:string);
           destructor destroy;override;
           procedure setfilename(const fn:TPathStr;allowoutput:boolean);
@@ -625,6 +631,9 @@ uses
          asmfilename:=p+n+target_info.asmext;
          objfilename:=p+n+target_info.objext;
          ppufilename:=p+n+target_info.unitext;
+{$ifdef DEBUG_NODE_XML}
+         ppxfilename:=p+n+'-node-dump.xml';
+{$endif DEBUG_NODE_XML}
          importlibfilename:=p+target_info.importlibprefix+n+target_info.importlibext;
          staticlibfilename:=p+target_info.staticlibprefix+n+target_info.staticlibext;
          exportfilename:=p+'exp'+n+target_info.objext;
@@ -668,6 +677,9 @@ uses
         realmodulename:=stringdup(s);
         mainsource:='';
         ppufilename:='';
+{$ifdef DEBUG_NODE_XML}
+        ppxfilename:='';
+{$endif DEBUG_NODE_XML}
         objfilename:='';
         asmfilename:='';
         importlibfilename:='';
@@ -679,6 +691,12 @@ uses
         outputpath:='';
         paramfn:='';
         path:='';
+{$ifdef DEBUG_NODE_XML}
+        { Setting ppxfilefail to true will stop it from being written to if it
+          was never initialised, which happens if a module doesn't need
+          recompiling. }
+        ppxfilefail := True;
+{$endif DEBUG_NODE_XML}
         { status }
         state:=ms_registered;
         { unit index }

compiler/i8086/n8086con.pas

@@ -35,6 +35,9 @@ interface
       ti8086pointerconstnode = class(tcgpointerconstnode)
         constructor create(v : TConstPtrUInt;def:tdef);override;
         procedure printnodedata(var t: text);override;
+{$ifdef DEBUG_NODE_XML}
+        procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
         procedure pass_generate_code;override;
       end;
 
@@ -70,6 +73,15 @@ implementation
           inherited printnodedata(t);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure Ti8086PointerConstNode.XMLPrintNodeData(var T: Text);
+      begin
+        if (typedef.typ=pointerdef) and (tcpupointerdef(typedef).x86pointertyp in [x86pt_far,x86pt_huge]) then
+          WriteLn(T, PrintNodeIndention, '<value>$', hexstr(word(value shr 16),4),':',hexstr(word(value),4), '</value>')
+        else
+          inherited XMLPrintNodeData(T);
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure ti8086pointerconstnode.pass_generate_code;
       begin

compiler/nbas.pas

@@ -37,6 +37,9 @@ interface
           constructor create;virtual;
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeTree(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tnothingnodeclass = class of tnothingnode;
 
@@ -83,6 +86,9 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           function docompare(p: tnode): boolean; override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tasmnodeclass = class of tasmnode;
 
@@ -224,6 +230,10 @@ interface
           procedure includetempflag(flag: ttempinfoflag); inline;
           procedure excludetempflag(flag: ttempinfoflag); inline;
           property tempflags: ttempinfoflags read gettempinfoflags write settempinfoflags;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeInfo(var T: Text); override;
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
 
        { a node which will create a (non)persistent temp of a given type with a given  }
@@ -251,6 +261,9 @@ interface
           function pass_typecheck: tnode; override;
           function docompare(p: tnode): boolean; override;
           procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
         end;
        ttempcreatenodeclass = class of ttempcreatenode;
 
@@ -286,6 +299,9 @@ interface
           function docompare(p: tnode): boolean; override;
           destructor destroy; override;
           procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
          protected
           release_to_normal : boolean;
         private
@@ -324,6 +340,14 @@ implementation
       pass_1,
       nutils,nld,
       procinfo
+{$ifdef DEBUG_NODE_XML}
+{$ifndef jvm}
+      ,
+      cpubase,
+      cutils,
+      itcpugas
+{$endif jvm}
+{$endif DEBUG_NODE_XML}
       ;
 
 
@@ -395,6 +419,15 @@ implementation
         expectloc:=LOC_VOID;
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TNothingNode.XMLPrintNodeTree(var T: Text);
+      begin
+        Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]);
+        XMLPrintNodeInfo(T);
+        { "Nothing nodes" contain no data, so just use "/>" to terminate it early }
+        WriteLn(T, ' />');
+      end;
+{$endif DEBUG_NODE_XML}
 
 {*****************************************************************************
                              TFIRSTERROR
@@ -892,6 +925,159 @@ implementation
         docompare := false;
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TAsmNode.XMLPrintNodeData(var T: Text);
+
+      procedure PadString(var S: string; Len: Integer);
+        var
+          X, C: Integer;
+        begin
+          C := Length(S);
+          if C < Len then
+            begin
+              SetLength(S, 7);
+              for X := C + 1 to Len do
+                S[X] := ' '
+            end;
+        end;
+
+{$ifndef jvm}
+      function FormatOp(const Oper: POper): string;
+        begin
+          case Oper^.typ of
+            top_const:
+              begin
+                case Oper^.val of
+                  -15..15:
+                    Result := '$' + tostr(Oper^.val);
+                  $10..$FF:
+                    Result := '$0x' + hexstr(Oper^.val, 2);
+                  $100..$FFFF:
+                    Result := '$0x' + hexstr(Oper^.val, 4);
+                  $10000..$FFFFFFFF:
+                    Result := '$0x' + hexstr(Oper^.val, 8);
+                  else
+                    Result := '$0x' + hexstr(Oper^.val, 16);
+                end;
+              end;
+            top_reg:
+              Result := gas_regname(Oper^.reg);
+            top_ref:
+              with Oper^.ref^ do
+                begin
+{$if defined(x86)}
+                  if segment <> NR_NO then
+                    Result := gas_regname(segment) + ':'
+                  else
+                    Result := '';
+{$endif defined(x86)}
+
+                  if Assigned(symbol) then
+                    begin
+                      Result := Result + symbol.Name;
+                      if offset > 0 then
+                        Result := Result + '+';
+                    end;
+
+                  if offset <> 0 then
+                    Result := Result + tostr(offset)
+                  else
+                    Result := Result;
+
+                  if (base <> NR_NO) or (index <> NR_NO) then
+                    begin
+                      Result := Result + '(';
+
+                      if base <> NR_NO then
+                        begin
+                          Result := Result + gas_regname(base);
+                          if index <> NR_NO then
+                            Result := Result + ',';
+                        end;
+
+                      if index <> NR_NO then
+                        Result := Result + gas_regname(index);
+
+                      if scalefactor <> 0 then
+                        Result := Result + ',' + tostr(scalefactor) + ')'
+                      else
+                        Result := Result + ')';
+                    end;
+                end;
+            top_bool:
+              begin
+                if Oper^.b then
+                  Result := 'TRUE'
+                else
+                  Result := 'FALSE';
+              end
+            else
+              Result := '';
+          end;
+        end;
+
+{$if defined(x86)}
+      procedure ProcessInstruction(p: tai); inline;
+        var
+          ThisOp, ThisOper: string;
+          X: Integer;
+        begin
+          case p.typ of
+            ait_label:
+              WriteLn(T, PrintNodeIndention, tai_label(p).labsym.name);
+
+            ait_instruction:
+              begin
+                ThisOp := gas_op2str[taicpu(p).opcode]+cond2str[taicpu(p).condition];
+                if gas_needsuffix[taicpu(p).opcode] <> AttSufNONE then
+                  ThisOp := ThisOp + gas_opsize2str[taicpu(p).opsize];
+
+                { Pad the opcode with spaces so the succeeding operands are aligned }
+                PadString(ThisOp, 7);
+
+                Write(T, PrintNodeIndention, '  ', ThisOp); { Extra indentation to account for label formatting }
+                for X := 0 to taicpu(p).ops - 1 do
+                  begin
+                    Write(T, ' ');
+
+                    ThisOper := FormatOp(taicpu(p).oper[X]);
+                    if X < taicpu(p).ops - 1 then
+                      begin
+                        ThisOper := ThisOper + ',';
+                        PadString(ThisOper, 7);
+                      end;
+
+                    Write(T, ThisOper);
+                  end;
+                WriteLn(T);
+              end;
+            else
+              { Do nothing };
+          end;
+        end;
+
+      var
+        hp: tai;
+      begin
+        if not Assigned(p_asm) then
+          Exit;
+
+        hp := tai(p_asm.First);
+        while Assigned(hp) do
+          begin
+            ProcessInstruction(hp);
+            hp := tai(hp.Next);
+          end;
+{$else defined(x86)}
+      begin
+        WriteLn(T, PrintNodeIndention, '(Assembler output not currently supported on this platform)');
+{$endif defined(x86)}
+{$else jvm}
+      begin
+        WriteLn(T, PrintNodeIndention, '(Should assembly language even be possible under JVM?)');
+{$endif jvm}
+      end;
+{$endif DEBUG_NODE_XML}
 
 {*****************************************************************************
                           TEMPBASENODE
@@ -939,6 +1125,47 @@ implementation
         settempinfoflags(gettempinfoflags-[flag])
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TTempBaseNode.XMLPrintNodeInfo(var T: Text);
+      begin
+        inherited XMLPrintNodeInfo(T);
+
+        { The raw pointer is the only way to uniquely identify the temp }
+        Write(T, ' id="', WritePointer(tempinfo), '"');
+      end;
+
+
+    procedure TTempBaseNode.XMLPrintNodeData(var T: Text);
+      var
+        Flag: TTempInfoFlag;
+        NotFirst: Boolean;
+      begin
+        inherited XMLPrintNodeData(t);
+
+        if not assigned(tempinfo) then
+          exit;
+
+        WriteLn(T, PrintNodeIndention, '<typedef>', SanitiseXMLString(tempinfo^.typedef.typesymbolprettyname), '</typedef>');
+
+        NotFirst := False;
+        for Flag := Low(TTempInfoFlag) to High(TTempInfoFlag) do
+          if (Flag in tempinfo^.flags) then
+            if not NotFirst then
+              begin
+                Write(T, PrintNodeIndention, '<tempflags>', Flag);
+                NotFirst := True;
+              end
+            else
+              Write(T, ',', Flag);
+
+        if NotFirst then
+          WriteLn(T, '</tempflags>')
+        else
+          WriteLn(T, PrintNodeIndention, '<tempflags />');
+
+        WriteLn(T, PrintNodeIndention, '<temptype>', tempinfo^.temptype, '</temptype>');
+      end;
+{$endif DEBUG_NODE_XML}
 
 {*****************************************************************************
                           TEMPCREATENODE
@@ -1136,6 +1363,24 @@ implementation
         printnode(t,tempinfo^.tempinitcode);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TTempCreateNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        WriteLn(T, PrintNodeIndention, '<size>', size, '</size>');
+        if Assigned(TempInfo^.TempInitCode) then
+          begin
+            WriteLn(T, PrintNodeIndention, '<tempinit>');
+            PrintNodeIndent;
+            XMLPrintNode(T, TempInfo^.TempInitCode);
+            PrintNodeUnindent;
+            WriteLn(T, PrintNodeIndention, '</tempinit>');
+          end
+        else
+          WriteLn(T, PrintNodeIndention, '<tempinit />');
+      end;
+{$endif DEBUG_NODE_XML}
+
 {*****************************************************************************
                              TEMPREFNODE
 *****************************************************************************}
@@ -1393,4 +1638,12 @@ implementation
           tempinfo^.typedef.GetTypeName,'", temptype = ',tempinfo^.temptype,', tempinfo = $',hexstr(ptrint(tempinfo),sizeof(ptrint)*2));
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TTempDeleteNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        WriteLn(T, PrintNodeIndention, '<release_to_normal>', release_to_normal, '</release_to_normal>');
+      end;
+{$endif DEBUG_NODE_XML}
+
 end.

compiler/ncal.pas

@@ -201,6 +201,9 @@ interface
        {$endif state_tracking}
           function  docompare(p: tnode): boolean; override;
           procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
           function  para_count:longint;
           function  required_para_count:longint;
           { checks if there are any parameters which end up at the stack, i.e.
@@ -1836,6 +1839,56 @@ implementation
            (not(cnf_typedefset in callnodeflags) and not(cnf_typedefset in tcallnode(p).callnodeflags)));
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TCallNode.XMLPrintNodeData(var T: Text);
+      begin
+        if assigned(procdefinition) and (procdefinition.typ=procdef) then
+          WriteLn(T, PrintNodeIndention, '<procname>', SanitiseXMLString(TProcDef(procdefinition).FullProcName(True)), '</procname>')
+        else
+          begin
+            if assigned(symtableprocentry) then
+              WriteLn(T, PrintNodeIndention, '<procname>', symtableprocentry.name, '</procname>')
+          end;
+
+        if assigned(methodpointer) then
+          begin
+            WriteLn(T, PrintNodeIndention, '<methodpointer>');
+            PrintNodeIndent;
+            XMLPrintNode(T, methodpointer);
+            PrintNodeUnindent;
+            WriteLn(T, PrintNodeIndention, '</methodpointer>');
+          end;
+
+        if assigned(funcretnode) then
+          begin
+            WriteLn(T, PrintNodeIndention, '<funcretnode>');
+            PrintNodeIndent;
+            XMLPrintNode(T, funcretnode);
+            PrintNodeUnindent;
+            WriteLn(T, PrintNodeIndention, '</funcretnode>');
+          end;
+
+        if assigned(callinitblock) then
+          begin
+            WriteLn(T, PrintNodeIndention, '<callinitblock>');
+            PrintNodeIndent;
+            XMLPrintNode(T, callinitblock);
+            PrintNodeUnindent;
+            WriteLn(T, PrintNodeIndention, '</callinitblock>');
+          end;
+
+        if assigned(callcleanupblock) then
+          begin
+            WriteLn(T, PrintNodeIndention, '<callcleanupblock>');
+            PrintNodeIndent;
+            XMLPrintNode(T, callcleanupblock);
+            PrintNodeUnindent;
+            WriteLn(T, PrintNodeIndention, '</callcleanupblock>');
+          end;
+
+        inherited XMLPrintNodeData(T);
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure tcallnode.printnodedata(var t:text);
       begin

compiler/ncnv.pas

@@ -64,6 +64,9 @@ interface
           procedure derefimpl;override;
           function dogetcopy : tnode;override;
           procedure printnodeinfo(var t : text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeInfo(var T: Text); override;
+{$endif DEBUG_NODE_XML}
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           function simplify(forinline : boolean):tnode; override;
@@ -1047,6 +1050,31 @@ implementation
         write(t,']');
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TTypeConvNode.XMLPrintNodeInfo(var T: Text);
+      var
+        First: Boolean;
+        i: TTypeConvNodeFlag;
+      begin
+        inherited XMLPrintNodeInfo(T);
+        Write(T,' convtype="', convtype);
+        First := True;
+        for i := Low(TTypeConvNodeFlag) to High(TTypeConvNodeFlag) do
+          if i in ConvNodeFlags then
+            begin
+              if First then
+                begin
+                  Write(T, '" convnodeflags="', i);
+                  First := False;
+                end
+              else
+                Write(T, ',', i);
+           end;
+
+        { If no flags were printed, this is the closing " for convtype }
+        Write(T, '"');
+      end;
+{$endif DEBUG_NODE_XML}
 
     function ttypeconvnode.typecheck_cord_to_pointer : tnode;
 

compiler/ncon.pas

@@ -48,6 +48,9 @@ interface
           function pass_typecheck:tnode;override;
           function docompare(p: tnode) : boolean; override;
           procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        trealconstnodeclass = class of trealconstnode;
 
@@ -70,6 +73,10 @@ interface
           function pass_typecheck:tnode;override;
           function docompare(p: tnode) : boolean; override;
           procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeInfo(var T: Text); override;
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tordconstnodeclass = class of tordconstnode;
 
@@ -87,6 +94,9 @@ interface
           function pass_typecheck:tnode;override;
           function docompare(p: tnode) : boolean; override;
           procedure printnodedata(var t : text); override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tpointerconstnodeclass = class of tpointerconstnode;
 
@@ -124,6 +134,9 @@ interface
           { returns whether this platform uses the nil pointer to represent
             empty dynamic strings }
           class function emptydynstrnil: boolean; virtual;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tstringconstnodeclass = class of tstringconstnode;
 
@@ -494,6 +507,13 @@ implementation
         writeln(t,printnodeindention,'value = ',value_real);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TRealConstNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        WriteLn(T, printnodeindention, '<value>', value_real, '</value>');
+      end;
+{$endif DEBUG_NODE_XML}
 
 {*****************************************************************************
                               TORDCONSTNODE
@@ -586,6 +606,20 @@ implementation
         writeln(t,printnodeindention,'value = ',tostr(value));
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TOrdConstNode.XMLPrintNodeInfo(var T: Text);
+      begin
+        inherited XMLPrintNodeInfo(T);
+        Write(T, ' rangecheck="', rangecheck, '"');
+      end;
+
+
+    procedure TOrdConstNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        WriteLn(T, printnodeindention, '<value>', tostr(value), '</value>');
+      end;
+{$endif DEBUG_NODE_XML}
 
 {*****************************************************************************
                             TPOINTERCONSTNODE
@@ -668,6 +702,13 @@ implementation
         writeln(t,printnodeindention,'value = $',hexstr(PUInt(value),sizeof(PUInt)*2));
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TPointerConstNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        WriteLn(T, PrintNodeIndention, '<value>$', hexstr(PUInt(value),sizeof(PUInt)*2), '</value>');
+      end;
+{$endif DEBUG_NODE_XML}
 
 {*****************************************************************************
                              TSTRINGCONSTNODE
@@ -1031,6 +1072,52 @@ implementation
         result:=true;
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TStringConstNode.XMLPrintNodeData(var T: Text);
+      var
+        OutputStr: ansistring;
+      begin
+        inherited XMLPrintNodeData(T);
+        Write(T, printnodeindention, '<stringtype>');
+        case cst_type of
+        cst_conststring:
+          Write(T, 'conststring');
+        cst_shortstring:
+          Write(T, 'shortstring');
+        cst_longstring:
+          Write(T, 'longstring');
+        cst_ansistring:
+          Write(T, 'ansistring');
+        cst_widestring:
+          Write(T, 'widestring');
+        cst_unicodestring:
+          Write(T, 'unicodestring');
+        end;
+        WriteLn(T, '</stringtype>');
+        WriteLn(T, printnodeindention, '<length>', len, '</length>');
+
+        if len = 0 then
+          begin
+            WriteLn(T, printnodeindention, '<value />');
+            Exit;
+          end;
+
+        case cst_type of
+        cst_widestring, cst_unicodestring:
+          begin
+            { value_str is of type PCompilerWideString }
+            SetLength(OutputStr, len);
+            UnicodeToUtf8(PChar(OutputStr), PUnicodeChar(PCompilerWideString(value_str)^.data), len + 1); { +1 for the null terminator }
+          end;
+        else
+          OutputStr := ansistring(value_str);
+          SetLength(OutputStr, len);
+        end;
+
+        WriteLn(T, printnodeindention, '<value>', SanitiseXMLString(OutputStr), '</value>');
+      end;
+{$endif DEBUG_NODE_XML}
+
 {*****************************************************************************
                              TSETCONSTNODE
 *****************************************************************************}

compiler/nflw.pas

@@ -68,6 +68,10 @@ interface
           procedure derefimpl;override;
           procedure insertintolist(l : tnodelist);override;
           procedure printnodetree(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeInfo(var T: Text); override;
+          procedure XMLPrintNodeTree(var T: Text); override;
+{$endif DEBUG_NODE_XML}
           function docompare(p: tnode): boolean; override;
        end;
 
@@ -1052,6 +1056,119 @@ implementation
         writeln(t,printnodeindention,')');
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TLoopNode.XMLPrintNodeInfo(var T: Text);
+      var
+        i: TLoopFlag;
+        First: Boolean;
+      begin
+        inherited XMLPrintNodeInfo(T);
+
+        First := True;
+        for i := Low(TLoopFlag) to High(TLoopFlag) do
+          if i in loopflags then
+            begin
+              if First then
+                begin
+                  Write(T, ' loopflags="', i);
+                  First := False;
+                end
+              else
+                Write(T, ',', i)
+            end;
+        if not First then
+          Write(T, '"');
+      end;
+
+    procedure TLoopNode.XMLPrintNodeTree(var T: Text);
+      begin
+        Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]);
+        XMLPrintNodeInfo(T);
+        WriteLn(T, '>');
+        PrintNodeIndent;
+        if Assigned(Left) then
+          begin
+            if nodetype = forn then
+              WriteLn(T, PrintNodeIndention, '<counter>')
+            else
+              WriteLn(T, PrintNodeIndention, '<condition>');
+            PrintNodeIndent;
+            XMLPrintNode(T, Left);
+            PrintNodeUnindent;
+            if nodetype = forn then
+              WriteLn(T, PrintNodeIndention, '</counter>')
+            else
+              WriteLn(T, PrintNodeIndention, '</condition>');
+          end;
+
+        if Assigned(Right) then
+          begin
+            case nodetype of
+              ifn:
+                WriteLn(T, PrintNodeIndention, '<then>');
+              forn:
+                WriteLn(T, PrintNodeIndention, '<first>');
+              else
+                WriteLn(T, PrintNodeIndention, '<right>');
+            end;
+            PrintNodeIndent;
+            XMLPrintNode(T, Right);
+            PrintNodeUnindent;
+            case nodetype of
+              ifn:
+                WriteLn(T, PrintNodeIndention, '</then>');
+              forn:
+                WriteLn(T, PrintNodeIndention, '</first>');
+              else
+                WriteLn(T, PrintNodeIndention, '</right>');
+            end;
+          end;
+
+        if Assigned(t1) then
+          begin
+            case nodetype of
+              ifn:
+                WriteLn(T, PrintNodeIndention, '<else>');
+              forn:
+                WriteLn(T, PrintNodeIndention, '<last>');
+              else
+                WriteLn(T, PrintNodeIndention, '<t1>');
+            end;
+            PrintNodeIndent;
+            XMLPrintNode(T, t1);
+            PrintNodeUnindent;
+            case nodetype of
+              ifn:
+                WriteLn(T, PrintNodeIndention, '</else>');
+              forn:
+                WriteLn(T, PrintNodeIndention, '</last>');
+              else
+                WriteLn(T, PrintNodeIndention, '</t1>');
+            end;
+          end;
+
+        if Assigned(t2) then
+          begin
+
+            if nodetype <> forn then
+              begin
+                WriteLn(T, PrintNodeIndention, '<loop>');
+                PrintNodeIndent;
+              end;
+
+            XMLPrintNode(T, t2);
+
+            if nodetype <> forn then
+              begin
+                PrintNodeUnindent;
+                WriteLn(T, PrintNodeIndention, '</loop>');
+              end;
+          end;
+
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
+      end;
+{$endif DEBUG_NODE_XML}
 
     function tloopnode.docompare(p: tnode): boolean;
       begin

compiler/ninl.pas

@@ -36,6 +36,9 @@ interface
           procedure ppuwrite(ppufile:tcompilerppufile);override;
           function dogetcopy : tnode;override;
           procedure printnodeinfo(var t : text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeInfo(var t : text);override;
+{$endif DEBUG_NODE_XML}
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           function pass_typecheck_cpu:tnode;virtual;
@@ -191,6 +194,13 @@ implementation
         write(t,', inlinenumber = ',inlinenumber);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TInlineNode.XMLPrintNodeInfo(var T: Text);
+      begin
+        inherited;
+        Write(T, ' inlinenumber="', inlinenumber, '"');
+      end;
+{$endif DEBUG_NODE_XML}
 
     function get_str_int_func(def: tdef): string;
     var

compiler/nld.pas

@@ -71,6 +71,9 @@ interface
           procedure mark_write;override;
           function  docompare(p: tnode): boolean; override;
           procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
           procedure setprocdef(p : tprocdef);
           property procdef: tprocdef read fprocdef write setprocdef;
        end;
@@ -97,6 +100,9 @@ interface
           function track_state_pass(exec_known:boolean):boolean;override;
        {$endif state_tracking}
           function docompare(p: tnode): boolean; override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tassignmentnodeclass = class of tassignmentnode;
 
@@ -471,6 +477,16 @@ implementation
         writeln(t,'');
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TLoadNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        WriteLn(T, printnodeindention, '<symbol>', symtableentry.name, '</symbol>');
+
+        if symtableentry.typ = procsym then
+          WriteLn(T, printnodeindention, '<procdef>', fprocdef.mangledname, '</procdef>');
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure tloadnode.setprocdef(p : tprocdef);
       begin
@@ -956,6 +972,18 @@ implementation
 {$endif}
 
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TAssignmentNode.XMLPrintNodeData(var T: Text);
+      begin
+        { For assignments, put the left and right branches on the same level for clarity }
+        XMLPrintNode(T, Left);
+        XMLPrintNode(T, Right);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
+      end;
+{$endif DEBUG_NODE_XML}
+
+
 {*****************************************************************************
                            TARRAYCONSTRUCTORRANGENODE
 *****************************************************************************}

compiler/nmem.pas

@@ -88,6 +88,9 @@ interface
           procedure buildderefimpl;override;
           procedure derefimpl;override;
           procedure printnodeinfo(var t: text); override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeInfo(var T: Text); override;
+{$endif DEBUG_NODE_XML}
           function docompare(p: tnode): boolean; override;
           function dogetcopy : tnode;override;
           function pass_1 : tnode;override;
@@ -121,6 +124,9 @@ interface
           function docompare(p: tnode): boolean; override;
           function pass_typecheck:tnode;override;
           procedure mark_write;override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tsubscriptnodeclass = class of tsubscriptnode;
 
@@ -133,6 +139,9 @@ interface
           function pass_1 : tnode;override;
           function pass_typecheck:tnode;override;
           procedure mark_write;override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
        end;
        tvecnodeclass = class of tvecnode;
 
@@ -481,6 +490,29 @@ implementation
         write(t,']');
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TAddrNode.XMLPrintNodeInfo(var T: Text);
+      var
+        First: Boolean;
+        i: TAddrNodeFlag;
+      begin
+        inherited XMLPrintNodeInfo(t);
+        First := True;
+        for i := Low(TAddrNodeFlag) to High(TAddrNodeFlag) do
+          if i in addrnodeflags then
+            begin
+              if First then
+                begin
+                  Write(T, ' addrnodeflags="', i);
+                  First := False;
+                end
+              else
+                Write(T, ',', i);
+            end;
+        if not First then
+          Write(T, '"');
+      end;
+{$endif DEBUG_NODE_XML}
 
     function taddrnode.docompare(p: tnode): boolean;
       begin
@@ -897,6 +929,13 @@ implementation
           (vs = tsubscriptnode(p).vs);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TSubscriptNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        WriteLn(T, PrintNodeIndention, '<field>', vs.Name, '</field>');
+      end;
+{$endif DEBUG_NODE_XML}
 
 {*****************************************************************************
                                TVECNODE
@@ -1299,6 +1338,24 @@ implementation
     end;
 
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TVecNode.XMLPrintNodeData(var T: Text);
+      begin
+        XMLPrintNode(T, Left);
+
+        { The right node is the index }
+        WriteLn(T, PrintNodeIndention, '<index>');
+        PrintNodeIndent;
+        XMLPrintNode(T, Right);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</index>');
+
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
+      end;
+{$endif DEBUG_NODE_XML}
+
+
     function is_big_untyped_addrnode(p: tnode): boolean;
       begin
         is_big_untyped_addrnode:=(p.nodetype=addrn) and

compiler/node.pas

@@ -383,6 +383,15 @@ interface
          procedure printnodeinfo(var t:text);virtual;
          procedure printnodedata(var t:text);virtual;
          procedure printnodetree(var t:text);virtual;
+{$ifdef DEBUG_NODE_XML}
+         { For writing nodes to XML files - do not call directly, but
+           instead call XMLPrintNode to write a complete tree }
+         procedure XMLPrintNodeInfo(var T: Text); dynamic;
+         procedure XMLPrintNodeData(var T: Text); virtual;
+         procedure XMLPrintNodeTree(var T: Text); virtual;
+         class function SanitiseXMLString(const S: ansistring): ansistring;
+         class function WritePointer(const P: Pointer): ansistring;
+{$endif DEBUG_NODE_XML}
          procedure concattolist(l : tlinkedlist);virtual;
          function ischild(p : tnode) : boolean;virtual;
 
@@ -413,6 +422,9 @@ interface
          function dogetcopy : tnode;override;
          procedure insertintolist(l : tnodelist);override;
          procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+         procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
       end;
 
       //pbinarynode = ^tbinarynode;
@@ -431,6 +443,10 @@ interface
          function dogetcopy : tnode;override;
          procedure insertintolist(l : tnodelist);override;
          procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+         procedure XMLPrintNodeTree(var T: Text); override;
+         procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
          procedure printnodelist(var t:text);
       end;
 
@@ -449,11 +465,17 @@ interface
          function dogetcopy : tnode;override;
          procedure insertintolist(l : tnodelist);override;
          procedure printnodedata(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+         procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
       end;
 
       tbinopnode = class(tbinarynode)
          constructor create(t:tnodetype;l,r : tnode);virtual;
          function docompare(p : tnode) : boolean;override;
+{$ifdef DEBUG_NODE_XML}
+         procedure XMLPrintNodeData(var T: Text); override;
+{$endif DEBUG_NODE_XML}
       end;
 
     var
@@ -476,7 +498,9 @@ interface
     procedure printnodeunindent;
     procedure printnode(var t:text;n:tnode);
     procedure printnode(n:tnode);
-
+{$ifdef DEBUG_NODE_XML}
+    procedure XMLPrintNode(var T: Text; N: TNode);
+{$endif DEBUG_NODE_XML}
     function is_constnode(p : tnode) : boolean;
     function is_constintnode(p : tnode) : boolean;
     function is_constcharnode(p : tnode) : boolean;
@@ -494,6 +518,9 @@ implementation
 
     uses
        verbose,entfile,comphook,
+{$ifdef DEBUG_NODE_XML}
+       cutils,
+{$endif DEBUG_NODE_XML}
        symconst,
        nutils,nflw,
        defutil;
@@ -656,6 +683,13 @@ implementation
         printnode(output,n);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure XMLPrintNode(var T: Text; N: TNode);
+      begin
+        if Assigned(N) then
+          N.XMLPrintNodeTree(T);
+      end;
+{$endif DEBUG_NODE_XML}
 
     function is_constnode(p : tnode) : boolean;
       begin
@@ -898,6 +932,354 @@ implementation
          writeln(t,printnodeindention,')');
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    { For writing nodes to XML files - do not call directly, but
+      instead call XMLPrintNode to write a complete tree }
+    procedure tnode.XMLPrintNodeInfo(var T: Text);
+      var
+        i: TNodeFlag;
+        first: Boolean;
+      begin
+        if Assigned(resultdef) then
+          Write(T,' resultdef="', SanitiseXMLString(resultdef.typesymbolprettyname), '"');
+
+        Write(T,' pos="',fileinfo.line,',',fileinfo.column);
+
+        First := True;
+        for i := Low(TNodeFlag) to High(TNodeFlag) do
+          if i in flags then
+            begin
+              if First then
+                begin
+                  Write(T, '" flags="', i);
+                  First := False;
+                end
+              else
+                Write(T, ',', i)
+            end;
+
+        write(t,'" complexity="',node_complexity(self),'"');
+      end;
+
+    procedure tnode.XMLPrintNodeData(var T: Text);
+      begin
+        { Nothing by default }
+      end;
+
+    procedure tnode.XMLPrintNodeTree(var T: Text);
+      begin
+        Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]);
+        XMLPrintNodeInfo(T);
+        WriteLn(T, '>');
+        PrintNodeIndent;
+        XMLPrintNodeData(T);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
+      end;
+
+    class function TNode.WritePointer(const P: Pointer): ansistring;
+      begin
+        case PtrUInt(P) of
+          0:
+            WritePointer := 'nil';
+          1..$FFFF:
+            WritePointer := '$' + hexstr(PtrUInt(P), 4);
+          $10000..$FFFFFFFF:
+            WritePointer := '$' + hexstr(PtrUInt(P), 8);
+{$ifdef CPU64}
+          else
+            WritePointer := '$' + hexstr(PtrUInt(P), 16);
+{$endif CPU64}
+        end;
+      end;
+
+    class function TNode.SanitiseXMLString(const S: ansistring): ansistring;
+      var
+        X, UTF8Len, UTF8Char, CurrentChar: Integer;
+        needs_quoting, in_quotes, add_end_quote: Boolean;
+        DoASCII: Boolean;
+
+        { Write the given byte as #xxx }
+        procedure EncodeControlChar(Value: Byte);
+          begin
+            if X = Length(Result) then
+              add_end_quote := False;
+
+            Delete(Result, X, 1);
+            if in_quotes then
+              begin
+                Insert('#' + tostr(Value) + '''', Result, X);
+
+                { If the entire string consists of control characters, it
+                  doesn't need quoting, so only set the flag here }
+                needs_quoting := True;
+
+                in_quotes := False;
+              end
+            else
+              Insert('#' + tostr(Value), Result, X);
+          end;
+
+        { Write the given byte as either a plain character or an XML keyword }
+        procedure EncodeStandardChar(Value: Byte);
+          begin
+            if not in_quotes then
+              begin
+                in_quotes := True;
+                if (X < Length(Result)) then
+                  begin
+                    needs_quoting := True;
+                    Insert('''', Result, X + 1)
+                  end;
+              end;
+
+            { Check the character for anything that could be mistaken for an XML element }
+            case CurrentChar of
+              Ord('#'):
+                { Required to differentiate '#27' from the escape code #27, for example }
+                needs_quoting:=true;
+
+              Ord('<'):
+                begin
+                  Delete(Result, X, 1);
+                  Insert('&lt;', Result, X);
+                end;
+              Ord('>'):
+                begin
+                  Delete(Result, X, 1);
+                  Insert('&gt;', Result, X);
+                end;
+              Ord('&'):
+                begin
+                  Delete(Result, X, 1);
+                  Insert('&amp;', Result, X);
+                end;
+              Ord('"'):
+                begin
+                  needs_quoting := True;
+                  Delete(Result, X, 1);
+                  Insert('&quot;', Result, X);
+                end;
+              Ord(''''):
+                begin
+                  needs_quoting:=true;
+                  { Simply double it like in pascal strings }
+                  Insert('''', Result, X);
+                end;
+              else
+                { Do nothing };
+            end;
+          end;
+
+        { Convert character between $80 and $FF to UTF-8 }
+        procedure EncodeExtendedChar(Value: Byte);
+          begin
+            if not in_quotes then
+              begin
+                in_quotes := True;
+                if (X < Length(Result)) then
+                  begin
+                    needs_quoting := True;
+                    Insert('''', Result, X + 1)
+                  end;
+              end;
+
+            case Value of
+              $80..$BF: { Add $C2 before the value }
+                Insert(#$C2, Result, X);
+              $C0..$FF: { Zero the $40 bit and add $C3 before the value }
+                begin
+                  Result[X] := Char(Byte(Result[X]) and $BF);
+                  Insert(#$C3, Result, X);
+                end;
+              else
+                { Previous conditions should prevent this procedure from being
+                  called if Value < $80 }
+                InternalError(2019061901);
+            end;
+          end;
+
+      begin
+        needs_quoting := False;
+        Result := S;
+
+        { Gets set to True if an invalid UTF-8 sequence is found }
+        DoASCII := False;
+
+        { By setting in_quotes to false here, we can exclude the single
+          quotation marks surrounding the string if it doesn't contain any
+          control characters, or consists entirely of control characters. }
+        in_quotes := False;
+
+        add_end_quote := True;
+
+        X := Length(Result);
+        while X > 0 do
+          begin
+            CurrentChar := Ord(Result[X]);
+
+            { Control characters and extended characters need special handling }
+            case CurrentChar of
+              $00..$1F, $7F:
+                EncodeControlChar(CurrentChar);
+
+              $20..$7E:
+                EncodeStandardChar(CurrentChar);
+
+              { UTF-8 continuation byte }
+              $80..$BF:
+                begin
+                  if not in_quotes then
+                    begin
+                      in_quotes := True;
+                      if (X < Length(Result)) then
+                        begin
+                          needs_quoting := True;
+                          Insert('''', Result, X + 1)
+                        end;
+                    end;
+
+                  UTF8Char := CurrentChar and $3F; { The data bits of the continuation byte }
+                  UTF8Len := 1; { This variable actually holds 1 less than the length }
+
+                  { By setting DoASCII to true, it marks the string as 'invalid UTF-8'
+                    automatically if it reaches the beginning of the string unexpectedly }
+                  DoASCII := True;
+
+                  Dec(X);
+                  while X > 0 do
+                    begin
+                      CurrentChar := Ord(Result[X]);
+
+                      case CurrentChar of
+                        { A standard character here is invalid UTF-8 }
+                        $00..$7F:
+                          Break;
+
+                        { Another continuation byte }
+                        $80..$BF:
+                          begin
+                            UTF8Char := UTF8Char or ((CurrentChar and $3F) shl (6 * UTF8Len));
+
+                            Inc(UTF8Len);
+                            if UTF8Len >= 4 then
+                              { Sequence too long }
+                              Break;
+                          end;
+
+                        { Lead byte for 2-byte sequences }
+                        $C2..$DF:
+                          begin
+                            if UTF8Len <> 1 then Break;
+
+                            UTF8Char := UTF8Char or ((CurrentChar and $1F) shl 6);
+
+                            { Check to see if the code is in range and not part of an 'overlong' sequence }
+                            case UTF8Char of
+                              $0080..$07FF:
+                                DoASCII := False;
+                              else
+                                { Do nothing - DoASCII is already true }
+                            end;
+                            Break;
+                          end;
+
+                        { Lead byte for 3-byte sequences }
+                        $E0..$EF:
+                          begin
+                            if UTF8Len <> 2 then Break;
+
+                            UTF8Char := UTF8Char or ((CurrentChar and $0F) shl 12);
+
+                            { Check to see if the code is in range and not part of an 'overlong' sequence }
+                            case UTF8Char of
+                              $0800..$D7FF, $E000..$FFFF: { $D800..$DFFF is reserved and hence invalid }
+                                DoASCII := False;
+                              else
+                                { Do nothing - DoASCII is already true }
+                            end;
+                            Break;
+                          end;
+
+                        { Lead byte for 4-byte sequences }
+                        $F0..$F4:
+                          begin
+                            if UTF8Len <> 3 then Break;
+
+                            UTF8Char := UTF8Char or ((CurrentChar and $07) shl 18);
+
+                            { Check to see if the code is in range and not part of an 'overlong' sequence }
+                            case UTF8Char of
+                              $010000..$10FFFF:
+                                DoASCII := False;
+                              else
+                                { Do nothing - DoASCII is already true }
+                            end;
+                            Break;
+                          end;
+
+                        { Invalid character }
+                        else
+                          Break;
+                      end;
+                    end;
+
+                  if DoASCII then
+                    Break;
+
+                  { If all is fine, we don't need to encode any more characters }
+                end;
+
+              { Invalid UTF-8 bytes and lead bytes without continuation bytes }
+              $C0..$FF:
+                begin
+                  DoASCII := True;
+                  Break;
+                end;
+            end;
+
+            Dec(X);
+          end;
+
+        { UTF-8 failed, so encode the string as plain ASCII }
+        if DoASCII then
+          begin
+            { Reset the flags and Result }
+            needs_quoting := False;
+            Result := S;
+            in_quotes := False;
+            add_end_quote := True;
+
+            for X := Length(Result) downto 1 do
+              begin
+                CurrentChar := Ord(Result[X]);
+
+                { Control characters and extended characters need special handling }
+                case CurrentChar of
+                  $00..$1F, $7F:
+                    EncodeControlChar(CurrentChar);
+
+                  $20..$7E:
+                    EncodeStandardChar(CurrentChar);
+
+                  { Extended characters }
+                  else
+                    EncodeExtendedChar(CurrentChar);
+
+                end;
+              end;
+          end;
+
+        if needs_quoting then
+          begin
+            if in_quotes then
+              Result := '''' + Result;
+
+            if add_end_quote then
+              Result := Result + '''';
+          end;
+      end;
+{$endif DEBUG_NODE_XML}
 
     function tnode.isequal(p : tnode) : boolean;
       begin
@@ -1058,6 +1440,13 @@ implementation
          printnode(t,left);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TUnaryNode.XMLPrintNodeData(var T: Text);
+      begin
+         inherited XMLPrintNodeData(T);
+         XMLPrintNode(T, Left);
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure tunarynode.concattolist(l : tlinkedlist);
       begin
@@ -1185,6 +1574,26 @@ implementation
          printnode(t,right);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TBinaryNode.XMLPrintNodeTree(var T: Text);
+      begin
+        Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]);
+        XMLPrintNodeInfo(T);
+        WriteLn(T, '>');
+        PrintNodeIndent;
+        XMLPrintNodeData(T);
+      end;
+
+
+    procedure TBinaryNode.XMLPrintNodeData(var T: Text);
+      begin
+        inherited XMLPrintNodeData(T);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
+        { Right nodes are on the same indentation level }
+        XMLPrintNode(T, Right);
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure tbinarynode.printnodelist(var t:text);
       var
@@ -1286,6 +1695,21 @@ implementation
          printnode(t,third);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TTertiaryNode.XMLPrintNodeData(var T: Text);
+      begin
+         if Assigned(Third) then
+           begin
+             WriteLn(T, PrintNodeIndention, '<third-branch>');
+             PrintNodeIndent;
+             XMLPrintNode(T, Third);
+             PrintNodeUnindent;
+             WriteLn(T, PrintNodeIndention, '</third-branch>');
+           end;
+
+         inherited XMLPrintNodeData(T);
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure ttertiarynode.concattolist(l : tlinkedlist);
       begin
@@ -1320,6 +1744,18 @@ implementation
             right.isequal(tbinopnode(p).left));
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TBinOpNode.XMLPrintNodeData(var T: Text);
+      begin
+        { For binary operations, put the left and right branches on the same level for clarity }
+        XMLPrintNode(T, Left);
+        XMLPrintNode(T, Right);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
+      end;
+{$endif DEBUG_NODE_XML}
+
+
 begin
 {$push}{$warnings off}
   { tvaroption must fit into a 4 byte set for speed reasons }

compiler/nset.pas

@@ -120,6 +120,9 @@ interface
           procedure derefimpl;override;
           function dogetcopy : tnode;override;
           procedure printnodetree(var t:text);override;
+{$ifdef DEBUG_NODE_XML}
+          procedure XMLPrintNodeTree(var t:text); override;
+{$endif DEBUG_NODE_XML}
           procedure insertintolist(l : tnodelist);override;
           function pass_typecheck:tnode;override;
           function pass_1 : tnode;override;
@@ -1014,6 +1017,43 @@ implementation
         writeln(t,printnodeindention,')');
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure TCaseNode.XMLPrintNodeTree(var T: Text);
+      var
+        i : longint;
+      begin
+        Write(T, PrintNodeIndention, '<', nodetype2str[nodetype]);
+        XMLPrintNodeInfo(T);
+        WriteLn(T, '>');
+        PrintNodeIndent;
+        WriteLn(T, PrintNodeIndention, '<condition>');
+        PrintNodeIndent;
+        XMLPrintNode(T, Left);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</condition>');
+
+        i:=0;
+        for i:=0 to blocks.count-1 do
+          begin
+            WriteLn(T, PrintNodeIndention, '<block id="', i, '">');
+            PrintNodeIndent;
+            XMLPrintNode(T, PCaseBlock(blocks[i])^.statement);
+            PrintNodeUnindent;
+            WriteLn(T, PrintNodeIndention, '</block>');
+          end;
+        if assigned(elseblock) then
+          begin
+            WriteLn(T, PrintNodeIndention, '<block id="else">');;
+            PrintNodeIndent;
+            XMLPrintNode(T, ElseBlock);
+            PrintNodeUnindent;
+            WriteLn(T, PrintNodeIndention, '</block>');
+          end;
+
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</', nodetype2str[nodetype], '>');
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure tcasenode.insertintolist(l : tnodelist);
       begin

compiler/pmodules.pas

@@ -886,6 +886,10 @@ type
          current_module.SetFileName(main_file.path+main_file.name,true);
          current_module.SetModuleName(unitname);
 
+{$ifdef DEBUG_NODE_XML}
+         XMLInitializeNodeFile('unit', unitname);
+{$endif DEBUG_NODE_XML}
+
          { check for system unit }
          new(s2);
          s2^:=upper(ChangeFileExt(ExtractFileName(main_file.name),''));
@@ -1023,6 +1027,10 @@ type
             Message1(unit_f_errors_in_unit,tostr(Errorcount));
             status.skip_error:=true;
             symtablestack.pop(current_module.globalsymtable);
+
+{$ifdef DEBUG_NODE_XML}
+            XMLFinalizeNodeFile('unit');
+{$endif DEBUG_NODE_XML}
             exit;
           end;
 
@@ -1316,6 +1324,10 @@ type
             module_is_done;
             if not immediate then
               restore_global_state(globalstate,true);
+
+{$ifdef DEBUG_NODE_XML}
+            XMLFinalizeNodeFile('unit');
+{$endif DEBUG_NODE_XML}
             exit;
           end;
 
@@ -1405,6 +1417,10 @@ type
             module_is_done;
             if not immediate then
               restore_global_state(globalstate,true);
+
+{$ifdef DEBUG_NODE_XML}
+            XMLFinalizeNodeFile('unit');
+{$endif DEBUG_NODE_XML}
             exit;
           end;
 
@@ -1464,6 +1480,9 @@ type
                 waitingmodule.end_of_parsing;
               end;
           end;
+{$ifdef DEBUG_NODE_XML}
+        XMLFinalizeNodeFile('unit');
+{$endif DEBUG_NODE_XML}
       end;
 
 
@@ -1545,6 +1564,10 @@ type
 
          setupglobalswitches;
 
+{$ifdef DEBUG_NODE_XML}
+         XMLInitializeNodeFile('package', module_name);
+{$endif DEBUG_NODE_XML}
+
          consume(_SEMICOLON);
 
          { global switches are read, so further changes aren't allowed }
@@ -1727,6 +1750,10 @@ type
              main_procinfo.generate_code;
            end;
 
+{$ifdef DEBUG_NODE_XML}
+         XMLFinalizeNodeFile('package');
+{$endif DEBUG_NODE_XML}
+
          { leave when we got an error }
          if (Errorcount>0) and not status.skip_error then
            begin
@@ -1991,6 +2018,10 @@ type
               setupglobalswitches;
 
               consume(_SEMICOLON);
+
+{$ifdef DEBUG_NODE_XML}
+              XMLInitializeNodeFile('library', program_name);
+{$endif DEBUG_NODE_XML}
            end
          else
            { is there an program head ? }
@@ -2037,6 +2068,10 @@ type
               setupglobalswitches;
 
               consume(_SEMICOLON);
+
+{$ifdef DEBUG_NODE_XML}
+              XMLInitializeNodeFile('program', program_name);
+{$endif DEBUG_NODE_XML}
             end
          else
            begin
@@ -2045,6 +2080,10 @@ type
 
              { setup things using the switches }
              setupglobalswitches;
+
+{$ifdef DEBUG_NODE_XML}
+             XMLInitializeNodeFile('program', current_module.realmodulename^);
+{$endif DEBUG_NODE_XML}
            end;
 
          { load all packages, so we know whether a unit is contained inside a
@@ -2267,6 +2306,13 @@ type
          { consume the last point }
          consume(_POINT);
 
+{$ifdef DEBUG_NODE_XML}
+         if IsLibrary then
+           XMLFinalizeNodeFile('library')
+         else
+           XMLFinalizeNodeFile('program');
+{$endif DEBUG_NODE_XML}
+
          { reset wpo flags for all defs }
          reset_all_defs;
 

compiler/psub.pas

@@ -68,11 +68,18 @@ interface
 
         function has_assembler_child : boolean;
         procedure set_eh_info; override;
+{$ifdef DEBUG_NODE_XML}
+        procedure XMLPrintProc;
+{$endif DEBUG_NODE_XML}
       end;
 
 
     procedure printnode_reset;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure XMLInitializeNodeFile(RootName, ModuleName: shortstring);
+    procedure XMLFinalizeNodeFile(RootName: shortstring);
+{$endif DEBUG_NODE_XML}
     { reads the declaration blocks }
     procedure read_declarations(islibrary : boolean);
 
@@ -1153,6 +1160,67 @@ implementation
       end;
 
 
+{$ifdef DEBUG_NODE_XML}
+    procedure tcgprocinfo.XMLPrintProc;
+      var
+        T: Text;
+        W: Word;
+        syssym: tsyssym;
+
+      procedure PrintOption(Flag: string);
+        begin
+          WriteLn(T, PrintNodeIndention, '<option>', Flag, '</option>');
+        end;
+
+      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}
+        Write(T, PrintNodeIndention, '<procedure');
+        Write(T, ' name="', TNode.SanitiseXMLString(procdef.customprocname([])), '"');
+
+        if po_hascallingconvention in procdef.procoptions then
+          Write(T, ' convention="', proccalloptionStr[procdef.proccalloption], '"');
+
+        WriteLn(T, '>');
+
+        PrintNodeIndent;
+
+        if po_compilerproc in procdef.procoptions then
+          PrintOption('compilerproc');
+        if po_assembler in procdef.procoptions then
+          PrintOption('assembler');
+        if po_nostackframe in procdef.procoptions then
+          PrintOption('nostackframe');
+        if po_inline in procdef.procoptions then
+          PrintOption('inline');
+        if po_noreturn in procdef.procoptions then
+          PrintOption('noreturn');
+        if po_noinline in procdef.procoptions then
+          PrintOption('noinline');
+
+        WriteLn(T, PrintNodeIndention, '<code>');
+        PrintNodeIndent;
+        XMLPrintNode(T, Code);
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</code>');
+        PrintNodeUnindent;
+        WriteLn(T, PrintNodeIndention, '</procedure>');
+        WriteLn(T); { Line for spacing }
+        Close(T);
+      end;
+{$endif DEBUG_NODE_XML}
+
     procedure tcgprocinfo.generate_code_tree;
       var
         hpi : tcgprocinfo;
@@ -1450,7 +1518,7 @@ implementation
 {$endif i386 or i8086}
 
         { Print the node to tree.log }
-        if paraprintnodetree=1 then
+        if paraprintnodetree <> 0 then
           printproc( 'after the firstpass');
 
         { do this before adding the entry code else the tail recursion recognition won't work,
@@ -1577,7 +1645,7 @@ implementation
             CalcExecutionWeights(code);
 
             { Print the node to tree.log }
-            if paraprintnodetree=1 then
+            if paraprintnodetree <> 0 then
               printproc( 'right before code generation');
 
             { generate code for the node tree }
@@ -2073,9 +2141,14 @@ implementation
            CreateInlineInfo;
 
          { Print the node to tree.log }
-         if paraprintnodetree=1 then
+         if paraprintnodetree <> 0 then
            printproc( 'after parsing');
 
+{$ifdef DEBUG_NODE_XML}
+         printnodeindention := printnodespacing;
+         XMLPrintProc;
+{$endif DEBUG_NODE_XML}
+
          { ... remove symbol tables }
          remove_from_symtablestack;
 
@@ -2491,6 +2564,50 @@ implementation
           MessagePos1(tsym(p).fileinfo,sym_e_forward_type_not_resolved,tsym(p).realname);
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    procedure XMLInitializeNodeFile(RootName, ModuleName: shortstring);
+      var
+        T: Text;
+      begin
+        Assign(T, current_module.ppxfilename);
+        {$push} {$I-}
+        Rewrite(T);
+        if IOResult<>0 then
+          begin
+            Message1(exec_e_cant_create_archivefile,current_module.ppxfilename);
+            current_module.ppxfilefail := True;
+            Exit;
+          end;
+        {$pop}
+        { Mark the node dump file as available for writing }
+        current_module.ppxfilefail := False;
+        WriteLn(T, '<?xml version="1.0" encoding="utf-8"?>');
+        WriteLn(T, '<', RootName, ' name="', ModuleName, '">');
+        Close(T);
+      end;
+
+
+    procedure XMLFinalizeNodeFile(RootName: shortstring);
+      var
+        T: Text;
+      begin
+        if current_module.ppxfilefail then
+          Exit;
+
+        current_module.ppxfilefail := True; { File is now considered closed no matter what happens }
+        Assign(T, current_module.ppxfilename);
+        {$push} {$I-}
+        Append(T);
+        if IOResult<>0 then
+          begin
+            Message1(exec_e_cant_create_archivefile,current_module.ppxfilename);
+            Exit;
+          end;
+        {$pop}
+        WriteLn(T, '</', RootName, '>');
+        Close(T);
+      end;
+{$endif DEBUG_NODE_XML}
 
     procedure read_declarations(islibrary : boolean);
       var