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

compiler: start implementation of class constructors/destructors: parsing is ready but at the moment neither class constructors nor destructors are called - this is to be implemented

Browse Source 
git-svn-id: trunk@15109 -
This commit is contained in:
paul 2010-04-03 09:14:12 +00:00
parent e20f907b5c
commit 24d8a7d833
14 changed files with 411 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
compiler/msg/errore.msg
View File

@ -368,7 +368,7 @@ scanner_w_illegal_warn_identifier=02087_W_Illegal identifier "$1" for $WARN dire
# #
# Parser # Parser
# #
# 03287 is the last used one # 03291 is the last used one
# #
% \section{Parser messages} % \section{Parser messages}
% This section lists all parser messages. The parser takes care of the % This section lists all parser messages. The parser takes care of the
@ -1296,6 +1296,16 @@ parser_e_string_const_too_long=03286_E_String constant too long while ansistring
parser_e_invalid_univ_para=03287_E_Type cannot be used as univ parameter because its size is unknown at compile time: "$1" parser_e_invalid_univ_para=03287_E_Type cannot be used as univ parameter because its size is unknown at compile time: "$1"
% \var{univ} parameters are compatible with all values of the same size, but this % \var{univ} parameters are compatible with all values of the same size, but this
% cannot be checked in case a parameter's size is unknown at compile time. % cannot be checked in case a parameter's size is unknown at compile time.
parser_e_only_one_class_constructor_allowed=03288_E_Only one class constructor can be declared in class: "$1"
% You are trying to declare more than one class constructor but only one class constructor can be declared.
parser_e_only_one_class_destructor_allowed=03289_E_Only one class destructor can be declared in class: "$1"
% You are trying to declare more than one class destructor but only one class destructor can be declared.
parser_e_no_paras_for_class_constructor=03290_E_Class constructors can't have parameters
% You are declaring a class constructor with a parameter list. Class constructor methods
% cannot have parameters.
parser_e_no_paras_for_class_destructor=03291_E_Class destructors can't have parameters
% You are declaring a class destructor with a parameter list. Class destructor methods
% cannot have parameters.
% \end{description} % \end{description}
# #
# Type Checking # Type Checking

8
compiler/msgidx.inc
View File

@ -376,6 +376,10 @@ const
parser_e_more_array_elements_expected=03285; parser_e_more_array_elements_expected=03285;
parser_e_string_const_too_long=03286; parser_e_string_const_too_long=03286;
parser_e_invalid_univ_para=03287; parser_e_invalid_univ_para=03287;
parser_e_only_one_class_constructor_allowed=03288;
parser_e_only_one_class_destructor_allowed=03289;
parser_e_no_paras_for_class_constructor=03290;
parser_e_no_paras_for_class_destructor=03291;
type_e_mismatch=04000; type_e_mismatch=04000;
type_e_incompatible_types=04001; type_e_incompatible_types=04001;
type_e_not_equal_types=04002; type_e_not_equal_types=04002;
@ -854,9 +858,9 @@ const
option_info=11024; option_info=11024;
option_help_pages=11025; option_help_pages=11025;
MsgTxtSize = 56081; MsgTxtSize = 56309;
MsgIdxMax : array[1..20] of longint=( MsgIdxMax : array[1..20] of longint=(
24,88,288,96,80,51,110,22,202,63, 24,88,292,96,80,51,110,22,202,63,
49,20,1,1,1,1,1,1,1,1 49,20,1,1,1,1,1,1,1,1
); );

383
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

2
compiler/ncal.pas
View File

@ -2890,7 +2890,7 @@ implementation
{ When this is method the methodpointer must be available } { When this is method the methodpointer must be available }
if (right=nil) and if (right=nil) and
(procdefinition.owner.symtabletype=ObjectSymtable) and (procdefinition.owner.symtabletype=ObjectSymtable) and
not([po_staticmethod,po_classmethod] <= procdefinition.procoptions) then not procdefinition.no_self_node then
internalerror(200305061); internalerror(200305061);
end; end;

2
compiler/ncgrtti.pas
View File

@ -705,6 +705,8 @@ implementation
case def.proctypeoption of case def.proctypeoption of
potype_constructor: methodkind:=mkConstructor; potype_constructor: methodkind:=mkConstructor;
potype_destructor: methodkind:=mkDestructor; potype_destructor: methodkind:=mkDestructor;
potype_class_constructor: methodkind:=mkClassConstructor;
potype_class_destructor: methodkind:=mkClassDestructor;
potype_procedure: potype_procedure:
if po_classmethod in def.procoptions then if po_classmethod in def.procoptions then
methodkind:=mkClassProcedure methodkind:=mkClassProcedure

