View Issue Details

IDProjectCategoryView StatusLast Update
0036882FPCCompilerpublic2020-04-07 05:55
ReporterJ. Gareth Moreton Assigned ToPierre Muller  
PrioritylowSeverityfeatureReproducibilityalways
Status assignedResolutionopen 
PlatformCross-platformOSMicrosoft Windows 
Product Version3.3.1 
Summary0036882: [Feature] Class and record definition XML dump extension
DescriptionThese patches extend the node dump feature (enabled with DEBUG_NODE_XML) so it also dumps class and record definitions to the XML file. They are contained within <definition> tags.

Currently only fields and constants are dumped to the XML file. Methods, constant and variable definitions may be added later.
Steps To Reproduce- Apply patches.
- Confirm compiler builds with no changes when DEBUG_NODE_XML is specified.
- Confirm compiler builds with extended XML dump information when DEBUG_NODE_XML is specified (WARNING: uses a lot of disk space).
Additional Information- "node-dump-extension-refactor.patch" should not change the current node dump behaviour, but moves some functions so non-node classes can use them.
- "node-dump-extension-defs.patch" requires "node-dump-extension-refactor.patch" to work, and contains the changes required to allow record and class definitions to be dumped to the relevant XML file.

For example, the declaration:

type TVec = record
  X, Y, Z: Single;
end;

Appears as the following in the XML dump:

   <definition name="TVec" pos="29,9">
      <type><record></type>
      <size>12</size>
      <alignment>4</alignment>
      <field name="X" pos="30,5">
         <type>Single</type>
         <visibility>vis_public</visibility>
         <offset>0</offset>
         <size>4</size>
      </field>
      <field name="Y" pos="30,8">
         <type>Single</type>
         <visibility>vis_public</visibility>
         <offset>4</offset>
         <size>4</size>
      </field>
      <field name="Z" pos="30,11">
         <type>Single</type>
         <visibility>vis_public</visibility>
         <offset>8</offset>
         <size>4</size>
      </field>
   </definition>

(I might have the visibility field be omitted later on if it is vis_public)

The idea behind this extra information in the node dump files, even though they're not actually nodes, is to aid with compiler development where vectorisation is concerned by confirming, say, the offsets and sizes of fields are suitable for transferring en masse to an XMM register, and studying a selection of nodes in the same file that might be suitable for vectorisation.
Tagscompiler, debug, patch, XML
Fixed in Revision
FPCOldBugId
FPCTarget-
Attached Files

Relationships

child of 0035017 resolvedPierre Muller [Feature] XML node dump 

Activities

J. Gareth Moreton

2020-04-07 05:50

developer  

xml-node-dump-refactor.patch (26,389 bytes)   
Index: compiler/node.pas
===================================================================
--- compiler/node.pas	(revision 44513)
+++ compiler/node.pas	(working copy)
@@ -391,8 +391,6 @@
          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; static;
-         class function WritePointer(const P: Pointer): ansistring; static;
 {$endif DEBUG_NODE_XML}
          procedure concattolist(l : tlinkedlist);virtual;
          function ischild(p : tnode) : boolean;virtual;
@@ -490,14 +488,6 @@
     function ppuloadnodetree(ppufile:tcompilerppufile):tnode;
     procedure ppuwritenodetree(ppufile:tcompilerppufile;n:tnode);
 
-    const
-      printnodespacing = '   ';
-    var
-      { indention used when writing the tree to the screen }
-      printnodeindention : string;
-
-    procedure printnodeindent;
-    procedure printnodeunindent;
     procedure printnode(var t:text;n:tnode);
     procedure printnode(n:tnode);
 {$ifdef DEBUG_NODE_XML}
@@ -660,18 +650,6 @@
       end;
 
 
-    procedure printnodeindent;
-      begin
-        printnodeindention:=printnodeindention+printnodespacing;
-      end;
-
-
-    procedure printnodeunindent;
-      begin
-        delete(printnodeindention,1,length(printnodespacing));
-      end;
-
-
     procedure printnode(var t:text;n:tnode);
       begin
         if assigned(n) then
