diff --git a/compiler/psub.pas b/compiler/psub.pas
index b070099fc4..49836771a5 100644
--- a/compiler/psub.pas
+++ b/compiler/psub.pas
@@ -86,7 +86,7 @@ interface
function has_assembler_child : boolean;
procedure set_eh_info; override;
{$ifdef DEBUG_NODE_XML}
- procedure XMLPrintProc;
+ procedure XMLPrintProc(FirstHalf: Boolean);
{$endif DEBUG_NODE_XML}
end;
@@ -1437,15 +1437,19 @@ implementation
{$ifdef DEBUG_NODE_XML}
- procedure tcgprocinfo.XMLPrintProc;
+ procedure tcgprocinfo.XMLPrintProc(FirstHalf: Boolean);
var
T: Text;
W: Word;
syssym: tsyssym;
+ separate : boolean;
procedure PrintType(Flag: string);
begin
- Write(T, ' type="', Flag, '"');
+ if df_generic in procdef.defoptions then
+ Write(T, ' type="generic ', Flag, '"')
+ else
+ Write(T, ' type="', Flag, '"');
end;
procedure PrintOption(Flag: string);
@@ -1467,109 +1471,132 @@ implementation
Exit;
end;
{$pop}
- Write(T, PrintNodeIndention, '<subroutine');
- { Check to see if the procedure is a class or object method }
- if Assigned(procdef.struct) then
+ separate := (df_generic in procdef.defoptions);
+
+ { First half prints the header and the nodes as a "code" tag }
+ if FirstHalf or separate then
begin
- if Assigned(procdef.struct.objrealname) then
- Write(T, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
- else
- Write(T, ' struct="<NULL>"');
+ Write(T, PrintNodeIndention, '<subroutine');
+ { Check to see if the procedure is a class or object method }
+ if Assigned(procdef.struct) then
+ begin
+ if Assigned(procdef.struct.objrealname) then
+ Write(T, ' struct="', SanitiseXMLString(procdef.struct.objrealname^), '"')
+ else
+ Write(T, ' struct="<NULL>"');
+ end;
+ case procdef.proctypeoption of
+ potype_none:
+ { Do nothing - should this be an internal error though? };
+ potype_procedure,
+ potype_function:
+ if po_classmethod in procdef.procoptions then
+ begin
+ if po_staticmethod in procdef.procoptions then
+ PrintType('static class method')
+ else
+ PrintType('class method');
+ end
+ else if df_generic in procdef.defoptions then
+ Write(T, ' type="generic"');
+ potype_proginit,
+ potype_unitinit:
+ PrintType('initialization');
+ potype_unitfinalize:
+ PrintType('finalization');
+ potype_constructor:
+ PrintType('constructor');
+ potype_destructor:
+ PrintType('destructor');
+ potype_operator:
+ PrintType('operator');
+ potype_class_constructor:
+ PrintType('class constructor');
+ potype_class_destructor:
+ PrintType('class destructor');
+ potype_propgetter:
+ PrintType('dispinterface getter');
+ potype_propsetter:
+ PrintType('dispinterface setter');
+ potype_exceptfilter:
+ PrintType('except filter');
+ potype_mainstub:
+ PrintType('main stub');
+ potype_libmainstub:
+ PrintType('library main stub');
+ potype_pkgstub:
+ PrintType('package stub');
+ end;
+
+ Write(T, ' name="', SanitiseXMLString(procdef.customprocname([pno_showhidden, pno_noclassmarker])), '"');
+ if po_hascallingconvention in procdef.procoptions then
+ Write(T, ' convention="', proccalloptionStr[procdef.proccalloption], '"');
+ WriteLn(T, '>');
+
+ PrintNodeIndent;
+
+ if Assigned(procdef.returndef) and not is_void(procdef.returndef) then
+ WriteLn(T, PrintNodeIndention, '<returndef>', SanitiseXMLString(procdef.returndef.typesymbolprettyname), '</returndef>');
+
+ if po_reintroduce in procdef.procoptions then
+ PrintOption('reintroduce');
+ if po_virtualmethod in procdef.procoptions then
+ PrintOption('virtual');
+ if po_finalmethod in procdef.procoptions then
+ PrintOption('final');
+ if po_overridingmethod in procdef.procoptions then
+ PrintOption('override');
+ if po_overload in procdef.procoptions then
+ PrintOption('overload');
+ 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');
end;
- case procdef.proctypeoption of
- potype_none: { Do nothing };
+ if Assigned(Code) then
+ begin
+ if FirstHalf then
+ WriteLn(T, PrintNodeIndention, '<code>')
+ else
+ begin
+ WriteLn(T); { Line for spacing }
+ WriteLn(T, PrintNodeIndention, '<firstpass>');
+ end;
- potype_procedure,
- potype_function:
- if po_classmethod in procdef.procoptions then
- begin
- if po_staticmethod in procdef.procoptions then
- PrintType('static class method')
- else
- PrintType('class method');
- end;
- { Do nothing otherwise }
+ PrintNodeIndent;
+ XMLPrintNode(T, Code);
+ PrintNodeUnindent;
- potype_proginit,
- potype_unitinit:
- PrintType('initialization');
- potype_unitfinalize:
- PrintType('finalization');
- potype_constructor:
- PrintType('constructor');
- potype_destructor:
- PrintType('destructor');
- potype_operator:
- PrintType('operator');
- potype_class_constructor:
- PrintType('class constructor');
- potype_class_destructor:
- PrintType('class destructor');
- potype_propgetter:
- PrintType('dispinterface getter');
- potype_propsetter:
- PrintType('dispinterface setter');
- potype_exceptfilter:
- PrintType('except filter');
- potype_mainstub:
- PrintType('main stub');
- potype_libmainstub:
- PrintType('library main stub');
- potype_pkgstub:
- PrintType('package stub');
- end;
+ if FirstHalf then
+ WriteLn(T, PrintNodeIndention, '</code>')
+ else
+ WriteLn(T, PrintNodeIndention, '</firstpass>');
+ end
+ else { Code=Nil }
+ begin
+ { Don't print anything for second half - if there's no code, there's no firstpass }
+ if FirstHalf then
+ WriteLn(T, PrintNodeIndention, '<code />');
+ end;
- Write(T, ' name="', SanitiseXMLString(procdef.customprocname([pno_showhidden, pno_noclassmarker])), '"');
-
- if po_hascallingconvention in procdef.procoptions then
- Write(T, ' convention="', proccalloptionStr[procdef.proccalloption], '"');
-
- WriteLn(T, '>');
-
- PrintNodeIndent;
-
- if Assigned(procdef.returndef) and not is_void(procdef.returndef) then
- WriteLn(T, PrintNodeIndention, '<returndef>', SanitiseXMLString(procdef.returndef.typesymbolprettyname), '</returndef>');
-
- if po_reintroduce in procdef.procoptions then
- PrintOption('reintroduce');
- if po_virtualmethod in procdef.procoptions then
- PrintOption('virtual');
- if po_finalmethod in procdef.procoptions then
- PrintOption('final');
- if po_overridingmethod in procdef.procoptions then
- PrintOption('override');
- if po_overload in procdef.procoptions then
- PrintOption('overload');
- 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');
-
- if Assigned(Code) then
+ { Print footer only for second half }
+ if (not FirstHalf) or separate then
begin
- WriteLn(T, PrintNodeIndention, '<code>');
- PrintNodeIndent;
- XMLPrintNode(T, Code);
PrintNodeUnindent;
- WriteLn(T, PrintNodeIndention, '</code>');
- end
- else
- WriteLn(T, PrintNodeIndention, '<code />');
+ WriteLn(T, PrintNodeIndention, '</subroutine>');
+ WriteLn(T); { Line for spacing }
+ end;
- PrintNodeUnindent;
- WriteLn(T, PrintNodeIndention, '</subroutine>');
- WriteLn(T); { Line for spacing }
Close(T);
end;
{$endif DEBUG_NODE_XML}
@@ -1789,7 +1816,14 @@ implementation
don't need to generate anything. When it was an empty
procedure there would be at least a blocknode }
if not assigned(code) then
- exit;
+ begin
+{$ifdef DEBUG_NODE_XML}
+ { Print out nodes as they appear after the first pass }
+ XMLPrintProc(True);
+ XMLPrintProc(False);
+{$endif DEBUG_NODE_XML}
+ exit;
+ end;
{ We need valid code }
if Errorcount<>0 then
@@ -1883,6 +1917,10 @@ implementation
(procdef.proccalloption=pocall_safecall) then
include(flags, pi_needs_implicit_finally);
{$endif}
+{$ifdef DEBUG_NODE_XML}
+ { Print out nodes as they appear after the first pass }
+ XMLPrintProc(True);
+{$endif DEBUG_NODE_XML}
{ firstpass everything }
flowcontrol:=[];
do_firstpass(code);
@@ -1912,7 +1950,14 @@ implementation
do_optloadmodifystore(code);
{ only do secondpass if there are no errors }
- if (ErrorCount=0) then
+ if (ErrorCount<>0) then
+ begin
+{$ifdef DEBUG_NODE_XML}
+ { Print out nodes as they appear after the first pass }
+ XMLPrintProc(False);
+{$endif DEBUG_NODE_XML}
+ end
+ else
begin
create_hlcodegen;
@@ -1962,6 +2007,11 @@ implementation
if paraprintnodetree <> 0 then
printproc( 'right before code generation');
+{$ifdef DEBUG_NODE_XML}
+ { Print out nodes as they appear after the first pass }
+ XMLPrintProc(False);
+{$endif DEBUG_NODE_XML}
+
{ generate code for the node tree }
do_secondpass(code);
aktproccode.concatlist(current_asmdata.CurrAsmList);
@@ -2470,7 +2520,10 @@ implementation
printproc( 'after parsing');
{$ifdef DEBUG_NODE_XML}
- XMLPrintProc;
+ { Methods of generic classes don't get any code generated, so output
+ the node tree here }
+ if (df_generic in procdef.defoptions) then
+ XMLPrintProc(True);
{$endif DEBUG_NODE_XML}
{ ... remove symbol tables }