paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-11-03 01:09:40 +01:00
Code Issues Packages Projects Releases Wiki Activity

compiler: implement properties in records:

Browse Source 
- rename property_dec from pdecobj to struct_property_dec because pdecl also has property_dec and move it to interface to use by records + allow properties for records
  - use struct_property_dec in record parser
  - change structh type from objectdef to abstractrecorddef in read_property_dec to use by records
  - disallow stored and default modifiers for records because records are not used for streaming
  - fix misuse of search_sym_in_class for records in few places

git-svn-id: branches/paul/extended_records@16548 -
This commit is contained in:
paul 2010-12-11 08:42:26 +00:00
parent 69d3bb2ffc
commit 17815ce7a2
7 changed files with 58 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
compiler/dbgdwarf.pas
View File

@ -2675,7 +2675,7 @@ implementation
if not get_symlist_sym_offset(symlist,tosym,offset) then
exit;
if (tosym.owner.symtabletype<>objectsymtable) then
if not (tosym.owner.symtabletype in [objectsymtable,recordsymtable]) then
begin
if (tosym.typ=fieldvarsym) then
internalerror(2009031404);

21
compiler/pdecobj.pas
View File

@ -36,6 +36,7 @@ interface
function class_destructor_head:tprocdef;
function constructor_head:tprocdef;
function destructor_head:tprocdef;
procedure struct_property_dec(is_classproperty:boolean);
implementation
@ -111,22 +112,22 @@ implementation
end;
procedure property_dec(is_classproperty:boolean);
procedure struct_property_dec(is_classproperty:boolean);
var
p : tpropertysym;
begin
{ check for a class }
if not((is_class_or_interface_or_dispinterface(current_objectdef)) or
(not(m_tp7 in current_settings.modeswitches) and (is_object(current_objectdef)))) then
{ check for a class or record }
if not((is_class_or_interface_or_dispinterface(current_structdef) or is_record(current_structdef)) or
(not(m_tp7 in current_settings.modeswitches) and (is_object(current_structdef)))) then
Message(parser_e_syntax_error);
consume(_PROPERTY);
p:=read_property_dec(is_classproperty, current_objectdef);
p:=read_property_dec(is_classproperty,current_structdef);
consume(_SEMICOLON);
if try_to_consume(_DEFAULT) then
begin
if oo_has_default_property in current_objectdef.objectoptions then
if oo_has_default_property in current_structdef.objectoptions then
message(parser_e_only_one_default_property);
include(current_objectdef.objectoptions,oo_has_default_property);
include(current_structdef.objectoptions,oo_has_default_property);
include(p.propoptions,ppo_defaultproperty);
if not(ppo_hasparameters in p.propoptions) then
message(parser_e_property_need_paras);
@ -144,11 +145,11 @@ implementation
begin
if pattern='CURRENT' then
begin
if oo_has_enumerator_current in current_objectdef.objectoptions then
if oo_has_enumerator_current in current_structdef.objectoptions then
message(parser_e_only_one_enumerator_current);
if not p.propaccesslist[palt_read].empty then
begin
include(current_objectdef.objectoptions,oo_has_enumerator_current);
include(current_structdef.objectoptions,oo_has_enumerator_current);
include(p.propoptions,ppo_enumerator_current);
end
else
@ -764,7 +765,7 @@ implementation
end;
_PROPERTY :
begin
property_dec(is_classdef);
struct_property_dec(is_classdef);
fields_allowed:=false;
is_classdef:=false;
end;

24
compiler/pdecvar.pas
View File

