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

compiler:

Browse Source 
- implement class properties: properties which can access only static fields and static class methods
  - tests
  - fix a possibility to call an instance method from the class method

git-svn-id: trunk@14585 -
This commit is contained in:
paul 2010-01-09 18:37:54 +00:00
parent 5d87461507
commit 3ed4c58502
14 changed files with 726 additions and 551 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitattributes vendored
View File

@ -9222,6 +9222,9 @@ tests/test/tset7.pp svneol=native#text/plain
tests/test/tsetsize.pp svneol=native#text/plain
tests/test/tstack.pp svneol=native#text/plain
tests/test/tstatic1.pp svneol=native#text/pascal
tests/test/tstatic2.pp svneol=native#text/pascal
tests/test/tstatic3.pp svneol=native#text/pascal
tests/test/tstatic4.pp svneol=native#text/pascal
tests/test/tstprocv.pp svneol=native#text/plain
tests/test/tstring1.pp svneol=native#text/plain
tests/test/tstring10.pp svneol=native#text/plain

6
compiler/msg/errore.msg
View File

@ -366,7 +366,7 @@ scan_w_multiple_main_name_overrides=02086_W_Overriding name of "main" procedure
#
# Parser
#
# 03282 is the last used one
# 03284 is the last used one
#
% \section{Parser messages}
% This section lists all parser messages. The parser takes care of the
@ -514,7 +514,7 @@ parser_e_fail_only_in_constructor=03051_E_FAIL can be used in constructors only
parser_e_no_paras_for_destructor=03052_E_Destructors can't have parameters
% You are declaring a destructor with a parameter list. Destructor methods
% cannot have parameters.
parser_e_only_class_methods_via_class_ref=03053_E_Only class methods can be referred with class references
parser_e_only_class_members_via_class_ref=03053_E_Only class methods, class properties and class variables can be referred with class references
% This error occurs in a situation like the following:
% \begin{verbatim}
% Type :
@ -528,7 +528,7 @@ parser_e_only_class_methods_via_class_ref=03053_E_Only class methods can be refe
% \end{verbatim}
% \var{Free} is not a class method and hence cannot be called with a class
% reference.
parser_e_only_class_methods=03054_E_Only class methods can be accessed in class methods
parser_e_only_class_members=03054_E_Only class class methods, class properties and class variables can be accessed in class methods
% This is related to the previous error. You cannot call a method of an object
% from inside a class method. The following code would produce this error:
% \begin{verbatim}

6
compiler/msgidx.inc
View File

