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

Implement support for parsing "generic [class] procedure" and "generic [class] function" in non-Delphi modes. Since "generic" is a prefix it is quite ugly to implement, but from a Pascal language point of view it fits better than "procedure generic xyz".

Browse Source 
Supporting such a prefix of course means that all section handling code ("var", "type", etc.) needs to respect the case of a "generic" token followed by "function", "procedure" or "class" and thus abort doing its own business.
Maybe I'll find the time somewhen in the future to rework the parser (plus scanner?) a bit so that code like this gets more easy to add and more importantly less ugly.

pdecsub.pas:
  * extend parse_proc_dec() and parse_record_method_dec() so that they can be told that they are supposed to handle the to be parsed function/procedure/method header as a generic
pdecvar.pas:
  + new entry for tvar_dec_option named "vd_check_generic" to tell read_var_decls() and read_record_fields() to look out for "generic"
  * extend read_var_decls() and read_record_fields() to check for "generic" if needed and to clean up correctly if it is encountered
pdecl.pas:
  * the section handling procedures types_dec(), resourcestring_dec(), var_dec(), threadvar_dec() and consts_dec() all return whether they had encountered a "generic" token that was followed by one of $
pdecobj.pas:
  * extend method_dec() to take a parameter that says whether the method is supposed to be a generic one
  * parse_object_members: while read_record_fields() can handle "generic" we also need to handle the case of "generic" if no fields are allowed anymore
psub.pas:
  * extend read_proc() by the possibility to tell it that the procedure/function to be parsed is supposed to be generic
  * adjust read_declarations() and read_interface_declarations() to keep track of parsed "generic" tokens and to pass them on accordingly
ptype.pas:
  * parse_record_members: same remark as for pdecobj.parse_object_members

git-svn-id: trunk@32380 -
This commit is contained in:
svenbarth 2015-11-20 16:50:58 +00:00
parent ba66456bdb
commit d3660fec31
7 changed files with 346 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
compiler/pdecl.pas
View File

