paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-13 17:59:27 +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;
procedure const_dec;
procedure consts_dec(in_structure, allow_typed_const: boolean);
procedure const_dec(out had_generic:boolean);
procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
procedure label_dec;
procedure type_dec;
procedure types_dec(in_structure: boolean);
procedure var_dec;
procedure threadvar_dec;
procedure type_dec(out had_generic:boolean);
procedure types_dec(in_structure: boolean;out had_generic:boolean);
procedure var_dec(out had_generic:boolean);
procedure threadvar_dec(out had_generic:boolean);
procedure property_dec;
procedure resourcestring_dec;
procedure resourcestring_dec(out had_generic:boolean);
implementation
@ -181,13 +181,13 @@ implementation
readconstant:=hp;
end;
procedure const_dec;
procedure const_dec(out had_generic:boolean);
begin
consume(_CONST);
consts_dec(false,true);
consts_dec(false,true,had_generic);
end;
procedure consts_dec(in_structure, allow_typed_const: boolean);
procedure consts_dec(in_structure, allow_typed_const: boolean;out had_generic:boolean);
var
orgname : TIDString;
hdef : tdef;
@ -197,15 +197,20 @@ implementation
storetokenpos,filepos : tfileposinfo;
nodetype : tnodetype;
old_block_type : tblock_type;
first,
isgeneric,
skipequal : boolean;
tclist : tasmlist;
varspez : tvarspez;
begin
old_block_type:=block_type;
block_type:=bt_const;
had_generic:=false;
first:=true;
repeat
orgname:=orgpattern;
filepos:=current_tokenpos;
isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
consume(_ID);
case token of
@ -314,9 +319,17 @@ implementation
end;
else
{ generate an error }
consume(_EQ);
if not first and isgeneric and (token in [_PROCEDURE,_FUNCTION,_CLASS]) then
begin
had_generic:=true;
break;
end
else
{ generate an error }
consume(_EQ);
end;
first:=false;
until (token<>_ID) or
(in_structure and
((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
@ -367,7 +380,7 @@ implementation
consume(_SEMICOLON);
end;
procedure types_dec(in_structure: boolean);
procedure types_dec(in_structure: boolean;out had_generic:boolean);
function determine_generic_def(name:tidstring):tstoreddef;
var
@ -435,6 +448,7 @@ implementation
old_block_type : tblock_type;
old_checkforwarddefs: TFPObjectList;
objecttype : tobjecttyp;
first,
isgeneric,
isunique,
istyperenaming : boolean;
@ -456,6 +470,7 @@ implementation
current_module.checkforwarddefs:=TFPObjectList.Create(false);
block_type:=bt_type;
hdef:=nil;
first:=true;
repeat
defpos:=current_tokenpos;
istyperenaming:=false;
@ -463,7 +478,9 @@ implementation
generictokenbuf:=nil;
{ 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;
orgtypename:=orgpattern;
@ -897,6 +914,18 @@ implementation
hdef.typesym:=newtype;
generictypelist.free;
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
(in_structure and
((idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]) or
@ -912,19 +941,19 @@ implementation
{ reads a type declaration to the symbol table }
procedure type_dec;
procedure type_dec(out had_generic:boolean);
begin
consume(_TYPE);
types_dec(false);
types_dec(false,had_generic);
end;
procedure var_dec;
procedure var_dec(out had_generic:boolean);
{ parses variable declarations and inserts them in }
{ the top symbol table of symtablestack }
begin
consume(_VAR);
read_var_decls([]);
read_var_decls([vd_check_generic],had_generic);
end;
@ -946,7 +975,7 @@ implementation
end;
procedure threadvar_dec;
procedure threadvar_dec(out had_generic:boolean);
{ parses thread variable declarations and inserts them in }
{ the top symbol table of symtablestack }
begin
@ -954,16 +983,16 @@ implementation
if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_threadvars_only_sg);
if f_threading in features then
read_var_decls([vd_threadvar])
read_var_decls([vd_threadvar,vd_check_generic],had_generic)
else
begin
Message1(parser_f_unsupported_feature,featurestr[f_threading]);
read_var_decls([]);
read_var_decls([vd_check_generic],had_generic);
end;
end;
procedure resourcestring_dec;
procedure resourcestring_dec(out had_generic:boolean);
var
orgname : TIDString;
p : tnode;
@ -973,17 +1002,22 @@ implementation
old_block_type : tblock_type;
sp : pchar;
sym : tsym;
first,
isgeneric : boolean;
begin
if target_info.system in systems_managed_vm then
message(parser_e_feature_unsupported_for_vm);
consume(_RESOURCESTRING);
if not(symtablestack.top.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_resourcestring_only_sg);
first:=true;
had_generic:=false;
old_block_type:=block_type;
block_type:=bt_const;
repeat
orgname:=orgpattern;
filepos:=current_tokenpos;
isgeneric:=not (m_delphi in current_settings.modeswitches) and (token=_ID) and (idtoken=_GENERIC);
consume(_ID);
case token of
_EQ:
@ -1035,8 +1069,17 @@ implementation
consume(_SEMICOLON);
p.free;
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;
first:=false;
until token<>_ID;
block_type:=old_block_type;
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;
{ 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_destructor_head(astruct: tabstractrecorddef):tprocdef;
@ -810,7 +810,7 @@ implementation
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);
begin
@ -874,7 +874,7 @@ implementation
oldparse_only:=parse_only;
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 }
{ interface mappings, i.e. mapping to a method }
@ -1019,6 +1019,7 @@ implementation
var
typedconstswritable: boolean;
object_member_blocktype : tblock_type;
hadgeneric,
fields_allowed, is_classdef, class_fields, is_final, final_fields: boolean;
vdoptions: tvar_dec_options;
fieldlist: tfpobjectlist;
@ -1114,6 +1115,7 @@ implementation
class_fields:=false;
is_final:=false;
final_fields:=false;
hadgeneric:=false;
object_member_blocktype:=bt_general;
fieldlist:=tfpobjectlist.create(false);
repeat
@ -1214,33 +1216,49 @@ implementation
begin
if object_member_blocktype=bt_general then
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 (idtoken=_GENERIC) and
not (m_delphi in current_settings.modeswitches) and
not fields_allowed then
begin
if hadgeneric then
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 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
not(oo_can_have_published in current_structdef.objectoptions) then
Message(parser_e_cant_have_published);
if (not fields_allowed) then
Message(parser_e_field_not_allowed_here);
if (current_structdef.symtable.currentvisibility=vis_published) and
not(oo_can_have_published in current_structdef.objectoptions) then
Message(parser_e_cant_have_published);
if (not fields_allowed) then
Message(parser_e_field_not_allowed_here);
vdoptions:=[vd_object];
if class_fields then
include(vdoptions,vd_class);
if is_class(current_structdef) then
include(vdoptions,vd_canreorder);
if final_fields then
include(vdoptions,vd_final);
read_record_fields(vdoptions,fieldlist,nil);
vdoptions:=[vd_object];
if not (m_delphi in current_settings.modeswitches) then
include(vdoptions,vd_check_generic);
if class_fields then
include(vdoptions,vd_class);
if is_class(current_structdef) then
include(vdoptions,vd_canreorder);
if final_fields then
include(vdoptions,vd_final);
read_record_fields(vdoptions,fieldlist,nil,hadgeneric);
end;
end
else if object_member_blocktype=bt_type then
types_dec(true)
types_dec(true,hadgeneric)
else if object_member_blocktype=bt_const then
begin
typedconstswritable:=false;
@ -1251,7 +1269,7 @@ implementation
typedconstswritable:=cs_typed_const_writable in current_settings.localswitches;
exclude(current_settings.localswitches,cs_typed_const_writable);
end;
consts_dec(true,not is_javainterface(current_structdef));
consts_dec(true,not is_javainterface(current_structdef),hadgeneric);
if final_fields and
typedconstswritable then
include(current_settings.localswitches,cs_typed_const_writable);
@ -1276,9 +1294,10 @@ implementation
_CONSTRUCTOR,
_DESTRUCTOR :
begin
method_dec(current_structdef,is_classdef);
method_dec(current_structdef,is_classdef,hadgeneric);
fields_allowed:=false;
is_classdef:=false;
hadgeneric:=false;
end;
_END :
begin

14
compiler/pdecsub.pas
View File

@ -78,11 +78,11 @@ interface
procedure parse_object_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_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);
{ 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);
@ -1457,7 +1457,7 @@ implementation
end;
end;
function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef):tprocdef;
function parse_proc_dec(isclassmethod:boolean;astruct:tabstractrecorddef;isgeneric:boolean):tprocdef;
var
pd : tprocdef;
old_block_type : tblock_type;
@ -1480,7 +1480,7 @@ implementation
_FUNCTION :
begin
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
{ pd=nil when it is a interface mapping }
if assigned(pd) then
@ -1500,7 +1500,7 @@ implementation
_PROCEDURE :
begin
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
{ pd=nil when it is an interface mapping }
if assigned(pd) then
@ -1578,13 +1578,13 @@ implementation
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
oldparse_only: boolean;
begin
oldparse_only:=parse_only;
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 }
{ interface mappings, i.e. mapping to a method }