@ -151,8 +151,8 @@ const
parser_e_error_in_real=03050;
parser_e_fail_only_in_constructor=03051;
parser_e_no_paras_for_destructor=03052;
parser_e_only_class_methods_via_class_ref=03053;
parser_e_only_class_methods=03054;
parser_e_only_class_members_via_class_ref=03053;
parser_e_only_class_members=03054;
parser_e_case_mismatch=03055;
parser_e_illegal_symbol_exported=03056;
parser_w_should_use_override=03057;
@ -840,7 +840,7 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 55145;
MsgTxtSize = 55227;
MsgIdxMax : array[1..20] of longint=(
24,87,285,95,71,51,110,22,202,63,

973
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

8
compiler/ncal.pas
View File

@ -2771,6 +2771,14 @@ implementation
while assigned(hpt) and (hpt.nodetype in [subscriptn,vecn]) do
hpt:=tunarynode(hpt).left;
if ((hpt.nodetype=loadvmtaddrn) or
((hpt.nodetype=loadn) and assigned(tloadnode(hpt).resultdef) and (tloadnode(hpt).resultdef.typ=classrefdef))) and
not (procdefinition.proctypeoption=potype_constructor) and
not (po_classmethod in procdefinition.procoptions) and
not (po_staticmethod in procdefinition.procoptions) then
{ error: we are calling instance method from the class method/static method }
CGMessage(parser_e_only_class_members);
if (procdefinition.proctypeoption=potype_constructor) and
assigned(symtableproc) and
(symtableproc.symtabletype=withsymtable) and

6
compiler/pdecl.pas
View File

@ -41,7 +41,7 @@ interface
procedure types_dec;
procedure var_dec;
procedure threadvar_dec;
procedure property_dec;
procedure property_dec(is_classpropery: boolean);
procedure resourcestring_dec;
implementation
@ -642,7 +642,7 @@ implementation
end;
procedure property_dec;
procedure property_dec(is_classpropery: boolean);
var
old_block_type : tblock_type;
begin
@ -652,7 +652,7 @@ implementation
old_block_type:=block_type;
block_type:=bt_const;
repeat
read_property_dec(nil);
read_property_dec(is_classpropery, nil);
consume(_SEMICOLON);
until token<>_ID;
block_type:=old_block_type;

33
compiler/pdecobj.pas
View File

@ -82,7 +82,7 @@ implementation
end;
procedure property_dec;
procedure property_dec(is_classproperty:boolean);
var
p : tpropertysym;
begin
@ -91,7 +91,7 @@ implementation
(not(m_tp7 in current_settings.modeswitches) and (is_object(current_objectdef)))) then
Message(parser_e_syntax_error);
consume(_PROPERTY);
p:=read_property_dec(current_objectdef);
p:=read_property_dec(is_classproperty, current_objectdef);
consume(_SEMICOLON);
if try_to_consume(_DEFAULT) then
begin
@ -526,7 +526,7 @@ implementation
oldparse_only,
old_parse_generic : boolean;
object_member_blocktype : tblock_type;
fields_allowed: boolean;
fields_allowed, is_classdef: boolean;
begin
{ empty class declaration ? }
if (current_objectdef.objecttype in [odt_class,odt_objcclass]) and
@ -544,6 +544,7 @@ implementation
testcurobject:=1;
has_destructor:=false;
fields_allowed:=true;
is_classdef:=false;
object_member_blocktype:=bt_general;
repeat
case token of
@ -667,12 +668,29 @@ implementation
end;
_PROPERTY :
begin
property_dec;
property_dec(is_classdef);
fields_allowed:=false;
is_classdef:=false;
end;
_CLASS:
begin
is_classdef:=false;
{ read class method }
if try_to_consume(_CLASS) then
begin
{ class method only allowed for procedures and functions }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY]) then
Message(parser_e_procedure_or_function_expected);
if is_interface(current_objectdef) then
Message(parser_e_no_static_method_in_interfaces)
else
{ class methods are also allowed for Objective-C protocols }
is_classdef:=true;
end;
end;
_PROCEDURE,
_FUNCTION,
_CLASS :
_FUNCTION:
begin
if (current_objectdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_objectdef.objectoptions) then
@ -680,7 +698,7 @@ implementation
oldparse_only:=parse_only;
parse_only:=true;
pd:=parse_proc_dec(current_objectdef);
pd:=parse_proc_dec(is_classdef, current_objectdef);
{ this is for error recovery as well as forward }
{ interface mappings, i.e. mapping to a method }
@ -716,6 +734,7 @@ implementation
parse_only:=oldparse_only;
fields_allowed:=false;
is_classdef:=false;
end;
_CONSTRUCTOR :
begin

19
compiler/pdecsub.pas
View File

@ -60,7 +60,7 @@ interface
procedure parse_var_proc_directives(sym:tsym);
procedure parse_object_proc_directives(pd:tabstractprocdef);
function parse_proc_head(aclass:tobjectdef;potype:tproctypeoption;var pd:tprocdef):boolean;
function parse_proc_dec(aclass:tobjectdef):tprocdef;
function parse_proc_dec(isclassmethod:boolean; aclass:tobjectdef):tprocdef;
implementation
@ -948,30 +948,15 @@ implementation
end;
function parse_proc_dec(aclass:tobjectdef):tprocdef;
function parse_proc_dec(isclassmethod:boolean; aclass:tobjectdef):tprocdef;
var
pd : tprocdef;
isclassmethod : boolean;
locationstr: string;
old_parse_generic,
popclass : boolean;
begin
locationstr:='';
pd:=nil;
isclassmethod:=false;
{ read class method }
if try_to_consume(_CLASS) then
begin
{ class method only allowed for procedures and functions }
if not(token in [_FUNCTION,_PROCEDURE]) then
Message(parser_e_procedure_or_function_expected);
if is_interface(aclass) then
Message(parser_e_no_static_method_in_interfaces)
else
{ class methods are also allowed for Objective-C protocols }
isclassmethod:=true;
end;
case token of
_FUNCTION :
begin

