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

compiler: start parsing of record constructors and destructors:

Browse Source 
- disallow record destructor
  - raise internal error for constructor because it is not yet implemented
  - handle class constructors and destructors for records
  - move find_procdef_bytype to tabstractpointerdef

git-svn-id: branches/paul/extended_records@16544 -
This commit is contained in:
paul 2010-12-11 07:31:27 +00:00
parent 4e73e280f9
commit 7852295f26
6 changed files with 381 additions and 408 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
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
# #
# 03298 is the last used one # 03299 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
@ -1342,8 +1342,10 @@ parser_f_no_generic_inside_generic=03297_F_Declaration of generic class inside a
% Since generics are implemented by recording tokens, it is not possible to % Since generics are implemented by recording tokens, it is not possible to
% have declaration of generic class inside another generic class. % have declaration of generic class inside another generic class.
% \end{description} % \end{description}
parser_e_no_record_published=03298_E_Record types cannot have published sections. parser_e_no_record_published=03298_E_Record types cannot have published sections
% Published sections can be used only inside classes % Published sections can be used only inside classes.
parser_e_no_destructor_in_records=03299_E_Destructors aren't allowed in records
% Destructor declarations aren't allowed in records.
# #
# Type Checking # Type Checking
# #

5
compiler/msgidx.inc
View File

@ -387,6 +387,7 @@ const
parser_e_no_procvarnested_const=03296; parser_e_no_procvarnested_const=03296;
parser_f_no_generic_inside_generic=03297; parser_f_no_generic_inside_generic=03297;
parser_e_no_record_published=03298; parser_e_no_record_published=03298;
parser_e_no_destructor_in_records=03299;
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;
@ -872,9 +873,9 @@ const
option_info=11024; option_info=11024;
option_help_pages=11025; option_help_pages=11025;
MsgTxtSize = 57958; MsgTxtSize = 58003;
MsgIdxMax : array[1..20] of longint=( MsgIdxMax : array[1..20] of longint=(
24,88,299,97,82,54,111,22,202,63, 24,88,300,97,82,54,111,22,202,63,
49,20,1,1,1,1,1,1,1,1 49,20,1,1,1,1,1,1,1,1
); );

635
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

34
compiler/pmodules.pas
View File

@ -376,13 +376,13 @@ implementation
ResourceStringTables.free; ResourceStringTables.free;
end; end;
procedure AddToClasInits(p:TObject;arg:pointer); procedure AddToStructInits(p:TObject;arg:pointer);
var var
ClassList: TFPList absolute arg; StructList: TFPList absolute arg;
begin begin
if (tdef(p).typ=objectdef) and if (tdef(p).typ in [objectdef,recorddef]) and
([oo_has_class_constructor,oo_has_class_destructor] * tobjectdef(p).objectoptions <> []) then ([oo_has_class_constructor,oo_has_class_destructor] * tabstractrecorddef(p).objectoptions <> []) then
ClassList.Add(p); StructList.Add(p);
end; end;
procedure InsertInitFinalTable; procedure InsertInitFinalTable;
@ -391,32 +391,32 @@ implementation
unitinits : TAsmList; unitinits : TAsmList;
count : longint; count : longint;
procedure write_class_inits(u: tmodule); procedure write_struct_inits(u: tmodule);
var var
i: integer; i: integer;
classlist: TFPList; structlist: TFPList;
pd: tprocdef; pd: tprocdef;
begin begin
classlist := TFPList.Create; structlist := TFPList.Create;
if assigned(u.globalsymtable) then if assigned(u.globalsymtable) then
u.globalsymtable.DefList.ForEachCall(@AddToClasInits,classlist); u.globalsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
u.localsymtable.DefList.ForEachCall(@AddToClasInits,classlist); u.localsymtable.DefList.ForEachCall(@AddToStructInits,structlist);
{ write classes } { write structures }
for i := 0 to classlist.Count - 1 do for i := 0 to structlist.Count - 1 do
begin begin
pd := tobjectdef(classlist[i]).find_procdef_bytype(potype_class_constructor); pd := tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_constructor);
if assigned(pd) then if assigned(pd) then
unitinits.concat(Tai_const.Createname(pd.mangledname,0)) unitinits.concat(Tai_const.Createname(pd.mangledname,0))
else else
unitinits.concat(Tai_const.Create_pint(0)); unitinits.concat(Tai_const.Create_pint(0));
pd := tobjectdef(classlist[i]).find_procdef_bytype(potype_class_destructor); pd := tabstractrecorddef(structlist[i]).find_procdef_bytype(potype_class_destructor);
if assigned(pd) then if assigned(pd) then
unitinits.concat(Tai_const.Createname(pd.mangledname,0)) unitinits.concat(Tai_const.Createname(pd.mangledname,0))
else else
unitinits.concat(Tai_const.Create_pint(0)); unitinits.concat(Tai_const.Create_pint(0));
inc(count); inc(count);
end; end;
classlist.free; structlist.free;
end; end;
begin begin
@ -427,7 +427,7 @@ implementation
begin begin
{ insert class constructors/destructors of the unit } { insert class constructors/destructors of the unit }
if (hp.u.flags and uf_classinits) <> 0 then if (hp.u.flags and uf_classinits) <> 0 then
write_class_inits(hp.u); write_struct_inits(hp.u);
{ call the unit init code and make it external } { call the unit init code and make it external }
if (hp.u.flags and (uf_init or uf_finalize))<>0 then if (hp.u.flags and (uf_init or uf_finalize))<>0 then
begin begin
@ -445,7 +445,7 @@ implementation
end; end;
{ insert class constructors/destructor of the program } { insert class constructors/destructor of the program }
if (current_module.flags and uf_classinits) <> 0 then if (current_module.flags and uf_classinits) <> 0 then
write_class_inits(current_module); write_struct_inits(current_module);
{ Insert initialization/finalization of the program } { Insert initialization/finalization of the program }
if (current_module.flags and (uf_init or uf_finalize))<>0 then if (current_module.flags and (uf_init or uf_finalize))<>0 then
begin begin