@ -33,7 +33,7 @@ interface
tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class);
tvar_dec_options=set of tvar_dec_option;
function read_property_dec(is_classproperty:boolean;astruct:tobjectdef):tpropertysym;
function read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym;
procedure read_var_decls(options:Tvar_dec_options);
@ -66,7 +66,7 @@ implementation
;
function read_property_dec(is_classproperty:boolean;astruct:tobjectdef):tpropertysym;
function read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym;
{ convert a node tree to symlist and return the last
symbol }
@ -279,7 +279,7 @@ implementation
pt.free;
end
else
p.dispid:=astruct.get_next_dispid;
p.dispid:=tobjectdef(astruct).get_next_dispid;
end;
procedure add_index_parameter(var paranr: word; p: tpropertysym; readprocdef, writeprocdef, storedprocdef: tprocvardef);
@ -457,7 +457,10 @@ implementation
else
begin
{ do an property override }
overridden:=search_struct_member(astruct.childof,p.name);
if (astruct.typ=objectdef) then
overridden:=search_struct_member(tobjectdef(astruct).childof,p.name)
else
overridden:=nil;
if assigned(overridden) and
(overridden.typ=propertysym) and
not(is_dispinterface(astruct)) then
@ -585,7 +588,8 @@ implementation
else
parse_dispinterface(p);
if assigned(astruct) and not(is_dispinterface(astruct)) and not is_classproperty then
{ stored is not allowed for dispinterfaces, records or class properties }
if assigned(astruct) and not(is_dispinterface(astruct) or is_record(astruct)) and not is_classproperty then
begin
{ ppo_stored is default on for not overridden properties }
if not assigned(p.overriddenpropsym) then
@ -672,7 +676,7 @@ implementation
end;
end;
end;
if try_to_consume(_DEFAULT) then
if not is_record(astruct) and try_to_consume(_DEFAULT) then
begin
if not allow_default_property(p) then
begin
@ -713,7 +717,7 @@ implementation
pt.free;
end;
end
else if try_to_consume(_NODEFAULT) then
else if not is_record(astruct) and try_to_consume(_NODEFAULT) then
begin
p.default:=longint($80000000);
end;
@ -724,7 +728,7 @@ implementation
end;
*)
{ Parse possible "implements" keyword }
if try_to_consume(_IMPLEMENTS) then
if not is_record(astruct) and try_to_consume(_IMPLEMENTS) then
begin
single_type(def,false,false);
@ -782,9 +786,9 @@ implementation
exit;
end;
found:=false;
for i:=0 to astruct.ImplementedInterfaces.Count-1 do
for i:=0 to tobjectdef(astruct).ImplementedInterfaces.Count-1 do
begin
ImplIntf:=TImplementedInterface(astruct.ImplementedInterfaces[i]);
ImplIntf:=TImplementedInterface(tobjectdef(astruct).ImplementedInterfaces[i]);
if compare_defs(def,ImplIntf.IntfDef,nothingn)>=te_equal then
begin

10
compiler/pexpr.pas
View File

@ -1083,7 +1083,10 @@ implementation
if (sp_static in sym.symoptions) then
begin
static_name:=lower(sym.owner.name^)+'_'+sym.name;
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable);
if sym.owner.defowner.typ=objectdef then
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable)
else
searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
if assigned(sym) then
check_hints(sym,sym.symoptions,sym.deprecatedmsg);
p1.free;
@ -1134,7 +1137,10 @@ implementation
if (sp_static in sym.symoptions) then
begin
static_name:=lower(sym.owner.name^)+'_'+sym.name;
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable);
if sym.owner.defowner.typ=objectdef then
searchsym_in_class(tobjectdef(sym.owner.defowner),tobjectdef(sym.owner.defowner),static_name,sym,srsymtable)
else
searchsym_in_record(trecorddef(sym.owner.defowner),static_name,sym,srsymtable);
if assigned(sym) then
check_hints(sym,sym.symoptions,sym.deprecatedmsg);
p1.free;

2
compiler/ptype.pas
View File

@ -701,7 +701,7 @@ implementation
end;
_PROPERTY :
begin
property_dec(is_classdef);
struct_property_dec(is_classdef);
fields_allowed:=false;
is_classdef:=false;
end;

6
tests/test/terecs3.pp
View File

@ -23,5 +23,11 @@ begin
halt(5);
if F.F5 <> 6 then
halt(6);
F.P3 := 7;
if F.P3 <> 7 then
halt(7);
F.P5 := 8;
if F.P5 <> 8 then
halt(8);
WriteLn('ok');
end.

17
tests/test/terecs_u1.pp
View File

@ -23,6 +23,13 @@ type
F5: TBar;
function Test(n: TBar): TBar;
class function Test1(n: TBar): TBar;
procedure Set3(const Value: TBar);
class procedure Set5(const Value: TBar); static;
property P3: TBar read F3 write Set3;
class property P5: TBar read F5 write Set5;
class constructor Create;
class destructor Destroy;
end;
@ -49,4 +56,14 @@ begin
WriteLn('TFoo.Destroy');
end;
procedure TFoo.Set3(const Value: TBar);
begin
F3 := Value;
end;
class procedure TFoo.Set5(const Value: TBar); static;
begin
F5 := Value;
end;
end.