mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-14 14:59:32 +02:00
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 -
This commit is contained in:
pierre
parent
c22982383f
commit
243c967967
@ -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 }
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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
|
||||
*****************************************************************************}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
*****************************************************************************}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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('<', Result, X);
|
||||
end;
|
||||
Ord('>'):
|
||||
begin
|
||||
Delete(Result, X, 1);
|
||||
Insert('>', Result, X);
|
||||
end;
|
||||
Ord('&'):
|
||||
begin
|
||||
Delete(Result, X, 1);
|
||||
Insert('&', Result, X);
|
||||
end;
|
||||
Ord('"'):
|
||||
begin
|
||||
needs_quoting := True;
|
||||
Delete(Result, X, 1);
|
||||
Insert('"', 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 }
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user