67
compiler/ptype.pas
View File

@ -573,7 +573,6 @@ implementation
var var
pd : tprocdef; pd : tprocdef;
has_destructor,
oldparse_only: boolean; oldparse_only: boolean;
member_blocktype : tblock_type; member_blocktype : tblock_type;
fields_allowed, is_classdef, classfields: boolean; fields_allowed, is_classdef, classfields: boolean;
@ -585,7 +584,6 @@ implementation
current_structdef.symtable.currentvisibility:=vis_public; current_structdef.symtable.currentvisibility:=vis_public;
testcurobject:=1; testcurobject:=1;
has_destructor:=false;
fields_allowed:=true; fields_allowed:=true;
is_classdef:=false; is_classdef:=false;
classfields:=false; classfields:=false;
@ -617,6 +615,7 @@ implementation
begin begin
consume(_PRIVATE); consume(_PRIVATE);
current_structdef.symtable.currentvisibility:=vis_private; current_structdef.symtable.currentvisibility:=vis_private;
include(current_structdef.objectoptions,oo_has_private);
fields_allowed:=true; fields_allowed:=true;
is_classdef:=false; is_classdef:=false;
classfields:=false; classfields:=false;
@ -626,6 +625,7 @@ implementation
begin begin
consume(_PROTECTED); consume(_PROTECTED);
current_structdef.symtable.currentvisibility:=vis_protected; current_structdef.symtable.currentvisibility:=vis_protected;
include(current_structdef.objectoptions,oo_has_protected);
fields_allowed:=true; fields_allowed:=true;
is_classdef:=false; is_classdef:=false;
classfields:=false; classfields:=false;
@ -660,11 +660,13 @@ implementation
begin begin
consume(_PRIVATE); consume(_PRIVATE);
current_structdef.symtable.currentvisibility:=vis_strictprivate; current_structdef.symtable.currentvisibility:=vis_strictprivate;
include(current_structdef.objectoptions,oo_has_strictprivate);
end; end;
_PROTECTED: _PROTECTED:
begin begin
consume(_PROTECTED); consume(_PROTECTED);
current_structdef.symtable.currentvisibility:=vis_strictprotected; current_structdef.symtable.currentvisibility:=vis_strictprotected;
include(current_structdef.objectoptions,oo_has_strictprotected);
end; end;
else else
message(parser_e_protected_or_private_expected); message(parser_e_protected_or_private_expected);
@ -742,43 +744,31 @@ implementation
fields_allowed:=false; fields_allowed:=false;
is_classdef:=false; is_classdef:=false;
end; end;
{ todo: constructor
_CONSTRUCTOR : _CONSTRUCTOR :
begin begin
if (current_objectdef.symtable.currentvisibility=vis_published) and if not is_classdef and (current_structdef.symtable.currentvisibility <> vis_public) then
not(oo_can_have_published in current_objectdef.objectoptions) then
Message(parser_e_cant_have_published);
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
Message(parser_e_no_con_des_in_interfaces);
{ Objective-C does not know the concept of a constructor }
if is_objc_class_or_protocol(current_objectdef) then
Message(parser_e_objc_no_constructor_destructor);
{ only 1 class constructor is allowed } { only 1 class constructor is allowed }
if is_classdef and (oo_has_class_constructor in current_objectdef.objectoptions) then if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
Message1(parser_e_only_one_class_constructor_allowed, current_objectdef.objrealname^); Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
if is_classdef then if is_classdef then
pd:=class_constructor_head pd:=class_constructor_head
else else
pd:=constructor_head; begin
parse_object_proc_directives(pd); pd:=constructor_head;
{ raise internal error for now - constructor is not implemented yet }
internalerror(201012110);
end;
parse_record_proc_directives(pd);
handle_calling_convention(pd); handle_calling_convention(pd);
{ add definition to procsym } { add definition to procsym }
proc_add_definition(pd); proc_add_definition(pd);
{ add procdef options to objectdef options }
if (po_virtualmethod in pd.procoptions) then
include(current_objectdef.objectoptions,oo_has_virtual);
chkcpp(pd);
maybe_parse_hint_directives(pd); maybe_parse_hint_directives(pd);
parse_only:=oldparse_only; parse_only:=oldparse_only;
@ -787,29 +777,12 @@ implementation
end; end;
_DESTRUCTOR : _DESTRUCTOR :
begin begin
if (current_objectdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_objectdef.objectoptions) then
Message(parser_e_cant_have_published);
if not is_classdef then if not is_classdef then
if has_destructor then Message(parser_e_no_destructor_in_records);
Message(parser_n_only_one_destructor)
else
has_destructor:=true;
if is_interface(current_objectdef) then
Message(parser_e_no_con_des_in_interfaces);
if not is_classdef and (current_objectdef.symtable.currentvisibility<>vis_public) then
Message(parser_w_destructor_should_be_public);
{ Objective-C does not know the concept of a destructor }
if is_objc_class_or_protocol(current_objectdef) then
Message(parser_e_objc_no_constructor_destructor);
{ only 1 class destructor is allowed } { only 1 class destructor is allowed }
if is_classdef and (oo_has_class_destructor in current_objectdef.objectoptions) then if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then
Message1(parser_e_only_one_class_destructor_allowed, current_objectdef.objrealname^); Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^);
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
@ -817,24 +790,18 @@ implementation
pd:=class_destructor_head pd:=class_destructor_head
else else
pd:=destructor_head; pd:=destructor_head;
parse_object_proc_directives(pd); parse_record_proc_directives(pd);
handle_calling_convention(pd); handle_calling_convention(pd);
{ add definition to procsym } { add definition to procsym }
proc_add_definition(pd); proc_add_definition(pd);
{ add procdef options to objectdef options }
if (po_virtualmethod in pd.procoptions) then
include(current_objectdef.objectoptions,oo_has_virtual);
chkcpp(pd);
maybe_parse_hint_directives(pd); maybe_parse_hint_directives(pd);
parse_only:=oldparse_only; parse_only:=oldparse_only;
fields_allowed:=false; fields_allowed:=false;
is_classdef:=false; is_classdef:=false;
end; end;
}
_END : _END :
begin begin
consume(_END); consume(_END);

