diff options
author | pierre <pierre@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2019-06-22 14:08:47 +0000 |
---|---|---|
committer | pierre <pierre@3ad0048d-3df7-0310-abae-a5850022a9f2> | 2019-06-22 14:08:47 +0000 |
commit | 61da10548ed95f0ea38c14a40c2e689046cfaeaa (patch) | |
tree | e3623c8378934f2a16edfc0572cb09a192620dae /compiler/ncon.pas | |
parent | 8a60d8514ae36728b6593f7feeb0ee4259534c05 (diff) | |
download | fpc-61da10548ed95f0ea38c14a40c2e689046cfaeaa.tar.gz |
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: https://svn.freepascal.org/svn/fpc/trunk@42271 3ad0048d-3df7-0310-abae-a5850022a9f2
Diffstat (limited to 'compiler/ncon.pas')
-rw-r--r-- | compiler/ncon.pas | 87 |
1 files changed, 87 insertions, 0 deletions
diff --git a/compiler/ncon.pas b/compiler/ncon.pas index 594d2f54a5..a2a62bcb40 100644 --- a/compiler/ncon.pas +++ b/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 *****************************************************************************} |