20
compiler/pdecvar.pas
View File

@ -33,7 +33,7 @@ interface
tvar_dec_option=(vd_record,vd_object,vd_threadvar);
tvar_dec_options=set of tvar_dec_option;
function read_property_dec(aclass:tobjectdef):tpropertysym;
function read_property_dec(is_classproperty:boolean; aclass:tobjectdef):tpropertysym;
procedure read_var_decls(options:Tvar_dec_options);
@ -66,7 +66,7 @@ implementation
;
function read_property_dec(aclass:tobjectdef):tpropertysym;
function read_property_dec(is_classproperty:boolean; aclass:tobjectdef):tpropertysym;
{ convert a node tree to symlist and return the last
symbol }
@ -269,8 +269,8 @@ implementation
writeprocdef:=tprocvardef.create(normal_function_level);
storedprocdef:=tprocvardef.create(normal_function_level);
{ make it method pointers }
if assigned(aclass) then
{ make them method pointers }
if assigned(aclass) and not is_classproperty then
begin
include(readprocdef.procoptions,po_methodpointer);
include(writeprocdef.procoptions,po_methodpointer);
@ -290,6 +290,8 @@ implementation
p:=tpropertysym.create(orgpattern);
p.visibility:=symtablestack.top.currentvisibility;
p.default:=longint($80000000);
if is_classproperty then
include(p.symoptions, sp_static);
symtablestack.top.insert(p);
consume(_ID);
{ property parameters ? }
@ -461,8 +463,9 @@ implementation
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) then
Message(parser_e_ill_property_access_sym);
if (ppo_hasparameters in p.propoptions) or
((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
Message(parser_e_ill_property_access_sym);
end
else
IncompatibleTypes(def,p.propdef);
@ -505,7 +508,8 @@ implementation
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) then
if (ppo_hasparameters in p.propoptions) or
((sp_static in p.symoptions) <> (sp_static in sym.symoptions)) then
Message(parser_e_ill_property_access_sym);
end
else
@ -536,7 +540,7 @@ implementation
end;
end;
if assigned(aclass) and not(is_dispinterface(aclass)) then
if assigned(aclass) and not(is_dispinterface(aclass)) and not is_classproperty then
begin
{ ppo_stored is default on for not overriden properties }
if not assigned(p.overridenpropsym) then

68
compiler/pexpr.pas
View File

@ -1028,6 +1028,9 @@ implementation
membercall : boolean;
callflags : tcallnodeflags;
propaccesslist : tpropaccesslist;
static_name : shortstring;
sym: tsym;
srsymtable : tsymtable;
begin
{ property parameters? read them only if the property really }
{ has parameters }
@ -1052,7 +1055,8 @@ implementation
begin
if getpropaccesslist(propsym,palt_write,propaccesslist) then
begin
case propaccesslist.firstsym^.sym.typ of
sym:=propaccesslist.firstsym^.sym;
case sym.typ of
procsym :
begin
callflags:=[];
@ -1060,8 +1064,8 @@ implementation
membercall:=maybe_load_methodpointer(st,p1);
if membercall then
include(callflags,cnf_member_call);
p1:=ccallnode.create(paras,tprocsym(propaccesslist.firstsym^.sym),st,p1,callflags);
addsymref(propaccesslist.firstsym^.sym);
p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
addsymref(sym);
paras:=nil;
consume(_ASSIGNMENT);
{ read the expression }
@ -1078,7 +1082,19 @@ implementation
fieldvarsym :
begin
{ generate access code }
propaccesslist_to_node(p1,st,propaccesslist);
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 assigned(sym) then
check_hints(sym,sym.symoptions,sym.deprecatedmsg);
p1.free;
p1:=nil;
{ static syms are always stored as absolutevarsym to handle scope and storage properly }
propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
end
else
propaccesslist_to_node(p1,st,propaccesslist);
include(p1.flags,nf_isproperty);
consume(_ASSIGNMENT);
{ read the expression }
@ -1102,12 +1118,25 @@ implementation
begin
if getpropaccesslist(propsym,palt_read,propaccesslist) then
begin
case propaccesslist.firstsym^.sym.typ of
sym := propaccesslist.firstsym^.sym;
case sym.typ of
fieldvarsym :
begin
{ generate access code }
propaccesslist_to_node(p1,st,propaccesslist);
include(p1.flags,nf_isproperty);
{ generate access code }
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 assigned(sym) then
check_hints(sym,sym.symoptions,sym.deprecatedmsg);
p1.free;
p1:=nil;
{ static syms are always stored as absolutevarsym to handle scope and storage properly }
propaccesslist_to_node(p1,nil,tabsolutevarsym(sym).ref);
end
else
propaccesslist_to_node(p1,st,propaccesslist);
include(p1.flags,nf_isproperty);
end;
procsym :
begin
@ -1116,7 +1145,7 @@ implementation
membercall:=maybe_load_methodpointer(st,p1);
if membercall then
include(callflags,cnf_member_call);
p1:=ccallnode.create(paras,tprocsym(propaccesslist.firstsym^.sym),st,p1,callflags);
p1:=ccallnode.create(paras,tprocsym(sym),st,p1,callflags);
paras:=nil;
include(p1.flags,nf_isproperty);
end
@ -1184,7 +1213,7 @@ implementation
assigned(tcallnode(p1).procdefinition) and
not(po_classmethod in tcallnode(p1).procdefinition.procoptions) and
not(tcallnode(p1).procdefinition.proctypeoption=potype_constructor) then
Message(parser_e_only_class_methods_via_class_ref);
Message(parser_e_only_class_members_via_class_ref);
end;
fieldvarsym:
begin
@ -1203,17 +1232,20 @@ implementation
begin
if isclassref then
if assigned(p1) and
is_self_node(p1) then
Message(parser_e_only_class_methods)
(
is_self_node(p1) or
(assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions) and
(current_procinfo.procdef._class = classh))) then
Message(parser_e_only_class_members)
else
Message(parser_e_only_class_methods_via_class_ref);
Message(parser_e_only_class_members_via_class_ref);
p1:=csubscriptnode.create(sym,p1);
end;
end;
propertysym:
begin
if isclassref then
Message(parser_e_only_class_methods_via_class_ref);
if isclassref and not (sp_static in sym.symoptions) then
Message(parser_e_only_class_members_via_class_ref);
handle_propertysym(tpropertysym(sym),sym.owner,p1);
end;
typesym:
@ -1595,7 +1627,11 @@ implementation
if is_member_read(srsym,srsymtable,p1,hdef) then
begin
if (srsymtable.symtabletype=ObjectSymtable) then
p1:=load_self_node;
if (assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions)) then
{ no self node in static class methods }
p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
else
p1:=load_self_node;
{ not srsymtable.symtabletype since that can be }
{ withsymtable as well }
if (srsym.owner.symtabletype=ObjectSymtable) then