@@ -979,309 +957,6 @@
         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;
Index: compiler/psub.pas
===================================================================
--- compiler/psub.pas	(revision 44513)
+++ compiler/psub.pas	(working copy)
@@ -1307,7 +1307,7 @@
         if Assigned(procdef.struct) then
           begin
             if Assigned(procdef.struct.objrealname) then
-              Write(T, ' struct="', TNode.SanitiseXMLString(procdef.struct.objrealname^), '"')
+              Write(T, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
             else
               Write(T, ' struct="&lt;NULL&gt;"');
           end;
@@ -1355,7 +1355,7 @@
             PrintType('package stub');
         end;
 
-        Write(T, ' name="', TNode.SanitiseXMLString(procdef.customprocname([pno_showhidden, pno_noclassmarker])), '"');
+        Write(T, ' name="', SanitiseXMLString(procdef.customprocname([pno_showhidden, pno_noclassmarker])), '"');
 
         if po_hascallingconvention in procdef.procoptions then
           Write(T, ' convention="', proccalloptionStr[procdef.proccalloption], '"');
@@ -1365,7 +1365,7 @@
         PrintNodeIndent;
 
         if Assigned(procdef.returndef) and not is_void(procdef.returndef) then
-          WriteLn(T, PrintNodeIndention, '<returndef>', TNode.SanitiseXMLString(procdef.returndef.typesymbolprettyname), '</returndef>');
+          WriteLn(T, PrintNodeIndention, '<returndef>', SanitiseXMLString(procdef.returndef.typesymbolprettyname), '</returndef>');
 
         if po_reintroduce in procdef.procoptions then
           PrintOption('reintroduce');
@@ -2275,7 +2275,6 @@
            printproc( 'after parsing');
 
 {$ifdef DEBUG_NODE_XML}
-         printnodeindention := printnodespacing;
          XMLPrintProc;
 {$endif DEBUG_NODE_XML}
 
@@ -2716,6 +2715,8 @@
         WriteLn(T, '<?xml version="1.0" encoding="utf-8"?>');
         WriteLn(T, '<', RootName, ' name="', ModuleName, '">');
         Close(T);
+
+        printnodeindention := printnodespacing;
       end;
 
 
Index: compiler/verbose.pas
===================================================================
--- compiler/verbose.pas	(revision 44513)
+++ compiler/verbose.pas	(working copy)
@@ -119,7 +119,22 @@
     procedure DoneVerbose;
 
 
+    const
+      printnodespacing = '   ';
+    var
+      { indention used when writing a node tree to the screen }
+      printnodeindention : string;
 
+
+     { Node dumping support functions }
+     procedure printnodeindent; inline;
+     procedure printnodeunindent; inline;
+{$ifdef DEBUG_NODE_XML}
+     function SanitiseXMLString(const S: ansistring): ansistring;
+     function WritePointer(const P: Pointer): ansistring;
+     function WriteGUID(const GUID: TGUID): ansistring;
+{$endif DEBUG_NODE_XML}
+
 implementation
 
     uses
@@ -1019,6 +1034,336 @@
       end;
 
 
+    procedure printnodeindent; inline;
+      begin
+        printnodeindention:=printnodeindention+printnodespacing;
+      end;
+
+
+    procedure printnodeunindent; inline;
+      begin
+        delete(printnodeindention,1,length(printnodespacing));
+      end;
+
+    {$ifdef DEBUG_NODE_XML}
+    function 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;
+
+
+    function WriteGUID(const GUID: TGUID): ansistring;
+      var
+        i: Integer;
+      begin
+        Result := '{' + hexstr(GUID.D1, 8) + '-' + hexstr(GUID.D2, 4) + '-' + hexstr(GUID.D3, 4) + '-';
+        for i := 0 to 7 do
+          Result := Result + hexstr(GUID.D4[i], 2);
+
+        Result := Result + '}';
+      end;
+
+
+    function 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}
+
+
 initialization
   constexp.internalerrorproc:=@internalerror;
 finalization