@ -37,15 +37,15 @@ interface
function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym; function readconstant(const orgname:string;const filepos:tfileposinfo; out nodetype: tnodetype):tconstsym;
procedure const_dec; procedure const_dec(out had_generic:boolean);
procedure consts_dec(in_structure, allow_typed_const: boolean); procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
procedure label_dec; procedure label_dec;
procedure type_dec; procedure type_dec(out had_generic:boolean);
procedure types_dec(in_structure: boolean); procedure types_dec(in_structure: boolean;out had_generic:boolean);
procedure var_dec; procedure var_dec(out had_generic:boolean);
procedure threadvar_dec; procedure threadvar_dec(out had_generic:boolean);
procedure property_dec; procedure property_dec;
procedure resourcestring_dec; procedure resourcestring_dec(out had_generic:boolean);
implementation implementation
@ -181,13 +181,13 @@ implementation
readconstant:=hp; readconstant:=hp;
end; end;
procedure const_dec; procedure const_dec(out had_generic:boolean);
begin begin
consume(_CONST); consume(_CONST);
consts_dec(false,true); consts_dec(false,true,had_generic);
end; end;
procedure consts_dec(in_structure, allow_typed_const: boolean); procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
var var
orgname : TIDString; orgname : TIDString;
hdef : tdef; hdef : tdef;
@ -197,15 +197,20 @@ implementation
storetokenpos,filepos : tfileposinfo; storetokenpos,filepos : tfileposinfo;
nodetype : tnodetype; nodetype : tnodetype;
old_block_type : tblock_type; old_block_type : tblock_type;
first,
isgeneric,
skipequal : boolean; skipequal : boolean;
tclist : tasmlist; tclist : tasmlist;
varspez : tvarspez; varspez : tvarspez;
begin begin
old_block_type:=block_type; old_block_type:=block_type;
block_type:=bt_const; block_type:=bt_const;
had_generic:=false;
first:=true;
repeat repeat
orgname:=orgpattern; orgname:=orgpattern;
filepos:=current_tokenpos; filepos:=current_tokenpos;
isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
consume(_ID); consume(_ID);
case token of case token of
@ -314,9 +319,17 @@ implementation
end; end;
else else
{ generate an error } if not first and isgeneric and (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
consume(_EQ); begin
had_generic:=true;
break;
end
else
{ generate an error }
consume(_EQ);
end; end;
first:=false;
until (token<>_ID) or until (token<>_ID) or
(in_structure and (in_structure and
((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
@ -367,7 +380,7 @@ implementation
consume(_SEMICOLON); consume(_SEMICOLON);
end; end;
procedure types_dec(in_structure: boolean); procedure types_dec(in_structure: boolean;out had_generic:boolean);
function determine_generic_def(name:tidstring):tstoreddef; function determine_generic_def(name:tidstring):tstoreddef;
var var
@ -435,6 +448,7 @@ implementation
old_block_type : tblock_type; old_block_type : tblock_type;
old_checkforwarddefs: TFPObjectList; old_checkforwarddefs: TFPObjectList;
objecttype : tobjecttyp; objecttype : tobjecttyp;
first,
isgeneric, isgeneric,
isunique, isunique,
istyperenaming : boolean; istyperenaming : boolean;
@ -456,6 +470,7 @@ implementation
current_module.checkforwarddefs:=TFPObjectList.Create(false); current_module.checkforwarddefs:=TFPObjectList.Create(false);
block_type:=bt_type; block_type:=bt_type;
hdef:=nil; hdef:=nil;
first:=true;
repeat repeat
defpos:=current_tokenpos; defpos:=current_tokenpos;
istyperenaming:=false; istyperenaming:=false;
@ -463,7 +478,9 @@ implementation
generictokenbuf:=nil; generictokenbuf:=nil;
{ fpc generic declaration? } { fpc generic declaration? }
isgeneric:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC); if first then
had_generic:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_GENERIC);
isgeneric:=had_generic;
typename:=pattern; typename:=pattern;
orgtypename:=orgpattern; orgtypename:=orgpattern;
@ -897,6 +914,18 @@ implementation
hdef.typesym:=newtype; hdef.typesym:=newtype;
generictypelist.free; generictypelist.free;
end; end;
if not (m_delphi in current_settings.modeswitches) and
(token=_ID) and (idtoken=_GENERIC) then
begin
had_generic:=true;
consume(_ID);
if token in [_PROCEDURE,_FUNCTION,_CLASS] then
break;
end
else
had_generic:=false;
first:=false;
until (token<>_ID) or until (token<>_ID) or
(in_structure and (in_structure and
((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or ((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
@ -912,19 +941,19 @@ implementation
{ reads a type declaration to the symbol table } { reads a type declaration to the symbol table }
procedure type_dec; procedure type_dec(out had_generic:boolean);
begin begin
consume(_TYPE); consume(_TYPE);
types_dec(false); types_dec(false,had_generic);
end; end;
procedure var_dec; procedure var_dec(out had_generic:boolean);
{ parses variable declarations and inserts them in } { parses variable declarations and inserts them in }
{ the top symbol table of symtablestack } { the top symbol table of symtablestack }
begin begin
consume(_VAR); consume(_VAR);
read_var_decls([]); read_var_decls([vd_check_generic],had_generic);
end; end;
@ -946,7 +975,7 @@ implementation
end; end;
procedure threadvar_dec; procedure threadvar_dec(out had_generic:boolean);
{ parses thread variable declarations and inserts them in } { parses thread variable declarations and inserts them in }
{ the top symbol table of symtablestack } { the top symbol table of symtablestack }
begin begin
@ -954,16 +983,16 @@ implementation
if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_threadvars_only_sg); message(parser_e_threadvars_only_sg);
if f_threading in features then if f_threading in features then
read_var_decls([vd_threadvar]) read_var_decls([vd_threadvar,vd_check_generic],had_generic)
else else
begin begin
Message1(parser_f_unsupported_feature,featurestr[f_threading]); Message1(parser_f_unsupported_feature,featurestr[f_threading]);
read_var_decls([]); read_var_decls([vd_check_generic],had_generic);
end; end;
end; end;
procedure resourcestring_dec; procedure resourcestring_dec(out had_generic:boolean);
var var
orgname : TIDString; orgname : TIDString;
p : tnode; p : tnode;
@ -973,17 +1002,22 @@ implementation
old_block_type : tblock_type; old_block_type : tblock_type;
sp : pchar; sp : pchar;
sym : tsym; sym : tsym;
first,
isgeneric : boolean;
begin begin
if target_info.system in systems_managed_vm then if target_info.system in systems_managed_vm then
message(parser_e_feature_unsupported_for_vm); message(parser_e_feature_unsupported_for_vm);
consume(_RESOURCESTRING); consume(_RESOURCESTRING);
if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_resourcestring_only_sg); message(parser_e_resourcestring_only_sg);
first:=true;
had_generic:=false;
old_block_type:=block_type; old_block_type:=block_type;
block_type:=bt_const; block_type:=bt_const;
repeat repeat
orgname:=orgpattern; orgname:=orgpattern;
filepos:=current_tokenpos; filepos:=current_tokenpos;
isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
consume(_ID); consume(_ID);
case token of case token of
_EQ: _EQ:
@ -1035,8 +1069,17 @@ implementation
consume(_SEMICOLON); consume(_SEMICOLON);
p.free; p.free;
end; end;
else consume(_EQ); else
if not first and isgeneric and
(token in [_PROCEDURE, _FUNCTION, _CLASS]) then
begin
had_generic:=true;
break;
end
else
consume(_EQ);
end; end;
first:=false;
until token<>_ID; until token<>_ID;
block_type:=old_block_type; block_type:=old_block_type;
end; end;

75
compiler/pdecobj.pas
View File

@ -33,7 +33,7 @@ interface
function object_dec(objecttype:tobjecttyp;const n:tidstring;objsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;fd : tobjectdef;helpertype:thelpertype) : tobjectdef; function object_dec(objecttype:tobjecttyp;const n:tidstring;objsym:tsym;genericdef:tstoreddef;genericlist:tfphashobjectlist;fd : tobjectdef;helpertype:thelpertype) : tobjectdef;
{ parses a (class) method declaration } { parses a (class) method declaration }
function method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef; function method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
function class_constructor_head(astruct: tabstractrecorddef):tprocdef; function class_constructor_head(astruct: tabstractrecorddef):tprocdef;
function class_destructor_head(astruct: tabstractrecorddef):tprocdef; function class_destructor_head(astruct: tabstractrecorddef):tprocdef;
@ -810,7 +810,7 @@ implementation
end; end;
function method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef; function method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
procedure chkobjc(pd: tprocdef); procedure chkobjc(pd: tprocdef);
begin begin
@ -874,7 +874,7 @@ implementation
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
result:=parse_proc_dec(is_classdef,astruct); result:=parse_proc_dec(is_classdef,astruct,hadgeneric);
{ this is for error recovery as well as forward } { this is for error recovery as well as forward }
{ interface mappings, i.e. mapping to a method } { interface mappings, i.e. mapping to a method }
@ -1019,6 +1019,7 @@ implementation
var var
typedconstswritable: boolean; typedconstswritable: boolean;
object_member_blocktype : tblock_type; object_member_blocktype : tblock_type;
hadgeneric,
fields_allowed, is_classdef, class_fields, is_final, final_fields: boolean; fields_allowed, is_classdef, class_fields, is_final, final_fields: boolean;
vdoptions: tvar_dec_options; vdoptions: tvar_dec_options;
fieldlist: tfpobjectlist; fieldlist: tfpobjectlist;
@ -1114,6 +1115,7 @@ implementation
class_fields:=false; class_fields:=false;
is_final:=false; is_final:=false;
final_fields:=false; final_fields:=false;
hadgeneric:=false;
object_member_blocktype:=bt_general; object_member_blocktype:=bt_general;
fieldlist:=tfpobjectlist.create(false); fieldlist:=tfpobjectlist.create(false);
repeat repeat
@ -1214,33 +1216,49 @@ implementation
begin begin
if object_member_blocktype=bt_general then if object_member_blocktype=bt_general then
begin begin
if is_interface(current_structdef) or if (idtoken=_GENERIC) and
is_objc_protocol_or_category(current_structdef) or not (m_delphi in current_settings.modeswitches) and
( not fields_allowed then
is_objectpascal_helper(current_structdef) and begin
not class_fields if hadgeneric then
) or Message(parser_e_procedure_or_function_expected);
(is_javainterface(current_structdef) and consume(_ID);
not(class_fields and final_fields)) then hadgeneric:=true;
Message(parser_e_no_vars_in_interfaces); if not (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
Message(parser_e_procedure_or_function_expected);
end
else
begin
if is_interface(current_structdef) or
is_objc_protocol_or_category(current_structdef) or
(
is_objectpascal_helper(current_structdef) and
not class_fields
) or
(is_javainterface(current_structdef) and
not(class_fields and final_fields)) then
Message(parser_e_no_vars_in_interfaces);
if (current_structdef.symtable.currentvisibility=vis_published) and if (current_structdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_structdef.objectoptions) then not(oo_can_have_published in current_structdef.objectoptions) then
Message(parser_e_cant_have_published); Message(parser_e_cant_have_published);
if (not fields_allowed) then if (not fields_allowed) then
Message(parser_e_field_not_allowed_here); Message(parser_e_field_not_allowed_here);
vdoptions:=[vd_object]; vdoptions:=[vd_object];
if class_fields then if not (m_delphi in current_settings.modeswitches) then
include(vdoptions,vd_class); include(vdoptions,vd_check_generic);
if is_class(current_structdef) then if class_fields then
include(vdoptions,vd_canreorder); include(vdoptions,vd_class);
if final_fields then if is_class(current_structdef) then
include(vdoptions,vd_final); include(vdoptions,vd_canreorder);
read_record_fields(vdoptions,fieldlist,nil); if final_fields then
include(vdoptions,vd_final);
read_record_fields(vdoptions,fieldlist,nil,hadgeneric);
end;
end end
else if object_member_blocktype=bt_type then else if object_member_blocktype=bt_type then
types_dec(true) types_dec(true,hadgeneric)
else if object_member_blocktype=bt_const then else if object_member_blocktype=bt_const then
begin begin
typedconstswritable:=false; typedconstswritable:=false;
@ -1251,7 +1269,7 @@ implementation
typedconstswritable:=cs_typed_const_writable in current_settings.localswitches; typedconstswritable:=cs_typed_const_writable in current_settings.localswitches;
exclude(current_settings.localswitches,cs_typed_const_writable); exclude(current_settings.localswitches,cs_typed_const_writable);
end; end;
consts_dec(true,not is_javainterface(current_structdef)); consts_dec(true,not is_javainterface(current_structdef),hadgeneric);
if final_fields and if final_fields and
typedconstswritable then typedconstswritable then
include(current_settings.localswitches,cs_typed_const_writable); include(current_settings.localswitches,cs_typed_const_writable);
@ -1276,9 +1294,10 @@ implementation
_CONSTRUCTOR, _CONSTRUCTOR,
_DESTRUCTOR : _DESTRUCTOR :
begin begin
method_dec(current_structdef,is_classdef); method_dec(current_structdef,is_classdef,hadgeneric);
fields_allowed:=false; fields_allowed:=false;
is_classdef:=false; is_classdef:=false;
hadgeneric:=false;
end; end;
_END : _END :
begin begin

14
compiler/pdecsub.pas
View File

@ -78,11 +78,11 @@ interface
procedure parse_object_proc_directives(pd:tabstractprocdef); procedure parse_object_proc_directives(pd:tabstractprocdef);
procedure parse_record_proc_directives(pd:tabstractprocdef); procedure parse_record_proc_directives(pd:tabstractprocdef);
function parse_proc_head(astruct:tabstractrecorddef;potype:tproctypeoption;isgeneric:boolean;genericdef:tdef;generictypelist:tfphashobjectlist;out pd:tprocdef):boolean; function parse_proc_head(astruct:tabstractrecorddef;potype:tproctypeoption;isgeneric:boolean;genericdef:tdef;generictypelist:tfphashobjectlist;out pd:tprocdef):boolean;
function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef):tprocdef; function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef;isgeneric:boolean):tprocdef;
procedure parse_proc_dec_finish(pd:tprocdef;isclassmethod:boolean); procedure parse_proc_dec_finish(pd:tprocdef;isclassmethod:boolean);
{ parse a record method declaration (not a (class) constructor/destructor) } { parse a record method declaration (not a (class) constructor/destructor) }
function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef; function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
procedure insert_record_hidden_paras(astruct: trecorddef); procedure insert_record_hidden_paras(astruct: trecorddef);
@ -1457,7 +1457,7 @@ implementation
end; end;
end; end;
function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef):tprocdef; function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef;isgeneric:boolean):tprocdef;
var var
pd : tprocdef; pd : tprocdef;
old_block_type : tblock_type; old_block_type : tblock_type;
@ -1480,7 +1480,7 @@ implementation
_FUNCTION : _FUNCTION :
begin begin
consume(_FUNCTION); consume(_FUNCTION);
if parse_proc_head(astruct,potype_function,false,nil,nil,pd) then if parse_proc_head(astruct,potype_function,isgeneric,nil,nil,pd) then
begin begin
{ pd=nil when it is a interface mapping } { pd=nil when it is a interface mapping }
if assigned(pd) then if assigned(pd) then
@ -1500,7 +1500,7 @@ implementation
_PROCEDURE : _PROCEDURE :
begin begin
consume(_PROCEDURE); consume(_PROCEDURE);
if parse_proc_head(astruct,potype_procedure,false,nil,nil,pd) then if parse_proc_head(astruct,potype_procedure,isgeneric,nil,nil,pd) then
begin begin
{ pd=nil when it is an interface mapping } { pd=nil when it is an interface mapping }
if assigned(pd) then if assigned(pd) then
@ -1578,13 +1578,13 @@ implementation
end; end;
function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean): tprocdef; function parse_record_method_dec(astruct: tabstractrecorddef; is_classdef: boolean;hadgeneric:boolean): tprocdef;
var var
oldparse_only: boolean; oldparse_only: boolean;
begin begin
oldparse_only:=parse_only; oldparse_only:=parse_only;
parse_only:=true; parse_only:=true;
result:=parse_proc_dec(is_classdef,astruct); result:=parse_proc_dec(is_classdef,astruct,hadgeneric);
{ this is for error recovery as well as forward } { this is for error recovery as well as forward }
{ interface mappings, i.e. mapping to a method } { interface mappings, i.e. mapping to a method }

88
compiler/pdecvar.pas
View File

@ -31,14 +31,14 @@ interface
symtable,symsym,symdef; symtable,symsym,symdef;
type type
tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class,vd_final,vd_canreorder); tvar_dec_option=(vd_record,vd_object,vd_threadvar,vd_class,vd_final,vd_canreorder,vd_check_generic);
tvar_dec_options=set of tvar_dec_option; tvar_dec_options=set of tvar_dec_option;
function read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym; function read_property_dec(is_classproperty:boolean;astruct:tabstractrecorddef):tpropertysym;
procedure read_var_decls(options:Tvar_dec_options); procedure read_var_decls(options:Tvar_dec_options;out had_generic:boolean);
procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc: ppvariantrecdesc); procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc: ppvariantrecdesc;out had_generic:boolean);
procedure read_public_and_external(vs: tabstractvarsym); procedure read_public_and_external(vs: tabstractvarsym);
@ -1050,7 +1050,7 @@ implementation
end; end;
procedure read_var_decls(options:Tvar_dec_options); procedure read_var_decls(options:Tvar_dec_options;out had_generic:boolean);
procedure read_default_value(sc : TFPObjectList); procedure read_default_value(sc : TFPObjectList);
var var
@ -1266,6 +1266,8 @@ implementation
vs : tabstractvarsym; vs : tabstractvarsym;
hdef : tdef; hdef : tdef;
i : longint; i : longint;
first,
isgeneric,
semicoloneaten, semicoloneaten,
allowdefaultvalue, allowdefaultvalue,
hasdefaultvalue : boolean; hasdefaultvalue : boolean;
@ -1273,6 +1275,8 @@ implementation
deprecatedmsg : pshortstring; deprecatedmsg : pshortstring;
old_block_type : tblock_type; old_block_type : tblock_type;
sectionname : ansistring; sectionname : ansistring;
tmp_filepos,
old_current_filepos : tfileposinfo;
begin begin
old_block_type:=block_type; old_block_type:=block_type;
block_type:=bt_var; block_type:=bt_var;
@ -1281,6 +1285,8 @@ implementation
consume(_ID); consume(_ID);
{ read vars } { read vars }
sc:=TFPObjectList.create(false); sc:=TFPObjectList.create(false);
first:=true;
had_generic:=false;
while (token=_ID) do while (token=_ID) do
begin begin
semicoloneaten:=false; semicoloneaten:=false;
@ -1290,13 +1296,16 @@ implementation
repeat repeat
if (token = _ID) then if (token = _ID) then
begin begin
isgeneric:=(vd_check_generic in options) and
not (m_delphi in current_settings.modeswitches) and
(idtoken=_GENERIC);
case symtablestack.top.symtabletype of case symtablestack.top.symtabletype of
localsymtable : localsymtable :
vs:=clocalvarsym.create(orgpattern,vs_value,generrordef,[],true); vs:=clocalvarsym.create(orgpattern,vs_value,generrordef,[],false);
staticsymtable, staticsymtable,
globalsymtable : globalsymtable :
begin begin
vs:=cstaticvarsym.create(orgpattern,vs_value,generrordef,[],true); vs:=cstaticvarsym.create(orgpattern,vs_value,generrordef,[],false);
if vd_threadvar in options then if vd_threadvar in options then
include(vs.varoptions,vo_is_thread_var); include(vs.varoptions,vo_is_thread_var);
end; end;
@ -1304,11 +1313,43 @@ implementation
internalerror(200411064); internalerror(200411064);
end; end;
sc.add(vs); sc.add(vs);
symtablestack.top.insert(vs); if isgeneric then
end; tmp_filepos:=current_filepos;
end
else
isgeneric:=false;
consume(_ID); consume(_ID);
{ when the first variable had been read the next declaration could be
a "generic procedure", "generic function" or
"generic class (function/procedure)" }
if not first
and isgeneric
and (sc.count=1)
and (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
begin
vs.free;
sc.clear;
had_generic:=true;
break;
end
else
begin
vs.register_sym;
symtablestack.top.insert(vs);
if isgeneric then
begin
{ ensure correct error position }
old_current_filepos:=current_filepos;
current_filepos:=tmp_filepos;
symtablestack.top.insert(vs);
current_filepos:=old_current_filepos;
end;
end;
until not try_to_consume(_COMMA); until not try_to_consume(_COMMA);
if had_generic then
break;
{ read variable type def } { read variable type def }
block_type:=bt_var_type; block_type:=bt_var_type;
consume(_COLON); consume(_COLON);
@ -1445,6 +1486,8 @@ implementation
not(vo_is_external in vs.varoptions) then not(vo_is_external in vs.varoptions) then
cnodeutils.insertbssdata(tstaticvarsym(vs)); cnodeutils.insertbssdata(tstaticvarsym(vs));
end; end;
first:=false;
end; end;
block_type:=old_block_type; block_type:=old_block_type;
{ free the list } { free the list }
@ -1452,7 +1495,7 @@ implementation
end; end;
procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc : ppvariantrecdesc); procedure read_record_fields(options:Tvar_dec_options; reorderlist: TFPObjectList; variantdesc : ppvariantrecdesc;out had_generic:boolean);
var var
sc : TFPObjectList; sc : TFPObjectList;
i : longint; i : longint;
@ -1478,6 +1521,7 @@ implementation
uniondef : trecorddef; uniondef : trecorddef;
hintsymoptions : tsymoptions; hintsymoptions : tsymoptions;
deprecatedmsg : pshortstring; deprecatedmsg : pshortstring;
hadgendummy,
semicoloneaten, semicoloneaten,
removeclassoption: boolean; removeclassoption: boolean;
{$if defined(powerpc) or defined(powerpc64)} {$if defined(powerpc) or defined(powerpc64)}
@ -1498,6 +1542,7 @@ implementation
{ read vars } { read vars }
sc:=TFPObjectList.create(false); sc:=TFPObjectList.create(false);
removeclassoption:=false; removeclassoption:=false;
had_generic:=false;
while (token=_ID) and while (token=_ID) and
not(((vd_object in options) or not(((vd_object in options) or
((vd_record in options) and (m_advanced_records in current_settings.modeswitches))) and ((vd_record in options) and (m_advanced_records in current_settings.modeswitches))) and
@ -1512,22 +1557,39 @@ implementation
sorg:=orgpattern; sorg:=orgpattern;
if token=_ID then if token=_ID then
begin begin
vs:=cfieldvarsym.create(sorg,vs_value,generrordef,[],true); vs:=cfieldvarsym.create(sorg,vs_value,generrordef,[],false);
{ normally the visibility is set via addfield, but sometimes { normally the visibility is set via addfield, but sometimes
we collect symbols so we can add them in a batch of we collect symbols so we can add them in a batch of
potentially mixed visibility, and then the individual potentially mixed visibility, and then the individual
symbols need to have their visibility already set } symbols need to have their visibility already set }
vs.visibility:=visibility; vs.visibility:=visibility;
if (vd_check_generic in options) and (idtoken=_GENERIC) then
had_generic:=true;
end
else
vs:=nil;
consume(_ID);
if assigned(vs) and
(
not had_generic or
not (token in [_PROCEDURE,_FUNCTION,_CLASS])
) then
begin
vs.register_sym;
sc.add(vs); sc.add(vs);
recst.insert(vs); recst.insert(vs);
end; had_generic:=false;
consume(_ID); end
else
vs.free;
until not try_to_consume(_COMMA); until not try_to_consume(_COMMA);
if m_delphi in current_settings.modeswitches then if m_delphi in current_settings.modeswitches then
block_type:=bt_var_type block_type:=bt_var_type
else else
block_type:=old_block_type; block_type:=old_block_type;
if had_generic and (sc.count=0) then
break;
consume(_COLON); consume(_COLON);
read_anon_type(hdef,false); read_anon_type(hdef,false);
@ -1802,7 +1864,7 @@ implementation
consume(_LKLAMMER); consume(_LKLAMMER);
inc(variantrecordlevel); inc(variantrecordlevel);
if token<>_RKLAMMER then if token<>_RKLAMMER then
read_record_fields([vd_record],nil,@variantdesc^^.branches[high(variantdesc^^.branches)].nestedvariant); read_record_fields([vd_record],nil,@variantdesc^^.branches[high(variantdesc^^.branches)].nestedvariant,hadgendummy);
dec(variantrecordlevel); dec(variantrecordlevel);
consume(_RKLAMMER); consume(_RKLAMMER);

131
compiler/psub.pas
View File

@ -83,7 +83,7 @@ interface
{ reads any routine in the implementation, or a non-method routine { reads any routine in the implementation, or a non-method routine
declaration in the interface (depending on whether or not parse_only is declaration in the interface (depending on whether or not parse_only is
true) } true) }
procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef); procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
procedure generate_specialization_procs; procedure generate_specialization_procs;
@ -2033,7 +2033,7 @@ implementation
end; end;
procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef); procedure read_proc(isclassmethod:boolean; usefwpd: tprocdef;isgeneric:boolean);
{ {
Parses the procedure directives, then parses the procedure body, then Parses the procedure directives, then parses the procedure body, then
generates the code for it generates the code for it
@ -2062,7 +2062,7 @@ implementation
if not assigned(usefwpd) then if not assigned(usefwpd) then
{ parse procedure declaration } { parse procedure declaration }
pd:=parse_proc_dec(isclassmethod,old_current_structdef) pd:=parse_proc_dec(isclassmethod,old_current_structdef,isgeneric)
else else
pd:=usefwpd; pd:=usefwpd;
@ -2224,24 +2224,52 @@ implementation
procedure read_declarations(islibrary : boolean); procedure read_declarations(islibrary : boolean);
var
hadgeneric : boolean;
procedure handle_unexpected_had_generic;
begin
if hadgeneric then
begin
Message(parser_e_procedure_or_function_expected);
hadgeneric:=false;
end;
end;
var var
is_classdef:boolean; is_classdef:boolean;
begin begin
is_classdef:=false; is_classdef:=false;
hadgeneric:=false;
repeat repeat
if not assigned(current_procinfo) then if not assigned(current_procinfo) then
internalerror(200304251); internalerror(200304251);
case token of case token of
_LABEL: _LABEL:
label_dec; begin
handle_unexpected_had_generic;
label_dec;
end;
_CONST: _CONST:
const_dec; begin
handle_unexpected_had_generic;
const_dec(hadgeneric);
end;
_TYPE: _TYPE:
type_dec; begin
handle_unexpected_had_generic;
type_dec(hadgeneric);
end;
_VAR: _VAR:
var_dec; begin
handle_unexpected_had_generic;
var_dec(hadgeneric);
end;
_THREADVAR: _THREADVAR:
threadvar_dec; begin
handle_unexpected_had_generic;
threadvar_dec(hadgeneric);
end;
_CLASS: _CLASS:
begin begin
is_classdef:=false; is_classdef:=false;
@ -2266,11 +2294,18 @@ implementation
_PROCEDURE, _PROCEDURE,
_OPERATOR: _OPERATOR:
begin begin
read_proc(is_classdef,nil); if hadgeneric and not (token in [_PROCEDURE,_FUNCTION]) then
begin
Message(parser_e_procedure_or_function_expected);
hadgeneric:=false;
end;
read_proc(is_classdef,nil,hadgeneric);
is_classdef:=false; is_classdef:=false;
hadgeneric:=false;
end; end;
_EXPORTS: _EXPORTS:
begin begin
handle_unexpected_had_generic;
if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then if (current_procinfo.procdef.localst.symtablelevel>main_program_level) then
begin begin
Message(parser_e_syntax_error); Message(parser_e_syntax_error);
@ -2287,6 +2322,7 @@ implementation
end; end;
_PROPERTY: _PROPERTY:
begin begin
handle_unexpected_had_generic;
if (m_fpc in current_settings.modeswitches) then if (m_fpc in current_settings.modeswitches) then
property_dec property_dec
else else
@ -2297,23 +2333,36 @@ implementation
case idtoken of case idtoken of
_RESOURCESTRING: _RESOURCESTRING:
begin begin
handle_unexpected_had_generic;
{ m_class is needed, because the resourcestring { m_class is needed, because the resourcestring
loading is in the ObjPas unit } loading is in the ObjPas unit }
{ if (m_class in current_settings.modeswitches) then} { if (m_class in current_settings.modeswitches) then}
resourcestring_dec resourcestring_dec(hadgeneric)
{ else { else
break;} break;}
end; end;
_OPERATOR: _OPERATOR:
begin begin
handle_unexpected_had_generic;
if is_classdef then if is_classdef then
begin begin
read_proc(is_classdef,nil); read_proc(is_classdef,nil,false);
is_classdef:=false; is_classdef:=false;
end end
else else
break; break;
end; end;
_GENERIC:
begin
handle_unexpected_had_generic;
if not (m_delphi in current_settings.modeswitches) then
begin
consume(_ID);
hadgeneric:=true;
end
else
break;
end
else else
break; break;
end; end;
@ -2335,33 +2384,81 @@ implementation
procedure read_interface_declarations; procedure read_interface_declarations;
var
hadgeneric : boolean;
procedure handle_unexpected_had_generic;
begin
if hadgeneric then
begin
Message(parser_e_procedure_or_function_expected);
hadgeneric:=false;
end;
end;
begin begin
hadgeneric:=false;
repeat repeat
case token of case token of
_CONST : _CONST :
const_dec; begin
handle_unexpected_had_generic;
const_dec(hadgeneric);
end;
_TYPE : _TYPE :
type_dec; begin
handle_unexpected_had_generic;
type_dec(hadgeneric);
end;
_VAR : _VAR :
var_dec; begin
handle_unexpected_had_generic;
var_dec(hadgeneric);
end;
_THREADVAR : _THREADVAR :
threadvar_dec; begin
handle_unexpected_had_generic;
threadvar_dec(hadgeneric);
end;
_FUNCTION, _FUNCTION,
_PROCEDURE, _PROCEDURE,
_OPERATOR : _OPERATOR :
read_proc(false,nil); begin
if hadgeneric and not (token in [_FUNCTION, _PROCEDURE]) then
begin
message(parser_e_procedure_or_function_expected);
hadgeneric:=false;
end;
read_proc(false,nil,hadgeneric);
hadgeneric:=false;
end;
else else
begin begin
case idtoken of case idtoken of
_RESOURCESTRING : _RESOURCESTRING :
resourcestring_dec; begin
handle_unexpected_had_generic;
resourcestring_dec(hadgeneric);
end;
_PROPERTY: _PROPERTY:
begin begin
handle_unexpected_had_generic;
if (m_fpc in current_settings.modeswitches) then if (m_fpc in current_settings.modeswitches) then
property_dec property_dec
else else
break; break;
end; end;
_GENERIC:
begin
handle_unexpected_had_generic;
if not (m_delphi in current_settings.modeswitches) then
begin
hadgeneric:=true;
consume(_ID);
end
else
break;
end
else else
break; break;
end; end;

47
compiler/ptype.pas
View File

@ -654,6 +654,7 @@ implementation
pd : tprocdef; pd : tprocdef;
oldparse_only: boolean; oldparse_only: boolean;
member_blocktype : tblock_type; member_blocktype : tblock_type;
hadgeneric,
fields_allowed, is_classdef, classfields: boolean; fields_allowed, is_classdef, classfields: boolean;
vdoptions: tvar_dec_options; vdoptions: tvar_dec_options;
begin begin
@ -672,6 +673,7 @@ implementation
current_structdef.symtable.currentvisibility:=vis_public; current_structdef.symtable.currentvisibility:=vis_public;
fields_allowed:=true; fields_allowed:=true;
is_classdef:=false; is_classdef:=false;
hadgeneric:=false;
classfields:=false; classfields:=false;
member_blocktype:=bt_general; member_blocktype:=bt_general;
repeat repeat
@ -779,7 +781,7 @@ implementation
else else
if is_classdef and (idtoken=_OPERATOR) then if is_classdef and (idtoken=_OPERATOR) then
begin begin
pd:=parse_record_method_dec(current_structdef,is_classdef); pd:=parse_record_method_dec(current_structdef,is_classdef,false);
fields_allowed:=false; fields_allowed:=false;
is_classdef:=false; is_classdef:=false;
end end
@ -787,17 +789,33 @@ implementation
begin begin
if member_blocktype=bt_general then if member_blocktype=bt_general then
begin begin
if (not fields_allowed)and(idtoken<>_CASE) then if (idtoken=_GENERIC) and
Message(parser_e_field_not_allowed_here); not (m_delphi in current_settings.modeswitches) and
vdoptions:=[vd_record]; not fields_allowed then
if classfields then begin
include(vdoptions,vd_class); if hadgeneric then
read_record_fields(vdoptions,nil,nil); Message(parser_e_procedure_or_function_expected);
consume(_ID);
hadgeneric:=true;
if not (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
Message(parser_e_procedure_or_function_expected);
end
else
begin
if (not fields_allowed)and(idtoken<>_CASE) then
Message(parser_e_field_not_allowed_here);
vdoptions:=[vd_record];
if classfields then
include(vdoptions,vd_class);
if not (m_delphi in current_settings.modeswitches) then
include(vdoptions,vd_check_generic);
read_record_fields(vdoptions,nil,nil,hadgeneric);
end;
end end
else if member_blocktype=bt_type then else if member_blocktype=bt_type then
types_dec(true) types_dec(true,hadgeneric)
else if member_blocktype=bt_const then else if member_blocktype=bt_const then
consts_dec(true,true) consts_dec(true,true,hadgeneric)
else else
internalerror(201001110); internalerror(201001110);
end; end;
@ -818,8 +836,9 @@ implementation
consume(_CLASS); consume(_CLASS);
{ class modifier is only allowed for procedures, functions, } { class modifier is only allowed for procedures, functions, }
{ constructors, destructors, fields and properties } { constructors, destructors, fields and properties }
if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and if (hadgeneric and not (token in [_FUNCTION,_PROCEDURE])) or
not((token=_ID) and (idtoken=_OPERATOR)) then (not hadgeneric and (not (token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
not((token=_ID) and (idtoken=_OPERATOR)))) then
Message(parser_e_procedure_or_function_expected); Message(parser_e_procedure_or_function_expected);
if IsAnonOrLocal then if IsAnonOrLocal then
@ -832,7 +851,8 @@ implementation
begin begin
if IsAnonOrLocal then if IsAnonOrLocal then
Message(parser_e_no_methods_in_local_anonymous_records); Message(parser_e_no_methods_in_local_anonymous_records);
pd:=parse_record_method_dec(current_structdef,is_classdef); pd:=parse_record_method_dec(current_structdef,is_classdef,hadgeneric);
hadgeneric:=false;
fields_allowed:=false; fields_allowed:=false;
is_classdef:=false; is_classdef:=false;
end; end;
@ -909,6 +929,7 @@ implementation
old_current_specializedef: tstoreddef; old_current_specializedef: tstoreddef;
old_parse_generic: boolean; old_parse_generic: boolean;
recst: trecordsymtable; recst: trecordsymtable;
hadgendummy : boolean;
begin begin
old_current_structdef:=current_structdef; old_current_structdef:=current_structdef;
old_current_genericdef:=current_genericdef; old_current_genericdef:=current_genericdef;
@ -971,7 +992,7 @@ implementation
end end
else else
begin begin
read_record_fields([vd_record],nil,nil); read_record_fields([vd_record],nil,nil,hadgendummy);
{$ifdef jvm} {$ifdef jvm}
{ we need a constructor to create temps, a deep copy helper, ... } { we need a constructor to create temps, a deep copy helper, ... }
add_java_default_record_methods_intf(trecorddef(current_structdef)); add_java_default_record_methods_intf(trecorddef(current_structdef));

6
compiler/symcreat.pas
View File

@ -207,9 +207,9 @@ implementation
pd:=destructor_head; pd:=destructor_head;
else if assigned(astruct) and else if assigned(astruct) and
(astruct.typ=recorddef) then (astruct.typ=recorddef) then
pd:=parse_record_method_dec(astruct,is_classdef) pd:=parse_record_method_dec(astruct,is_classdef,false)
else else
pd:=method_dec(astruct,is_classdef); pd:=method_dec(astruct,is_classdef,false);
end; end;
if assigned(pd) then if assigned(pd) then
result:=true; result:=true;
@ -247,7 +247,7 @@ implementation
current_scanner.substitutemacro('meth_impl_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index); current_scanner.substitutemacro('meth_impl_macro',@str[1],length(str),current_scanner.line_no,current_scanner.inputfile.ref_index);
current_scanner.readtoken(false); current_scanner.readtoken(false);
{ and parse it... } { and parse it... }
read_proc(is_classdef,usefwpd); read_proc(is_classdef,usefwpd,false);
parse_only:=oldparse_only; parse_only:=oldparse_only;
{ remove the temporary macro input file again } { remove the temporary macro input file again }
current_scanner.closeinputfile; current_scanner.closeinputfile;