83
compiler/pdecobj.pas
View File

@ -50,6 +50,29 @@ implementation
current_procinfo = 'error'; current_procinfo = 'error';
function class_constructor_head:tprocdef;
var
pd : tprocdef;
begin
result:=nil;
consume(_CONSTRUCTOR);
{ must be at same level as in implementation }
parse_proc_head(current_objectdef,potype_class_constructor,pd);
if not assigned(pd) then
begin
consume(_SEMICOLON);
exit;
end;
pd.calcparas;
if (pd.maxparacount>0) then
Message(parser_e_no_paras_for_class_constructor);
consume(_SEMICOLON);
include(current_objectdef.objectoptions,oo_has_class_constructor);
{ no return value }
pd.returndef:=voidtype;
result:=pd;
end;
function constructor_head:tprocdef; function constructor_head:tprocdef;
var var
pd : tprocdef; pd : tprocdef;
@ -140,6 +163,28 @@ implementation
end; end;
function class_destructor_head:tprocdef;
var
pd : tprocdef;
begin
result:=nil;
consume(_DESTRUCTOR);
parse_proc_head(current_objectdef,potype_class_destructor,pd);
if not assigned(pd) then
begin
consume(_SEMICOLON);
exit;
end;
pd.calcparas;
if (pd.maxparacount>0) then
Message(parser_e_no_paras_for_class_destructor);
consume(_SEMICOLON);
include(current_objectdef.objectoptions,oo_has_class_destructor);
{ no return value }
pd.returndef:=voidtype;
result:=pd;
end;
function destructor_head:tprocdef; function destructor_head:tprocdef;
var var
pd : tprocdef; pd : tprocdef;
@ -155,6 +200,7 @@ implementation
if (cs_constructor_name in current_settings.globalswitches) and if (cs_constructor_name in current_settings.globalswitches) and
(pd.procsym.name<>'DONE') then (pd.procsym.name<>'DONE') then
Message(parser_e_destructorname_must_be_done); Message(parser_e_destructorname_must_be_done);
pd.calcparas;
if not(pd.maxparacount=0) and if not(pd.maxparacount=0) and
(m_fpc in current_settings.modeswitches) then (m_fpc in current_settings.modeswitches) then
Message(parser_e_no_paras_for_destructor); Message(parser_e_no_paras_for_destructor);
@ -702,8 +748,9 @@ implementation
{ read class method } { read class method }
if try_to_consume(_CLASS) then if try_to_consume(_CLASS) then
begin begin
{ class method only allowed for procedures and functions } { class modifier is only allowed for procedures, functions, }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR]) then { constructors, destructors, fields and properties }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR]) then
Message(parser_e_procedure_or_function_expected); Message(parser_e_procedure_or_function_expected);
if is_interface(current_objectdef) then if is_interface(current_objectdef) then
@ -773,7 +820,7 @@ implementation
not(oo_can_have_published in current_objectdef.objectoptions) then not(oo_can_have_published in current_objectdef.objectoptions) then
Message(parser_e_cant_have_published); Message(parser_e_cant_have_published);
if not(current_objectdef.symtable.currentvisibility in [vis_public,vis_published]) then if not is_classdef and not(current_objectdef.symtable.currentvisibility in [vis_public,vis_published]) then
Message(parser_w_constructor_should_be_public); Message(parser_w_constructor_should_be_public);
if is_interface(current_objectdef) then if is_interface(current_objectdef) then
@ -783,9 +830,16 @@ implementation
if is_objc_class_or_protocol(current_objectdef) then if is_objc_class_or_protocol(current_objectdef) then
Message(parser_e_objc_no_constructor_destructor); Message(parser_e_objc_no_constructor_destructor);
{ only 1 class constructor is allowed }
if is_classdef and (oo_has_class_constructor in current_objectdef.objectoptions) then
Message1(parser_e_only_one_class_constructor_allowed, current_objectdef.objrealname^);
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
pd:=constructor_head; if is_classdef then
pd:=class_constructor_head
else
pd:=constructor_head;
parse_object_proc_directives(pd); parse_object_proc_directives(pd);
handle_calling_convention(pd); handle_calling_convention(pd);
@ -800,6 +854,7 @@ implementation
parse_only:=oldparse_only; parse_only:=oldparse_only;
fields_allowed:=false; fields_allowed:=false;
is_classdef:=false;
end; end;
_DESTRUCTOR : _DESTRUCTOR :
begin begin
@ -807,23 +862,32 @@ implementation
not(oo_can_have_published in current_objectdef.objectoptions) then not(oo_can_have_published in current_objectdef.objectoptions) then
Message(parser_e_cant_have_published); Message(parser_e_cant_have_published);
if has_destructor then if not is_classdef then
Message(parser_n_only_one_destructor); if has_destructor then
has_destructor:=true; Message(parser_n_only_one_destructor)
else
has_destructor:=true;
if is_interface(current_objectdef) then if is_interface(current_objectdef) then
Message(parser_e_no_con_des_in_interfaces); Message(parser_e_no_con_des_in_interfaces);
if (current_objectdef.symtable.currentvisibility<>vis_public) then if not is_classdef and (current_objectdef.symtable.currentvisibility<>vis_public) then
Message(parser_w_destructor_should_be_public); Message(parser_w_destructor_should_be_public);
{ Objective-C does not know the concept of a destructor } { Objective-C does not know the concept of a destructor }
if is_objc_class_or_protocol(current_objectdef) then if is_objc_class_or_protocol(current_objectdef) then
Message(parser_e_objc_no_constructor_destructor); Message(parser_e_objc_no_constructor_destructor);
{ only 1 class destructor is allowed }
if is_classdef and (oo_has_class_destructor in current_objectdef.objectoptions) then
Message1(parser_e_only_one_class_destructor_allowed, current_objectdef.objrealname^);
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
pd:=destructor_head; if is_classdef then
pd:=class_destructor_head
else
pd:=destructor_head;
parse_object_proc_directives(pd); parse_object_proc_directives(pd);
handle_calling_convention(pd); handle_calling_convention(pd);
@ -839,6 +903,7 @@ implementation
parse_only:=oldparse_only; parse_only:=oldparse_only;
fields_allowed:=false; fields_allowed:=false;
is_classdef:=false;
end; end;
_END : _END :
begin begin