42
compiler/psub.pas
View File

@ -1545,7 +1545,7 @@ implementation
end;
procedure read_proc;
procedure read_proc(isclassmethod:boolean);
{
Parses the procedure directives, then parses the procedure body, then
generates the code for it
@ -1568,7 +1568,7 @@ implementation
current_objectdef:=nil;
{ parse procedure declaration }
pd:=parse_proc_dec(old_current_objectdef);
pd:=parse_proc_dec(isclassmethod, old_current_objectdef);
{ set the default function options }
if parse_only then
@ -1713,8 +1713,11 @@ implementation
procedure read_declarations(islibrary : boolean);
var
is_classdef:boolean;
begin
repeat
is_classdef:=false;
repeat
if not assigned(current_procinfo) then
internalerror(200304251);
case token of
@ -1728,13 +1731,31 @@ implementation
var_dec;
_THREADVAR:
threadvar_dec;
_CLASS:
begin
is_classdef:=false;
if try_to_consume(_CLASS) then
begin
{ class method only allowed for procedures and functions }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY]) then
Message(parser_e_procedure_or_function_expected);
if is_interface(current_objectdef) then
Message(parser_e_no_static_method_in_interfaces)
else
{ class methods are also allowed for Objective-C protocols }
is_classdef:=true;
end;
end;
_CONSTRUCTOR,
_DESTRUCTOR,
_FUNCTION,
_PROCEDURE,
_OPERATOR,
_CLASS:
read_proc;
_OPERATOR:
begin
read_proc(is_classdef);
is_classdef:=false;
end;
_EXPORTS:
begin
if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
@ -1766,7 +1787,10 @@ implementation
_PROPERTY:
begin
if (m_fpc in current_settings.modeswitches) then
property_dec
begin
property_dec(is_classdef);
is_classdef:=false;
end
else
break;
end;
@ -1799,7 +1823,7 @@ implementation
_FUNCTION,
_PROCEDURE,
_OPERATOR :
read_proc;
read_proc(false);
else
begin
case idtoken of
@ -1808,7 +1832,7 @@ implementation
_PROPERTY:
begin
if (m_fpc in current_settings.modeswitches) then
property_dec
property_dec(false)
else
break;
end;

