paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-21 20:09:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* first fixes for published properties

Browse Source
This commit is contained in:
florian 1998-09-07 17:37:00 +00:00
parent 7a173df255
commit e7f5a26700
4 changed files with 71 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
compiler/pdecl.pas
View File

@ -1129,7 +1129,7 @@ unit pdecl;
begin
aktclass^.options:=aktclass^.options or oois_class;
if (cs_generate_rtti in aktmoduleswitches) or
if (cs_generate_rtti in aktlocalswitches) or
(assigned(aktclass^.childof) and
((aktclass^.childof^.options and oo_can_have_published)<>0)
) then
@ -1312,6 +1312,7 @@ unit pdecl;
testcurobject:=0;
curobjectname:='';
aktclass^.generate_rtti;
if (cs_smartlink in aktmoduleswitches) then
datasegment^.concat(new(pai_cut,init));
{ write extended info for classes }
@ -1335,7 +1336,7 @@ unit pdecl;
datasegment^.concat(new(pai_const,init_32bit(0)));
{ pointer to type info of published section }
datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(aktclass^.get_rtti_label)))));
datasegment^.concat(new(pai_const,init_symbol(strpnew(aktclass^.rtti_name))));
{ pointer to field table }
datasegment^.concat(new(pai_const,init_32bit(0)));
@ -1969,7 +1970,10 @@ unit pdecl;
end.
{
$Log$
Revision 1.48 1998-09-04 08:42:02 peter
Revision 1.49 1998-09-07 17:37:00 florian
* first fixes for published properties
Revision 1.48 1998/09/04 08:42:02 peter
* updated some error messages
Revision 1.47 1998/09/03 16:03:18 florian

55
compiler/symdef.inc
View File

@ -2422,6 +2422,23 @@
vmt_mangledname:='VMT_'+s1+'$_'+s2;
end;
function tobjectdef.rtti_name : string;
var
s1,s2:string;
begin
if owner^.name=nil then
s1:=''
else
s1:=owner^.name^;
if name=nil then
s2:=''
else
s2:=name^;
rtti_name:='RTTI_'+s1+'$_'+s2;
end;
function tobjectdef.isclass : boolean;
begin
isclass:=(options and oois_class)<>0;
@ -2636,7 +2653,12 @@
typvalue : byte;
begin
if sym^.typ=varsym then
if not(assigned(sym)) then
begin
rttilist^.concat(new(pai_const,init_32bit(1)));
typvalue:=3;
end
else if sym^.typ=varsym then
begin
rttilist^.concat(new(pai_const,init_32bit(
pvarsym(sym)^.address)));
@ -2666,7 +2688,14 @@
rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(ppropertysym(sym)^.proptype^.get_rtti_label)))));
writeproc(ppropertysym(sym)^.readaccesssym,ppropertysym(sym)^.readaccessdef,0);
writeproc(ppropertysym(sym)^.writeaccesssym,ppropertysym(sym)^.writeaccessdef,2);
writeproc(ppropertysym(sym)^.storedsym,ppropertysym(sym)^.storeddef,4);
{ isn't it stored ? }
if (ppropertysym(sym)^.options and ppo_stored)=0 then
begin
rttilist^.concat(new(pai_const,init_32bit(1)));
proctypesinfo:=proctypesinfo or (3 shl 4);
end
else
writeproc(ppropertysym(sym)^.storedsym,ppropertysym(sym)^.storeddef,4);
rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.index)));
rttilist^.concat(new(pai_const,init_32bit(ppropertysym(sym)^.default)));
rttilist^.concat(new(pai_const,init_16bit(count)));
@ -2680,16 +2709,27 @@
procedure generate_published_child_rtti(sym : psym);{$ifndef fpc}far;{$endif}
begin
if (sym^.typ=propertysym) and ((sym^.properties and sp_published)<>0) then
ppropertysym(sym)^.proptype^.get_rtti_label;
end;
procedure tobjectdef.write_child_rtti_data;
begin
if assigned(childof) then
childof^.get_rtti_label;
publicsyms^.foreach(generate_published_child_rtti);
end;
procedure tobjectdef.generate_rtti;
begin
has_rtti:=true;
getlabel(rtti_label);
write_child_rtti_data;
rttilist^.concat(new(pai_symbol,init_global(rtti_name)));
rttilist^.concat(new(pai_label,init(rtti_label)));
write_rtti_data;
end;
procedure tobjectdef.write_rtti_data;
begin
@ -2706,7 +2746,7 @@
rttilist^.concat(new(pai_const,init_symbol(strpnew(vmt_mangledname))));
{ write owner typeinfo }
if assigned(childof) then
if assigned(childof) and ((childof^.options and oo_can_have_published)<>0) then
rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(childof^.get_rtti_label)))))
else
rttilist^.concat(new(pai_const,init_32bit(0)));
@ -2751,7 +2791,10 @@
{
$Log$
Revision 1.35 1998-09-06 22:42:02 florian
Revision 1.36 1998-09-07 17:37:01 florian
* first fixes for published properties
Revision 1.35 1998/09/06 22:42:02 florian
+ rtti genreation for properties added
Revision 1.34 1998/09/04 18:15:02 peter

11
compiler/symsym.inc
View File

@ -523,7 +523,11 @@
writeaccessdef:=nil;
readaccesssym:=nil;
writeaccesssym:=nil;
index:=$0;
storedsym:=nil;
storeddef:=nil;
index:=0;
default:=0;
end;
destructor tpropertysym.done;
@ -1620,7 +1624,10 @@
{
$Log$
Revision 1.39 1998-09-05 22:11:02 florian
Revision 1.40 1998-09-07 17:37:04 florian
* first fixes for published properties
Revision 1.39 1998/09/05 22:11:02 florian
+ switch -vb
* while/repeat loops accept now also word/longbool conditions
* makebooltojump did an invalid ungetregister32, fixed

9
compiler/types.pas
View File

@ -147,8 +147,8 @@ unit types;
begin
if is_equal(def1^.retdef,def2^.retdef) and
equal_paras(def1^.para1,def2^.para1,false) and
((def1^.options and po_comptatibility_options)=
(def2^.options and po_comptatibility_options)) then
((def1^.options and po_compatibility_options)=
(def2^.options and po_compatibility_options)) then
proc_to_procvar_equal:=true
else
proc_to_procvar_equal:=false;
@ -902,7 +902,10 @@ unit types;
end.
{
$Log$
Revision 1.26 1998-09-04 12:24:31 florian
Revision 1.27 1998-09-07 17:37:07 florian
* first fixes for published properties
Revision 1.26 1998/09/04 12:24:31 florian
* bug0159 fixed
Revision 1.25 1998/09/04 09:06:36 florian