xml-node-dump-refactor.patch (26,389 bytes)   
xml-node-dump-defs.patch (16,597 bytes)   
Index: compiler/pdecl.pas
===================================================================
--- compiler/pdecl.pas	(revision 44513)
+++ compiler/pdecl.pas	(working copy)
@@ -1158,6 +1158,11 @@
            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
Index: compiler/symdef.pas
===================================================================
--- compiler/symdef.pas	(revision 44513)
+++ compiler/symdef.pas	(working copy)
@@ -318,6 +318,10 @@
        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;
@@ -372,6 +376,10 @@
        end;
 
        trecorddef = class(tabstractrecorddef)
+{$ifdef DEBUG_NODE_XML}
+       protected
+          function XMLPrintType: ansistring; override;
+{$endif DEBUG_NODE_XML}
        public
           variantrecdesc : pvariantrecdesc;
           isunion       : boolean;
@@ -446,6 +454,12 @@
        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;
@@ -4822,7 +4836,93 @@
         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 := TRecordSymTable(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
 ***************************************************************************}
@@ -5151,6 +5251,12 @@
          GetTypeName:='<record type>'
       end;
 
+{$ifdef DEBUG_NODE_XML}
+    function TRecordDef.XMLPrintType: ansistring;
+      begin
+        Result := '&lt;record&gt;';
+      end;
+{$endif DEBUG_NODE_XML}
 
 {***************************************************************************
                        TABSTRACTPROCDEF
@@ -8206,7 +8312,54 @@
         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;
+
+        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
 ****************************************************************************}
Index: compiler/symsym.pas
===================================================================
--- compiler/symsym.pas	(revision 44513)
+++ compiler/symsym.pas	(working copy)
@@ -234,6 +234,10 @@
           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;
 
@@ -408,6 +412,10 @@
           { 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;
 
@@ -1901,6 +1909,15 @@
         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
@@ -2609,7 +2626,48 @@
         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>', WritePointer(Pointer(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
 ****************************************************************************}
Index: compiler/symtype.pas
===================================================================
--- compiler/symtype.pas	(revision 44513)
+++ compiler/symtype.pas	(working copy)
@@ -58,6 +58,12 @@
          { 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 @@
            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,7 +291,85 @@
           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
          inherited create;
@@ -461,6 +548,33 @@
           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)
 ****************************************************************************}
xml-node-dump-defs.patch (16,597 bytes)   

Issue History

Date Modified Username Field Change
2020-04-07 05:50 J. Gareth Moreton New Issue
2020-04-07 05:50 J. Gareth Moreton Status new => assigned
2020-04-07 05:50 J. Gareth Moreton Assigned To => Pierre Muller
2020-04-07 05:50 J. Gareth Moreton File Added: xml-node-dump-refactor.patch
2020-04-07 05:50 J. Gareth Moreton File Added: xml-node-dump-defs.patch
2020-04-07 05:51 J. Gareth Moreton Relationship added child of 0035017
2020-04-07 05:51 J. Gareth Moreton Tag Attached: compiler
2020-04-07 05:51 J. Gareth Moreton Tag Attached: debug
2020-04-07 05:51 J. Gareth Moreton Tag Attached: patch
2020-04-07 05:51 J. Gareth Moreton Tag Attached: XML
2020-04-07 05:52 J. Gareth Moreton Additional Information Updated View Revisions
2020-04-07 05:52 J. Gareth Moreton FPCTarget => -
2020-04-07 05:53 J. Gareth Moreton Additional Information Updated View Revisions
2020-04-07 05:54 J. Gareth Moreton Additional Information Updated View Revisions
2020-04-07 05:55 J. Gareth Moreton Priority normal => low
2020-04-07 05:55 J. Gareth Moreton Severity minor => feature
2020-04-07 05:55 J. Gareth Moreton Additional Information Updated View Revisions