93
compiler/pdecsub.pas
View File

@ -202,8 +202,7 @@ implementation
(pd.parast.symtablelevel=normal_function_level) then (pd.parast.symtablelevel=normal_function_level) then
begin begin
{ static class methods have no hidden self/vmt pointer } { static class methods have no hidden self/vmt pointer }
if (po_staticmethod in pd.procoptions) and if pd.no_self_node then
(po_classmethod in pd.procoptions) then
exit; exit;
storepos:=current_tokenpos; storepos:=current_tokenpos;
@ -722,7 +721,7 @@ implementation
pd:=nil; pd:=nil;
aprocsym:=nil; aprocsym:=nil;
if (potype=potype_operator) then if potype=potype_operator then
begin begin
sp:=overloaded_names[optoken]; sp:=overloaded_names[optoken];
orgsp:=sp; orgsp:=sp;
@ -800,6 +799,8 @@ implementation
(ttypesym(srsym).typedef.typ=objectdef) then (ttypesym(srsym).typedef.typ=objectdef) then
begin begin
aclass:=tobjectdef(ttypesym(srsym).typedef); aclass:=tobjectdef(ttypesym(srsym).typedef);
if (token<>_POINT) and (potype in [potype_class_constructor,potype_class_destructor]) then
sp := lower(sp);
srsym:=tsym(aclass.symtable.Find(sp)); srsym:=tsym(aclass.symtable.Find(sp));
if assigned(srsym) then if assigned(srsym) then
begin begin
@ -839,7 +840,8 @@ implementation
begin begin
{ check for constructor/destructor which is not allowed here } { check for constructor/destructor which is not allowed here }
if (not parse_only) and if (not parse_only) and
(potype in [potype_constructor,potype_destructor]) then (potype in [potype_constructor,potype_destructor,
potype_class_constructor,potype_class_destructor]) then
Message(parser_e_constructors_always_objects); Message(parser_e_constructors_always_objects);
repeat repeat
@ -897,13 +899,16 @@ implementation
operation } operation }
if (potype=potype_operator) then if (potype=potype_operator) then
begin begin
Aprocsym:=Tprocsym(symtablestack.top.Find(sp)); aprocsym:=Tprocsym(symtablestack.top.Find(sp));
if Aprocsym=nil then if aprocsym=nil then
Aprocsym:=tprocsym.create('$'+sp); aprocsym:=tprocsym.create('$'+sp);
end end
else else
if (potype in [potype_class_constructor,potype_class_destructor]) then
aprocsym:=tprocsym.create('$'+lower(sp))
else
aprocsym:=tprocsym.create(orgsp); aprocsym:=tprocsym.create(orgsp);
symtablestack.top.insert(aprocsym); symtablestack.top.insert(aprocsym);
end; end;
{ to get the correct symtablelevel we must ignore ObjectSymtables } { to get the correct symtablelevel we must ignore ObjectSymtables }
@ -1105,8 +1110,12 @@ implementation
_CONSTRUCTOR : _CONSTRUCTOR :
begin begin
consume(_CONSTRUCTOR); consume(_CONSTRUCTOR);
parse_proc_head(aclass,potype_constructor,pd); if isclassmethod then
if assigned(pd) and parse_proc_head(aclass,potype_class_constructor,pd)
else
parse_proc_head(aclass,potype_constructor,pd);
if not isclassmethod and
assigned(pd) and
assigned(pd._class) then assigned(pd._class) then
begin begin
{ Set return type, class constructors return the { Set return type, class constructors return the
@ -1119,13 +1128,18 @@ implementation
{$else CPU64bitaddr} {$else CPU64bitaddr}
pd.returndef:=bool32type; pd.returndef:=bool32type;
{$endif CPU64bitaddr} {$endif CPU64bitaddr}
end; end
else
pd.returndef:=voidtype;
end; end;
_DESTRUCTOR : _DESTRUCTOR :
begin begin
consume(_DESTRUCTOR); consume(_DESTRUCTOR);
parse_proc_head(aclass,potype_destructor,pd); if isclassmethod then
parse_proc_head(aclass,potype_class_destructor,pd)
else
parse_proc_head(aclass,potype_destructor,pd);
if assigned(pd) then if assigned(pd) then
pd.returndef:=voidtype; pd.returndef:=voidtype;
end; end;
@ -1849,7 +1863,7 @@ const
pocall : pocall_cdecl; pocall : pocall_cdecl;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_assembler,po_external] mutexclpo : [po_assembler,po_external]
),( ),(
idtok:_CDECL; idtok:_CDECL;
@ -1858,7 +1872,7 @@ const
pocall : pocall_cdecl; pocall : pocall_cdecl;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_assembler,po_external] mutexclpo : [po_assembler,po_external]
),( ),(
idtok:_DISPID; idtok:_DISPID;
@ -1867,7 +1881,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : [po_dispid]; pooption : [po_dispid];
mutexclpocall : [pocall_internproc]; mutexclpocall : [pocall_internproc];
mutexclpotype : [potype_constructor,potype_destructor,potype_operator]; mutexclpotype : [potype_constructor,potype_destructor,potype_operator,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_interrupt,po_external,po_inline] mutexclpo : [po_interrupt,po_external,po_inline]
),( ),(
idtok:_DYNAMIC; idtok:_DYNAMIC;
@ -1876,7 +1890,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : [po_virtualmethod]; pooption : [po_virtualmethod];
mutexclpocall : [pocall_internproc]; mutexclpocall : [pocall_internproc];
mutexclpotype : []; mutexclpotype : [potype_class_constructor,potype_class_destructor];
mutexclpo : [po_exports,po_interrupt,po_external,po_overridingmethod,po_inline] mutexclpo : [po_exports,po_interrupt,po_external,po_overridingmethod,po_inline]
),( ),(
idtok:_EXPORT; idtok:_EXPORT;
@ -1885,7 +1899,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : [po_exports,po_global]; pooption : [po_exports,po_global];
mutexclpocall : [pocall_internproc]; mutexclpocall : [pocall_internproc];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external,po_interrupt,po_inline] mutexclpo : [po_external,po_interrupt,po_inline]
),( ),(
idtok:_EXTERNAL; idtok:_EXTERNAL;
@ -1895,7 +1909,7 @@ const
pooption : [po_external]; pooption : [po_external];
mutexclpocall : [pocall_internproc,pocall_syscall]; mutexclpocall : [pocall_internproc,pocall_syscall];
{ allowed for external cpp classes } { allowed for external cpp classes }
mutexclpotype : [{potype_constructor,potype_destructor}]; mutexclpotype : [{potype_constructor,potype_destructor}potype_class_constructor,potype_class_destructor];
mutexclpo : [po_public,po_exports,po_interrupt,po_assembler,po_inline] mutexclpo : [po_public,po_exports,po_interrupt,po_assembler,po_inline]
),( ),(
idtok:_FAR; idtok:_FAR;
@ -1949,7 +1963,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : [po_inline]; pooption : [po_inline];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_exports,po_external,po_interrupt,po_virtualmethod] mutexclpo : [po_exports,po_external,po_interrupt,po_virtualmethod]
),( ),(
idtok:_INTERNCONST; idtok:_INTERNCONST;
@ -1967,7 +1981,7 @@ const
pocall : pocall_internproc; pocall : pocall_internproc;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor,potype_operator]; mutexclpotype : [potype_constructor,potype_destructor,potype_operator,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck,po_virtualmethod] mutexclpo : [po_exports,po_external,po_interrupt,po_assembler,po_iocheck,po_virtualmethod]
),( ),(
idtok:_INTERRUPT; idtok:_INTERRUPT;
@ -1977,7 +1991,7 @@ const
pooption : [po_interrupt]; pooption : [po_interrupt];
mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_cppdecl,pocall_stdcall, mutexclpocall : [pocall_internproc,pocall_cdecl,pocall_cppdecl,pocall_stdcall,
pocall_pascal,pocall_far16,pocall_oldfpccall]; pocall_pascal,pocall_far16,pocall_oldfpccall];
mutexclpotype : [potype_constructor,potype_destructor,potype_operator]; mutexclpotype : [potype_constructor,potype_destructor,potype_operator,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external,po_inline] mutexclpo : [po_external,po_inline]
),( ),(
idtok:_IOCHECK; idtok:_IOCHECK;
@ -2004,7 +2018,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : []; { can be po_msgstr or po_msgint } pooption : []; { can be po_msgstr or po_msgint }
mutexclpocall : [pocall_internproc]; mutexclpocall : [pocall_internproc];
mutexclpotype : [potype_constructor,potype_destructor,potype_operator]; mutexclpotype : [potype_constructor,potype_destructor,potype_operator,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_interrupt,po_external,po_inline] mutexclpo : [po_interrupt,po_external,po_inline]
),( ),(
idtok:_MWPASCAL; idtok:_MWPASCAL;
@ -2058,7 +2072,7 @@ const
pocall : pocall_pascal; pocall : pocall_pascal;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_PUBLIC; idtok:_PUBLIC;
@ -2076,7 +2090,7 @@ const
pocall : pocall_register; pocall : pocall_register;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_REINTRODUCE; idtok:_REINTRODUCE;
@ -2094,7 +2108,7 @@ const
pocall : pocall_safecall; pocall : pocall_safecall;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_SOFTFLOAT; idtok:_SOFTFLOAT;
@ -2103,7 +2117,7 @@ const
pocall : pocall_softfloat; pocall : pocall_softfloat;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
{ it's available with po_external because the libgcc floating point routines on the arm { it's available with po_external because the libgcc floating point routines on the arm
uses this calling convention } uses this calling convention }
mutexclpo : [] mutexclpo : []
@ -2114,7 +2128,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : [po_staticmethod]; pooption : [po_staticmethod];
mutexclpocall : [pocall_internproc]; mutexclpocall : [pocall_internproc];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external,po_interrupt,po_exports] mutexclpo : [po_external,po_interrupt,po_exports]
),( ),(
idtok:_STDCALL; idtok:_STDCALL;
@ -2123,7 +2137,7 @@ const
pocall : pocall_stdcall; pocall : pocall_stdcall;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external] mutexclpo : [po_external]
),( ),(
idtok:_SYSCALL; idtok:_SYSCALL;
@ -2135,7 +2149,7 @@ const
pocall : pocall_syscall; pocall : pocall_syscall;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external,po_assembler,po_interrupt,po_exports] mutexclpo : [po_external,po_assembler,po_interrupt,po_exports]
),( ),(
idtok:_VIRTUAL; idtok:_VIRTUAL;
@ -2144,7 +2158,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : [po_virtualmethod]; pooption : [po_virtualmethod];
mutexclpocall : [pocall_internproc]; mutexclpocall : [pocall_internproc];
mutexclpotype : []; mutexclpotype : [potype_class_constructor,potype_class_destructor];
mutexclpo : [po_external,po_interrupt,po_exports,po_overridingmethod,po_inline] mutexclpo : [po_external,po_interrupt,po_exports,po_overridingmethod,po_inline]
),( ),(
idtok:_CPPDECL; idtok:_CPPDECL;
@ -2153,7 +2167,7 @@ const
pocall : pocall_cppdecl; pocall : pocall_cppdecl;
pooption : []; pooption : [];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_assembler,po_external,po_virtualmethod] mutexclpo : [po_assembler,po_external,po_virtualmethod]
),( ),(
idtok:_VARARGS; idtok:_VARARGS;
@ -2172,7 +2186,7 @@ const
pocall : pocall_none; pocall : pocall_none;
pooption : [po_compilerproc]; pooption : [po_compilerproc];
mutexclpocall : []; mutexclpocall : [];
mutexclpotype : [potype_constructor,potype_destructor]; mutexclpotype : [potype_constructor,potype_destructor,potype_class_constructor,potype_class_destructor];
mutexclpo : [po_interrupt] mutexclpo : [po_interrupt]
),( ),(
idtok:_WEAKEXTERNAL; idtok:_WEAKEXTERNAL;
@ -2185,7 +2199,7 @@ const
pooption : [po_external,po_weakexternal]; pooption : [po_external,po_weakexternal];
mutexclpocall : [pocall_internproc,pocall_syscall]; mutexclpocall : [pocall_internproc,pocall_syscall];
{ allowed for external cpp classes } { allowed for external cpp classes }
mutexclpotype : [{potype_constructor,potype_destructor}]; mutexclpotype : [{potype_constructor,potype_destructor}potype_class_constructor,potype_class_destructor];
mutexclpo : [po_public,po_exports,po_interrupt,po_assembler,po_inline] mutexclpo : [po_public,po_exports,po_interrupt,po_assembler,po_inline]
),( ),(
idtok:_ENUMERATOR; idtok:_ENUMERATOR;
@ -2639,6 +2653,17 @@ const
include(pd.procoptions,po_global); include(pd.procoptions,po_global);
end; end;
{ Class constructors and destructor are static class methods in real. }
{ There are many places in the compiler where either class or static }
{ method flag changes the behavior. It is simplier to add them to }
{ the class constructors/destructors options than to fix all the }
{ occurencies. (Paul) }
if pd.proctypeoption in [potype_class_constructor,potype_class_destructor] then
begin
include(pd.procoptions,po_classmethod);
include(pd.procoptions,po_staticmethod);
end;
while token in [_ID,_LECKKLAMMER] do while token in [_ID,_LECKKLAMMER] do
begin begin
if try_to_consume(_LECKKLAMMER) then if try_to_consume(_LECKKLAMMER) then

2
compiler/pdecvar.pas
View File

@ -492,7 +492,7 @@ implementation
p.propaccesslist[palt_read].procdef:=Tprocsym(sym).Find_procdef_bypara(readprocdef.paras,p.propdef,[cpo_allowdefaults,cpo_ignorehidden]); p.propaccesslist[palt_read].procdef:=Tprocsym(sym).Find_procdef_bypara(readprocdef.paras,p.propdef,[cpo_allowdefaults,cpo_ignorehidden]);
if not assigned(p.propaccesslist[palt_read].procdef) or if not assigned(p.propaccesslist[palt_read].procdef) or
{ because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property } { because of cpo_ignorehidden we need to compare if it is a static class method and we have a class property }
((sp_static in p.symoptions) <> ([po_classmethod,po_staticmethod]<=tprocdef(p.propaccesslist[palt_read].procdef).procoptions)) then ((sp_static in p.symoptions) <> tprocdef(p.propaccesslist[palt_read].procdef).no_self_node) then
Message(parser_e_ill_property_access_sym); Message(parser_e_ill_property_access_sym);
end; end;
fieldvarsym : fieldvarsym :

10
compiler/pexpr.pas
View File

@ -845,8 +845,8 @@ implementation
end; end;
ObjectSymtable : ObjectSymtable :
begin begin
if (assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions)) then { We are calling from the static class method which has no self node }
{ We are calling from the static class method which has no self node } if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef._class)) p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef._class))
else else
p1:=load_self_node; p1:=load_self_node;
@ -1259,7 +1259,7 @@ implementation
if assigned(p1) and if assigned(p1) and
( (
is_self_node(p1) or is_self_node(p1) or
(assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions) and (assigned(current_procinfo) and (current_procinfo.procdef.no_self_node) and
(current_procinfo.procdef._class = classh))) then (current_procinfo.procdef._class = classh))) then
Message(parser_e_only_class_members) Message(parser_e_only_class_members)
else else
@ -1458,7 +1458,7 @@ implementation
if only method from which it was called is if only method from which it was called is
not class static } not class static }
if (srsymtable.symtabletype=ObjectSymtable) then if (srsymtable.symtabletype=ObjectSymtable) then
if (assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions)) then if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef._class)) p1:=cloadvmtaddrnode.create(ctypenode.create(current_procinfo.procdef._class))
else else
p1:=load_self_node; p1:=load_self_node;
@ -1637,7 +1637,7 @@ implementation
if is_member_read(srsym,srsymtable,p1,hdef) then if is_member_read(srsym,srsymtable,p1,hdef) then
begin begin
if (srsymtable.symtabletype=ObjectSymtable) then if (srsymtable.symtabletype=ObjectSymtable) then
if (assigned(current_procinfo) and ([po_staticmethod,po_classmethod] <= current_procinfo.procdef.procoptions)) then if assigned(current_procinfo) and current_procinfo.procdef.no_self_node then
{ no self node in static class methods } { no self node in static class methods }
p1:=cloadvmtaddrnode.create(ctypenode.create(hdef)) p1:=cloadvmtaddrnode.create(ctypenode.create(hdef))
else else