40
compiler/symdef.pas
View File

@ -168,6 +168,7 @@ interface
function GetTypeName:string;override; function GetTypeName:string;override;
end; end;
tprocdef = class;
{ tabstractrecorddef } { tabstractrecorddef }
tabstractrecorddef= class(tstoreddef) tabstractrecorddef= class(tstoreddef)
@ -181,6 +182,7 @@ interface
constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile); constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
procedure ppuwrite(ppufile:tcompilerppufile);override; procedure ppuwrite(ppufile:tcompilerppufile);override;
destructor destroy; override; destructor destroy; override;
function find_procdef_bytype(pt:tproctypeoption): tprocdef;
function GetSymtable(t:tGetSymtable):TSymtable;override; function GetSymtable(t:tGetSymtable):TSymtable;override;
function is_packed:boolean; function is_packed:boolean;
function RttiName: string; function RttiName: string;
@ -204,7 +206,6 @@ interface
function needs_inittable : boolean;override; function needs_inittable : boolean;override;
end; end;
tprocdef = class;
tobjectdef = class; tobjectdef = class;
{ TImplementedInterface } { TImplementedInterface }
@ -306,7 +307,6 @@ interface
procedure check_forwards; procedure check_forwards;
procedure insertvmt; procedure insertvmt;
procedure set_parent(c : tobjectdef); procedure set_parent(c : tobjectdef);
function find_procdef_bytype(pt:tproctypeoption): tprocdef;
function find_destructor: tprocdef; function find_destructor: tprocdef;
function implements_any_interfaces: boolean; function implements_any_interfaces: boolean;
{ dispinterface support } { dispinterface support }
@ -2589,6 +2589,24 @@ implementation
inherited destroy; inherited destroy;
end; end;
function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
var
i: longint;
sym: tsym;
begin
for i:=0 to symtable.SymList.Count-1 do
begin
sym:=tsym(symtable.SymList[i]);
if sym.typ=procsym then
begin
result:=tprocsym(sym).find_procdef_bytype(pt);
if assigned(result) then
exit;
end;
end;
result:=nil;
end;
function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable; function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
begin begin
if t=gs_record then if t=gs_record then
@ -4528,24 +4546,6 @@ implementation
is_related:=false; is_related:=false;
end; end;
function tobjectdef.find_procdef_bytype(pt:tproctypeoption): tprocdef;
var
i: longint;
sym: tsym;
begin
for i:=0 to symtable.SymList.Count-1 do
begin
sym:=tsym(symtable.SymList[i]);
if sym.typ=procsym then
begin
result:=tprocsym(sym).find_procdef_bytype(pt);
if assigned(result) then
exit;
end;
end;
result:=nil;
end;
function tobjectdef.find_destructor: tprocdef; function tobjectdef.find_destructor: tprocdef;
var var
objdef: tobjectdef; objdef: tobjectdef;