88
compiler/pdecvar.pas
View File

@ -31,14 +31,14 @@ interface
symtable,symsym,symdef;
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;
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);
@ -1050,7 +1050,7 @@ implementation
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);
var
@ -1266,6 +1266,8 @@ implementation
vs : tabstractvarsym;
hdef : tdef;
i : longint;
first,
isgeneric,
semicoloneaten,
allowdefaultvalue,
hasdefaultvalue : boolean;
@ -1273,6 +1275,8 @@ implementation
deprecatedmsg : pshortstring;
old_block_type : tblock_type;
sectionname : ansistring;
tmp_filepos,
old_current_filepos : tfileposinfo;
begin
old_block_type:=block_type;
block_type:=bt_var;
@ -1281,6 +1285,8 @@ implementation
consume(_ID);
{ read vars }
sc:=TFPObjectList.create(false);
first:=true;
had_generic:=false;
while (token=_ID) do
begin
semicoloneaten:=false;
@ -1290,13 +1296,16 @@ implementation
repeat
if (token = _ID) then
begin
isgeneric:=(vd_check_generic in options) and
not (m_delphi in current_settings.modeswitches) and
(idtoken=_GENERIC);
case symtablestack.top.symtabletype of
localsymtable :
vs:=clocalvarsym.create(orgpattern,vs_value,generrordef,[],true);
vs:=clocalvarsym.create(orgpattern,vs_value,generrordef,[],false);
staticsymtable,
globalsymtable :
begin
vs:=cstaticvarsym.create(orgpattern,vs_value,generrordef,[],true);
vs:=cstaticvarsym.create(orgpattern,vs_value,generrordef,[],false);
if vd_threadvar in options then
include(vs.varoptions,vo_is_thread_var);
end;
@ -1304,11 +1313,43 @@ implementation
internalerror(200411064);
end;
sc.add(vs);
symtablestack.top.insert(vs);
end;
if isgeneric then
tmp_filepos:=current_filepos;
end
else
isgeneric:=false;
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);
if had_generic then
break;
{ read variable type def }
block_type:=bt_var_type;
consume(_COLON);
@ -1445,6 +1486,8 @@ implementation
not(vo_is_external in vs.varoptions) then
cnodeutils.insertbssdata(tstaticvarsym(vs));
end;
first:=false;
end;
block_type:=old_block_type;
{ free the list }
@ -1452,7 +1495,7 @@ implementation
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
sc : TFPObjectList;
i : longint;
@ -1478,6 +1521,7 @@ implementation
uniondef : trecorddef;
hintsymoptions : tsymoptions;
deprecatedmsg : pshortstring;
hadgendummy,
semicoloneaten,
removeclassoption: boolean;
{$if defined(powerpc) or defined(powerpc64)}
@ -1498,6 +1542,7 @@ implementation
{ read vars }
sc:=TFPObjectList.create(false);
removeclassoption:=false;
had_generic:=false;
while (token=_ID) and
not(((vd_object in options) or
((vd_record in options) and (m_advanced_records in current_settings.modeswitches))) and
@ -1512,22 +1557,39 @@ implementation
sorg:=orgpattern;
if token=_ID then
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
we collect symbols so we can add them in a batch of
potentially mixed visibility, and then the individual
symbols need to have their visibility already set }
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);
recst.insert(vs);
end;
consume(_ID);
had_generic:=false;
end
else
vs.free;
until not try_to_consume(_COMMA);
if m_delphi in current_settings.modeswitches then
block_type:=bt_var_type
else
block_type:=old_block_type;
if had_generic and (sc.count=0) then
break;
consume(_COLON);
read_anon_type(hdef,false);
@ -1802,7 +1864,7 @@ implementation
consume(_LKLAMMER);
inc(variantrecordlevel);
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);
consume(_RKLAMMER);

131
compiler/psub.pas
View File

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

47
compiler/ptype.pas
View File

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

6
compiler/symcreat.pas
View File

@ -207,9 +207,9 @@ implementation
pd:=destructor_head;
else if assigned(astruct) and
(astruct.typ=recorddef) then
pd:=parse_record_method_dec(astruct,is_classdef)
pd:=parse_record_method_dec(astruct,is_classdef,false)
else
pd:=method_dec(astruct,is_classdef);
pd:=method_dec(astruct,is_classdef,false);
end;
if assigned(pd) then
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.readtoken(false);
{ and parse it... }
read_proc(is_classdef,usefwpd);
read_proc(is_classdef,usefwpd,false);
parse_only:=oldparse_only;
{ remove the temporary macro input file again }
current_scanner.closeinputfile;