34
tests/test/tstatic2.pp Normal file
View File

@ -0,0 +1,34 @@
program tstatic2;
{$APPTYPE console}
{$ifdef fpc}
{$mode delphi}{$H+}
{$endif}
type
TSomeClass = class
private
{$ifndef fpc}class var{$endif}FSomethingStatic: Integer; {$ifdef fpc}static;{$endif}
public
class procedure SetSomethingStatic(AValue: Integer); static;
class property SomethingStatic: Integer read FSomethingStatic write SetSomethingStatic;
end;
TAnotherClass = class(TSomeClass)
end;
{ TSomeClass }
class procedure TSomeClass.SetSomethingStatic(AValue: Integer);
begin
FSomethingStatic := AValue;
WriteLn('SomethingStatic:', SomethingStatic);
end;
begin
TSomeClass.SomethingStatic := 4;
if TSomeClass.SomethingStatic <> 4 then
halt(1);
TAnotherClass.SomethingStatic := 10;
if TSomeClass.SomethingStatic <> 10 then
halt(2); // outputs 10
end.

27
tests/test/tstatic3.pp Normal file
View File

@ -0,0 +1,27 @@
{ %FAIL}
program tstatic3;
{$APPTYPE console}
{$ifdef fpc}
{$mode delphi}{$H+}
{$endif}
type
TSomeClass = class
private
{$ifndef fpc}class var{$endif}FSomethingStatic: Integer;
{$ifndef fpc}var{$endif} FSomethingRegular: Integer;
class procedure SetSomethingStatic(AValue: Integer); static;
public
class property SomethingStatic: Integer read FSomethingStatic write SetSomethingStatic;
property SomethingRegular: Integer read FSomethingRegular write FSomethingRegular;
end;
{ TSomeClass }
class procedure TSomeClass.SetSomethingStatic(AValue: Integer);
begin
FSomethingRegular := AValue;
end;
begin
end.

32
tests/test/tstatic4.pp Normal file
View File

@ -0,0 +1,32 @@
{ %FAIL}
program tstatic4;
{$APPTYPE console}
{$ifdef fpc}
{$mode delphi}{$H+}
{$endif}
type
{ TSomeClass }
TSomeClass = class
public
class procedure StaticProc; static;
procedure RegularProc;
end;
{ TSomeClass }
procedure TSomeClass.RegularProc;
begin
end;
class procedure TSomeClass.StaticProc;
begin
RegularProc;
end;
begin
end.