mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-06-26 06:38:13 +02:00
445 lines
13 KiB
ObjectPascal
445 lines
13 KiB
ObjectPascal
{
|
|
$Id$
|
|
Copyright (c) 1998-2000 by Daniel Mantione,
|
|
and other members of the Free Pascal development team
|
|
|
|
Routines for the code generation of data structures
|
|
like VMT,Messages
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the terms of the GNU General Public License as published by
|
|
the Free Software Foundation; either version 2 of the License, or
|
|
(at your option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
|
****************************************************************************
|
|
}
|
|
unit hcgdata;
|
|
interface
|
|
|
|
uses
|
|
symtable,aasm,defs;
|
|
|
|
{ generates the message tables for a class }
|
|
function genstrmsgtab(_class : pobjectdef) : pasmlabel;
|
|
function genintmsgtab(_class : pobjectdef) : pasmlabel;
|
|
{ generates the method name table }
|
|
function genpublishedmethodstable(Aclass:Pobjectdef):Pasmlabel;
|
|
|
|
{ generates a VMT for _class }
|
|
procedure genvmt(list : paasmoutput;_class : pobjectdef);
|
|
|
|
{$ifdef WITHDMT}
|
|
{ generates a DMT for _class }
|
|
function gendmt(_class : pobjectdef) : pasmlabel;
|
|
{$endif WITHDMT}
|
|
|
|
implementation
|
|
|
|
uses
|
|
strings,cobjects,globtype,globals,verbose,
|
|
types,hcodegen,symbols,objects,xobjects;
|
|
|
|
|
|
{*****************************************************************************
|
|
Message
|
|
*****************************************************************************}
|
|
|
|
type
|
|
pprocdeftree = ^tprocdeftree;
|
|
tprocdeftree = record
|
|
p : pprocdef;
|
|
nl : pasmlabel;
|
|
l,r : pprocdeftree;
|
|
end;
|
|
|
|
var
|
|
root : pprocdeftree;
|
|
count : longint;
|
|
|
|
procedure insertstr(p : pprocdeftree;var at : pprocdeftree);
|
|
|
|
var
|
|
i : longint;
|
|
|
|
begin
|
|
if at=nil then
|
|
begin
|
|
at:=p;
|
|
inc(count);
|
|
end
|
|
else
|
|
begin
|
|
i:=strcomp(p^.p^.messageinf.str,at^.p^.messageinf.str);
|
|
if i<0 then
|
|
insertstr(p,at^.l)
|
|
else if i>0 then
|
|
insertstr(p,at^.r)
|
|
else
|
|
Message1(parser_e_duplicate_message_label,strpas(p^.p^.messageinf.str));
|
|
end;
|
|
end;
|
|
|
|
procedure disposeprocdeftree(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
disposeprocdeftree(p^.l);
|
|
if assigned(p^.r) then
|
|
disposeprocdeftree(p^.r);
|
|
dispose(p);
|
|
end;
|
|
|
|
procedure insertmsgstr(p:pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
|
|
|
|
procedure inserter(p:pointer);{$IFDEF TP}far;{$ENDIF}
|
|
|
|
var pt:Pprocdeftree;
|
|
|
|
begin
|
|
if po_msgstr in Pprocdef(p)^.options then
|
|
begin
|
|
new(pt);
|
|
pt^.p:=p;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertstr(pt,root);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if typeof(p^)=typeof(Tprocsym) then
|
|
Pprocsym(p)^.foreach(@inserter);
|
|
end;
|
|
|
|
procedure insertint(p : pprocdeftree;var at : pprocdeftree);
|
|
|
|
begin
|
|
if at=nil then
|
|
begin
|
|
at:=p;
|
|
inc(count);
|
|
end
|
|
else
|
|
begin
|
|
if p^.p^.messageinf.i<at^.p^.messageinf.i then
|
|
insertint(p,at^.l)
|
|
else if p^.p^.messageinf.i>at^.p^.messageinf.i then
|
|
insertint(p,at^.r)
|
|
else
|
|
Message1(parser_e_duplicate_message_label,tostr(p^.p^.messageinf.i));
|
|
end;
|
|
end;
|
|
|
|
procedure insertmsgint(p:pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
|
|
|
|
procedure inserter(p:pointer);{$IFDEF TP}far;{$ENDIF}
|
|
|
|
var pt:Pprocdeftree;
|
|
|
|
begin
|
|
if po_msgint in Pprocdef(p)^.options then
|
|
begin
|
|
new(pt);
|
|
pt^.p:=p;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertint(pt,root);
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if typeof(p^)=typeof(Tprocsym) then
|
|
Pprocsym(p)^.foreach(@inserter);
|
|
end;
|
|
|
|
procedure writenames(p : pprocdeftree);
|
|
|
|
begin
|
|
getdatalabel(p^.nl);
|
|
if assigned(p^.l) then
|
|
writenames(p^.l);
|
|
datasegment^.concat(new(pai_label,init(p^.nl)));
|
|
datasegment^.concat(new(pai_const,init_8bit(strlen(p^.p^.messageinf.str))));
|
|
datasegment^.concat(new(pai_string,init_pchar(p^.p^.messageinf.str)));
|
|
if assigned(p^.r) then
|
|
writenames(p^.r);
|
|
end;
|
|
|
|
procedure writestrentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writestrentry(p^.l);
|
|
|
|
{ write name label }
|
|
datasegment^.concat(new(pai_const_symbol,init(p^.nl)));
|
|
datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname)));
|
|
|
|
if assigned(p^.r) then
|
|
writestrentry(p^.r);
|
|
end;
|
|
|
|
function genstrmsgtab(_class : pobjectdef) : pasmlabel;
|
|
|
|
|
|
var
|
|
r : pasmlabel;
|
|
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
if _class^.privatesyms<>nil then
|
|
_class^.privatesyms^.foreach({$ifndef TP}@{$endif}insertmsgstr);
|
|
if _class^.privatesyms<>nil then
|
|
_class^.protectedsyms^.foreach({$ifndef TP}@{$endif}insertmsgstr);
|
|
if _class^.privatesyms<>nil then
|
|
_class^.publicsyms^.foreach({$ifndef TP}@{$endif}insertmsgstr);
|
|
|
|
{ write all names }
|
|
if assigned(root) then
|
|
writenames(root);
|
|
|
|
{ now start writing of the message string table }
|
|
getdatalabel(r);
|
|
datasegment^.concat(new(pai_label,init(r)));
|
|
genstrmsgtab:=r;
|
|
datasegment^.concat(new(pai_const,init_32bit(count)));
|
|
if assigned(root) then
|
|
begin
|
|
writestrentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
|
|
|
|
procedure writeintentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writeintentry(p^.l);
|
|
|
|
{ write name label }
|
|
datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
|
|
datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname)));
|
|
|
|
if assigned(p^.r) then
|
|
writeintentry(p^.r);
|
|
end;
|
|
|
|
function genintmsgtab(_class : pobjectdef) : pasmlabel;
|
|
|
|
var
|
|
r : pasmlabel;
|
|
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
if _class^.privatesyms<>nil then
|
|
_class^.privatesyms^.foreach({$ifndef TP}@{$endif}insertmsgint);
|
|
if _class^.privatesyms<>nil then
|
|
_class^.protectedsyms^.foreach({$ifndef TP}@{$endif}insertmsgint);
|
|
if _class^.privatesyms<>nil then
|
|
_class^.publicsyms^.foreach({$ifndef TP}@{$endif}insertmsgint);
|
|
|
|
{ now start writing of the message string table }
|
|
getdatalabel(r);
|
|
datasegment^.concat(new(pai_label,init(r)));
|
|
genintmsgtab:=r;
|
|
datasegment^.concat(new(pai_const,init_32bit(count)));
|
|
if assigned(root) then
|
|
begin
|
|
writeintentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
|
|
{$ifdef WITHDMT}
|
|
|
|
procedure insertdmtentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif FPC}
|
|
|
|
var
|
|
hp : pprocdef;
|
|
pt : pprocdeftree;
|
|
|
|
begin
|
|
if psym(p)^.typ=procsym then
|
|
begin
|
|
hp:=pprocsym(p)^.definition;
|
|
while assigned(hp) do
|
|
begin
|
|
if (po_msgint in hp^.procoptions) then
|
|
begin
|
|
new(pt);
|
|
pt^.p:=hp;
|
|
pt^.l:=nil;
|
|
pt^.r:=nil;
|
|
insertint(pt,root);
|
|
end;
|
|
hp:=hp^.nextoverloaded;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure writedmtindexentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writedmtindexentry(p^.l);
|
|
datasegment^.concat(new(pai_const,init_32bit(p^.p^.messageinf.i)));
|
|
if assigned(p^.r) then
|
|
writedmtindexentry(p^.r);
|
|
end;
|
|
|
|
procedure writedmtaddressentry(p : pprocdeftree);
|
|
|
|
begin
|
|
if assigned(p^.l) then
|
|
writedmtaddressentry(p^.l);
|
|
datasegment^.concat(new(pai_const_symbol,initname(p^.p^.mangledname)));
|
|
if assigned(p^.r) then
|
|
writedmtaddressentry(p^.r);
|
|
end;
|
|
|
|
function gendmt(_class : pobjectdef) : pasmlabel;
|
|
|
|
var
|
|
r : pasmlabel;
|
|
|
|
begin
|
|
root:=nil;
|
|
count:=0;
|
|
gendmt:=nil;
|
|
{ insert all message handlers into a tree, sorted by number }
|
|
_class^.symtable^.foreach({$ifndef TP}@{$endif}insertdmtentry);
|
|
|
|
if count>0 then
|
|
begin
|
|
getdatalabel(r);
|
|
gendmt:=r;
|
|
datasegment^.concat(new(pai_label,init(r)));
|
|
{ entries for caching }
|
|
datasegment^.concat(new(pai_const,init_32bit(0)));
|
|
datasegment^.concat(new(pai_const,init_32bit(0)));
|
|
|
|
datasegment^.concat(new(pai_const,init_32bit(count)));
|
|
if assigned(root) then
|
|
begin
|
|
writedmtindexentry(root);
|
|
writedmtaddressentry(root);
|
|
disposeprocdeftree(root);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{$endif WITHDMT}
|
|
|
|
procedure genpubmethodtableentry(p : pnamedindexobject);{$ifndef FPC}far;{$endif}
|
|
|
|
procedure do_concat(q:pointer);{$ifndef FPC}far;{$endif}
|
|
|
|
var l:Pasmlabel;
|
|
|
|
begin
|
|
if (sp_published in Pprocsym(p)^.objprop) then
|
|
begin
|
|
getlabel(l);
|
|
|
|
consts^.concat(new(pai_label,init(l)));
|
|
consts^.concat(new(pai_const,init_8bit(length(p^.name))));
|
|
consts^.concat(new(pai_string,init(p^.name)));
|
|
|
|
datasegment^.concat(new(pai_const_symbol,init(l)));
|
|
datasegment^.concat(new(pai_const_symbol,initname(Pprocdef(q)^.mangledname)));
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
if p^.is_object(typeof(Tprocsym)) then
|
|
Pprocsym(p)^.foreach(@do_concat);
|
|
end;
|
|
|
|
procedure sym_do_count(p:Pnamedindexobject);{$ifndef FPC}far;{$endif}
|
|
|
|
procedure def_do_count(p:pointer);{$ifndef FPC}far;{$endif}
|
|
|
|
begin
|
|
if (sp_published in Pprocsym(p)^.objprop) then
|
|
inc(count);
|
|
end;
|
|
|
|
begin
|
|
if Pobject(p)^.is_object(typeof(Tprocsym)) then
|
|
Pprocsym(p)^.foreach(@def_do_count);
|
|
end;
|
|
|
|
function genpublishedmethodstable(Aclass:Pobjectdef):Pasmlabel;
|
|
|
|
var l:Pasmlabel;
|
|
|
|
begin
|
|
count:=0;
|
|
if Aclass^.privatesyms<>nil then
|
|
Aclass^.privatesyms^.foreach({$ifndef TP}@{$endif}sym_do_count);
|
|
if Aclass^.protectedsyms<>nil then
|
|
Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}sym_do_count);
|
|
if Aclass^.publicsyms<>nil then
|
|
Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}sym_do_count);
|
|
if count>0 then
|
|
begin
|
|
getlabel(l);
|
|
datasegment^.concat(new(pai_label,init(l)));
|
|
datasegment^.concat(new(pai_const,init_32bit(count)));
|
|
if Aclass^.privatesyms<>nil then
|
|
Aclass^.privatesyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry);
|
|
if Aclass^.protectedsyms<>nil then
|
|
Aclass^.protectedsyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry);
|
|
if Aclass^.publicsyms<>nil then
|
|
Aclass^.publicsyms^.foreach({$ifndef TP}@{$endif}genpubmethodtableentry);
|
|
genpublishedmethodstable:=l;
|
|
end
|
|
else
|
|
genpublishedmethodstable:=nil;
|
|
end;
|
|
|
|
{*****************************************************************************
|
|
VMT
|
|
*****************************************************************************}
|
|
|
|
|
|
procedure genvmt(list:Paasmoutput;_class:Pobjectdef);
|
|
|
|
var i:longint;
|
|
|
|
begin
|
|
for i:=0 to _class^.vmt_layout^.count-1 do
|
|
list^.concat(new(pai_const_symbol,
|
|
initname(Pvmtentry(_class^.vmt_layout^.at(i))^.mangledname)));
|
|
end;
|
|
|
|
|
|
end.
|
|
{
|
|
$Log$
|
|
Revision 1.1 2000-07-13 06:30:13 michael
|
|
+ Initial import
|
|
|
|
Revision 1.2 2000/03/16 12:52:48 daniel
|
|
* Changed names of procedures flags
|
|
* Changed VMT generation
|
|
|
|
Revision 1.1 2000/03/11 21:11:25 daniel
|
|
* Ported hcgdata to new symtable.
|
|
* Alignment code changed as suggested by Peter
|
|
+ Usage of my is operator replacement, is_object
|
|
|
|
}
|