5
compiler/psub.pas
View File

@ -1801,8 +1801,9 @@ implementation
is_classdef:=false; is_classdef:=false;
if try_to_consume(_CLASS) then if try_to_consume(_CLASS) then
begin begin
{ class method only allowed for procedures and functions } { class modifier is only allowed for procedures, functions, }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR]) then { constructors, destructors, fields and properties }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR]) then
Message(parser_e_procedure_or_function_expected); Message(parser_e_procedure_or_function_expected);
if is_interface(current_objectdef) then if is_interface(current_objectdef) then

26
compiler/symconst.pas
View File

@ -81,12 +81,18 @@ const
ftCurr = 4; ftCurr = 4;
ftFloat128 = 5; ftFloat128 = 5;
mkProcedure= 0; mkProcedure = 0;
mkFunction = 1; mkFunction = 1;
mkConstructor = 2; mkConstructor = 2;
mkDestructor = 3; mkDestructor = 3;
mkClassProcedure= 4; mkClassProcedure = 4;
mkClassFunction = 5; mkClassFunction = 5;
mkClassConstructor = 6;
mkClassDestructor = 7;
// delphi has the next too:
//mkOperatorOverload = 8;
//mkSafeProcedure = 9;
//mkSafeFunction = 10;
pfvar = 1; pfvar = 1;
pfConst = 2; pfConst = 2;
@ -227,7 +233,9 @@ type
potype_destructor, { Procedure is a destructor } potype_destructor, { Procedure is a destructor }
potype_operator, { Procedure defines an operator } potype_operator, { Procedure defines an operator }
potype_procedure, potype_procedure,
potype_function potype_function,
potype_class_constructor, { class constructor }
potype_class_destructor { class destructor }
); );
tproctypeoptions=set of tproctypeoption; tproctypeoptions=set of tproctypeoption;
@ -344,7 +352,9 @@ type
oo_has_enumerator_current, oo_has_enumerator_current,
oo_is_external, { the class is externally implemented (objcclass, cppclass) } oo_is_external, { the class is externally implemented (objcclass, cppclass) }
oo_is_anonymous, { the class is only formally defined in this module (objcclass x = class; external;) } oo_is_anonymous, { the class is only formally defined in this module (objcclass x = class; external;) }
oo_is_classhelper { objcclasses that represent categories, and Delpi-style class helpers, are marked like this } oo_is_classhelper, { objcclasses that represent categories, and Delpi-style class helpers, are marked like this }
oo_has_class_constructor, { the object/class has a class constructor }
oo_has_class_destructor { the object/class has a class destructor }
); );
tobjectoptions=set of tobjectoption; tobjectoptions=set of tobjectoption;

16
compiler/symdef.pas
View File

@ -394,6 +394,8 @@ interface
function getvardef:longint;override; function getvardef:longint;override;
end; end;
{ tabstractprocdef }
tabstractprocdef = class(tstoreddef) tabstractprocdef = class(tstoreddef)
{ saves a definition to the return type } { saves a definition to the return type }
returndef : tdef; returndef : tdef;
@ -422,6 +424,7 @@ interface
function typename_paras(showhidden:boolean): string; function typename_paras(showhidden:boolean): string;
function is_methodpointer:boolean;virtual; function is_methodpointer:boolean;virtual;
function is_addressonly:boolean;virtual; function is_addressonly:boolean;virtual;
function no_self_node:boolean;
private private
procedure count_para(p:TObject;arg:pointer); procedure count_para(p:TObject;arg:pointer);
procedure insert_para(p:TObject;arg:pointer); procedure insert_para(p:TObject;arg:pointer);
@ -469,6 +472,8 @@ interface
end; end;
{$endif oldregvars} {$endif oldregvars}
{ tprocdef }
tprocdef = class(tabstractprocdef) tprocdef = class(tabstractprocdef)
private private
_mangledname : pshortstring; _mangledname : pshortstring;
@ -3008,6 +3013,12 @@ implementation
result:=true; result:=true;
end; end;
function tabstractprocdef.no_self_node: boolean;
begin
Result:=([po_staticmethod,po_classmethod]<=procoptions)or
(proctypeoption in [potype_class_constructor,potype_class_destructor]);
end;
{*************************************************************************** {***************************************************************************
TPROCDEF TPROCDEF
@ -3309,6 +3320,10 @@ implementation
s:='constructor '+s; s:='constructor '+s;
potype_destructor: potype_destructor:
s:='destructor '+s; s:='destructor '+s;
potype_class_constructor:
s:='class constructor '+s;
potype_class_destructor:
s:='class destructor '+s;
else else
if assigned(returndef) and if assigned(returndef) and
not(is_void(returndef)) then not(is_void(returndef)) then
@ -3336,7 +3351,6 @@ implementation
(owner.symtabletype<>ObjectSymtable); (owner.symtabletype<>ObjectSymtable);
end; end;
function tprocdef.GetSymtable(t:tGetSymtable):TSymtable; function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
begin begin
case t of case t of

31
compiler/utils/ppudump.pp
View File

@ -1086,7 +1086,9 @@ type
potype_destructor, { Procedure is a destructor } potype_destructor, { Procedure is a destructor }
potype_operator, { Procedure defines an operator } potype_operator, { Procedure defines an operator }
potype_procedure, potype_procedure,
potype_function potype_function,
potype_class_constructor, { class constructor }
potype_class_destructor { class destructor }
); );
tproctypeoptions=set of tproctypeoption; tproctypeoptions=set of tproctypeoption;
tprocoption=(po_none, tprocoption=(po_none,
@ -1182,14 +1184,16 @@ const
'MWPascal' 'MWPascal'
); );
proctypeopt : array[1..ord(high(tproctypeoption))] of tproctypeopt=( proctypeopt : array[1..ord(high(tproctypeoption))] of tproctypeopt=(
(mask:potype_proginit; str:'ProgInit'), (mask:potype_proginit; str:'ProgInit'),
(mask:potype_unitinit; str:'UnitInit'), (mask:potype_unitinit; str:'UnitInit'),
(mask:potype_unitfinalize;str:'UnitFinalize'), (mask:potype_unitfinalize; str:'UnitFinalize'),
(mask:potype_constructor; str:'Constructor'), (mask:potype_constructor; str:'Constructor'),
(mask:potype_destructor; str:'Destructor'), (mask:potype_destructor; str:'Destructor'),
(mask:potype_operator; str:'Operator'), (mask:potype_operator; str:'Operator'),
(mask:potype_procedure; str:'Procedure'), (mask:potype_procedure; str:'Procedure'),
(mask:potype_function; str:'Function') (mask:potype_function; str:'Function'),
(mask:potype_class_constructor; str:'Class Constructor'),
(mask:potype_class_destructor; str:'Class Destructor')
); );
procopt : array[1..ord(high(tprocoption))] of tprocopt=( procopt : array[1..ord(high(tprocoption))] of tprocopt=(
(mask:po_classmethod; str:'ClassMethod'), (mask:po_classmethod; str:'ClassMethod'),
@ -1407,7 +1411,9 @@ type
oo_has_enumerator_current, oo_has_enumerator_current,
oo_is_external, { the class is externally implemented (objcclass, cppclass) } oo_is_external, { the class is externally implemented (objcclass, cppclass) }
oo_is_anonymous, { the class is only formally defined in this module (objcclass x = class; external;) } oo_is_anonymous, { the class is only formally defined in this module (objcclass x = class; external;) }
oo_is_classhelper { objcclasses that represent categories, and Delpi-style class helpers, are marked like this } oo_is_classhelper, { objcclasses that represent categories, and Delpi-style class helpers, are marked like this }
oo_has_class_constructor, { the object/class has a class constructor }
oo_has_class_destructor { the object/class has a class destructor }
); );
tobjectoptions=set of tobjectoption; tobjectoptions=set of tobjectoption;
tsymopt=record tsymopt=record
@ -1436,7 +1442,10 @@ const
(mask:oo_has_enumerator_current; str:'HasEnumeratorCurrent'), (mask:oo_has_enumerator_current; str:'HasEnumeratorCurrent'),
(mask:oo_is_external; str:'External'), (mask:oo_is_external; str:'External'),
(mask:oo_is_anonymous; str:'Anonymous'), (mask:oo_is_anonymous; str:'Anonymous'),
(mask:oo_is_classhelper; str:'Class Helper/Category')); (mask:oo_is_classhelper; str:'Class Helper/Category'),
(mask:oo_has_class_constructor; str:'HasClassConstructor'),
(mask:oo_has_class_destructor; str:'HasClassDestructor')
);
var var
symoptions : tobjectoptions; symoptions : tobjectoptions;
i : longint; i : longint;

3
rtl/objpas/typinfo.pp
View File

@ -50,7 +50,8 @@ unit typinfo;
TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr); TFloatType = (ftSingle,ftDouble,ftExtended,ftComp,ftCurr);
{$endif} {$endif}
TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor, TMethodKind = (mkProcedure,mkFunction,mkConstructor,mkDestructor,
mkClassProcedure, mkClassFunction); mkClassProcedure, mkClassFunction, mkClassConstructor,
mkClassDestructor);
TParamFlag = (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut); TParamFlag = (pfVar,pfConst,pfArray,pfAddress,pfReference,pfOut);
TParamFlags = set of TParamFlag; TParamFlags = set of TParamFlag;
TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch,ifHasStrGUID); TIntfFlag = (ifHasGuid,ifDispInterface,ifDispatch,ifHasStrGUID);