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

* global property support for fpc modes

Browse Source
This commit is contained in:
peter 2003-12-10 16:37:01 +00:00
parent a42f9109c0
commit 5090185909
4 changed files with 563 additions and 491 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
compiler/pdecl.pas
View File

@ -41,6 +41,7 @@ interface
procedure type_dec;
procedure var_dec;
procedure threadvar_dec;
procedure property_dec;
procedure resourcestring_dec;
implementation
@ -564,6 +565,23 @@ implementation
end;
procedure property_dec;
var
old_block_type : tblock_type;
begin
consume(_PROPERTY);
if not(symtablestack.symtabletype in [staticsymtable,globalsymtable]) then
message(parser_e_resourcestring_only_sg);
old_block_type:=block_type;
block_type:=bt_const;
repeat
read_property_dec(nil);
consume(_SEMICOLON);
until token<>_ID;
block_type:=old_block_type;
end;
procedure threadvar_dec;
{ parses thread variable declarations and inserts them in }
{ the top symbol table of symtablestack }
@ -637,7 +655,10 @@ implementation
end.
{
$Log$
Revision 1.72 2003-11-12 15:48:48 peter
Revision 1.73 2003-12-10 16:37:01 peter
* global property support for fpc modes
Revision 1.72 2003/11/12 15:48:48 peter
* don't give redefinition warning for forward classes
Revision 1.71 2003/10/03 14:45:09 peter

477
compiler/pdecobj.pas
View File

@ -85,489 +85,23 @@ implementation
procedure property_dec;
{ convert a node tree to symlist and return the last
symbol }
function parse_symlist(pl:tsymlist;var def:tdef):boolean;
var
idx : longint;
sym : tsym;
st : tsymtable;
begin
result:=true;
def:=nil;
if token=_ID then
begin
sym:=search_class_member(aktclass,pattern);
if assigned(sym) then
begin
case sym.typ of
varsym :
begin
pl.addsym(sl_load,sym);
def:=tvarsym(sym).vartype.def;
end;
procsym :
begin
pl.addsym(sl_call,sym);
end;
end;
end
else
begin
Message1(parser_e_illegal_field_or_method,pattern);
result:=false;
end;
consume(_ID);
repeat
case token of
_ID,
_SEMICOLON :
begin
break;
end;
_POINT :
begin
consume(_POINT);
if assigned(def) then
begin
st:=def.getsymtable(gs_record);
if assigned(st) then
begin
sym:=searchsymonlyin(st,pattern);
if assigned(sym) then
begin
pl.addsym(sl_subscript,sym);
case sym.typ of
varsym :
def:=tvarsym(sym).vartype.def;
else
begin
Message1(sym_e_illegal_field,pattern);
result:=false;
end;
end;
end
else
begin
Message1(sym_e_illegal_field,pattern);
result:=false;
end;
end
else
begin
Message(cg_e_invalid_qualifier);
result:=false;
end;
end
else
begin
Message(cg_e_invalid_qualifier);
result:=false;
end;
consume(_ID);
end;
_LECKKLAMMER :
begin
consume(_LECKKLAMMER);
repeat
if def.deftype=arraydef then
begin
idx:=get_intconst;
pl.addconst(sl_vec,idx);
def:=tarraydef(def).elementtype.def;
end
else
begin
Message(cg_e_invalid_qualifier);
result:=false;
end;
until not try_to_consume(_COMMA);
consume(_RECKKLAMMER);
end;
else
begin
Message(parser_e_ill_property_access_sym);
result:=false;
break;
end;
end;
until false;
end
else
begin
Message(parser_e_ill_property_access_sym);
result:=false;
end;
end;
var
sym : tsym;
p : tpropertysym;
overriden : tsym;
hs : string;
varspez : tvarspez;
s : string;
tt : ttype;
arraytype : ttype;
def : tdef;
pt : tnode;
propname : stringid;
sc : tsinglelist;
oldregisterdef : boolean;
readvs,
hvs : tvarsym;
readprocdef,
writeprocdef : tprocvardef;
p : tpropertysym;
begin
{ check for a class }
if not((is_class_or_interface(aktclass)) or
((m_delphi in aktmodeswitches) and (is_object(aktclass)))) then
Message(parser_e_syntax_error);
consume(_PROPERTY);
{ Generate temp procvardefs to search for matching read/write
procedures. the readprocdef will store all definitions }
oldregisterdef:=registerdef;
registerdef:=false;
readprocdef:=tprocvardef.create(normal_function_level);
include(readprocdef.procoptions,po_methodpointer);
writeprocdef:=tprocvardef.create(normal_function_level);
include(writeprocdef.procoptions,po_methodpointer);
registerdef:=oldregisterdef;
if token<>_ID then
begin
consume(_ID);
consume(_SEMICOLON);
exit;
end;
{ Generate propertysym and insert in symtablestack }
p:=tpropertysym.create(orgpattern);
symtablestack.insert(p);
propname:=pattern;
consume(_ID);
{ Set the symtablestack to the parast of readprop so
temp defs will be destroyed after declaration }
readprocdef.parast.next:=symtablestack;
symtablestack:=readprocdef.parast;
{ property parameters ? }
if token=_LECKKLAMMER then
begin
if (sp_published in current_object_option) then
Message(parser_e_cant_publish_that_property);
{ create a list of the parameters }
sc:=tsinglelist.create;
consume(_LECKKLAMMER);
inc(testcurobject);
repeat
if token=_VAR then
begin
consume(_VAR);
varspez:=vs_var;
end
else if token=_CONST then
begin
consume(_CONST);
varspez:=vs_const;
end
else if (idtoken=_OUT) and (m_out in aktmodeswitches) then
begin
consume(_OUT);
varspez:=vs_out;
end
else
varspez:=vs_value;
sc.reset;
repeat
readvs:=tvarsym.create(orgpattern,varspez,generrortype);
readprocdef.parast.insert(readvs);
sc.insert(readvs);
consume(_ID);
until not try_to_consume(_COMMA);
if token=_COLON then
begin
consume(_COLON);
if token=_ARRAY then
begin
consume(_ARRAY);
consume(_OF);
{ define range and type of range }
tt.setdef(tarraydef.create(0,-1,s32bittype));
{ define field type }
single_type(arraytype,s,false);
tarraydef(tt.def).setelementtype(arraytype);
end
else
single_type(tt,s,false);
end
else
tt:=cformaltype;
readvs:=tvarsym(sc.first);
while assigned(readvs) do
begin
readprocdef.concatpara(nil,tt,readvs,nil,false);
{ also update the writeprocdef }
hvs:=tvarsym.create(readvs.realname,vs_value,generrortype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,tt,hvs,nil,false);
readvs:=tvarsym(readvs.listnext);
end;
until not try_to_consume(_SEMICOLON);
sc.free;
dec(testcurobject);
consume(_RECKKLAMMER);
{ the parser need to know if a property has parameters, the
index parameter doesn't count (PFV) }
if readprocdef.minparacount>0 then
include(p.propoptions,ppo_hasparameters);
end;
{ overriden property ? }
{ force property interface, if there is a property parameter }
if (token=_COLON) or (readprocdef.minparacount>0) then
begin
consume(_COLON);
single_type(p.proptype,hs,false);
if (idtoken=_INDEX) then
begin
consume(_INDEX);
pt:=comp_expr(true);
if is_constnode(pt) and
is_ordinal(pt.resulttype.def) and
(not is_64bitint(pt.resulttype.def)) then
p.index:=tordconstnode(pt).value
else
begin
Message(parser_e_invalid_property_index_value);
p.index:=0;
end;
p.indextype.setdef(pt.resulttype.def);
include(p.propoptions,ppo_indexed);
{ concat a longint to the para templates }
hvs:=tvarsym.create('$index',vs_value,p.indextype);
readprocdef.parast.insert(hvs);
readprocdef.concatpara(nil,p.indextype,hvs,nil,false);
hvs:=tvarsym.create('$index',vs_value,p.indextype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,p.indextype,hvs,nil,false);
pt.free;
end;
end
else
begin
{ do an property override }
overriden:=search_class_member(aktclass.childof,propname);
if assigned(overriden) and (overriden.typ=propertysym) then
begin
p.dooverride(tpropertysym(overriden));
end
else
begin
p.proptype:=generrortype;
message(parser_e_no_property_found_to_override);
end;
end;
if (sp_published in current_object_option) and
not(p.proptype.def.is_publishable) then
Message(parser_e_cant_publish_that_property);
if try_to_consume(_READ) then
begin
p.readaccess.clear;
if parse_symlist(p.readaccess,def) then
begin
sym:=p.readaccess.firstsym^.sym;
case sym.typ of
procsym :
begin
{ read is function returning the type of the property }
readprocdef.rettype:=p.proptype;
{ Insert hidden parameters }
handle_calling_convention(readprocdef);
calc_parast(readprocdef);
{ search procdefs matching readprocdef }
p.readaccess.procdef:=Tprocsym(sym).search_procdef_bypara(readprocdef.para,p.proptype.def,[cpo_allowdefaults]);
if not assigned(p.readaccess.procdef) then
Message(parser_e_ill_property_access_sym);
end;
varsym :
begin
if not assigned(def) then
internalerror(200310071);
if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
begin
{ property parameters are allowed if this is
an indexed property, because the index is then
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) then
Message(parser_e_ill_property_access_sym);
end
else
IncompatibleTypes(def,p.proptype.def);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end;
end;
if try_to_consume(_WRITE) then
begin
p.writeaccess.clear;
if parse_symlist(p.writeaccess,def) then
begin
sym:=p.writeaccess.firstsym^.sym;
case sym.typ of
procsym :
begin
{ write is a procedure with an extra value parameter
of the of the property }
writeprocdef.rettype:=voidtype;
hvs:=tvarsym.create('$value',vs_value,p.proptype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,p.proptype,hvs,nil,false);
{ Insert hidden parameters }
handle_calling_convention(writeprocdef);
calc_parast(writeprocdef);
{ search procdefs matching writeprocdef }
p.writeaccess.procdef:=Tprocsym(sym).search_procdef_bypara(writeprocdef.para,writeprocdef.rettype.def,[cpo_allowdefaults]);
if not assigned(p.writeaccess.procdef) then
Message(parser_e_ill_property_access_sym);
end;
varsym :
begin
if not assigned(def) then
internalerror(200310072);
if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
begin
{ property parameters are allowed if this is
an indexed property, because the index is then
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) then
Message(parser_e_ill_property_access_sym);
end
else
IncompatibleTypes(def,p.proptype.def);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end;
end;
include(p.propoptions,ppo_stored);
if try_to_consume(_STORED) then
begin
p.storedaccess.clear;
case token of
_ID:
begin
{ in the case that idtoken=_DEFAULT }
{ we have to do nothing except }
{ setting ppo_stored, it's the same }
{ as stored true }
if idtoken<>_DEFAULT then
begin
if parse_symlist(p.storedaccess,def) then
begin
sym:=p.storedaccess.firstsym^.sym;
case sym.typ of
procsym :
begin
p.storedaccess.procdef:=Tprocsym(sym).search_procdef_nopara_boolret;
if not assigned(p.storedaccess.procdef) then
message(parser_e_ill_property_storage_sym);
end;
varsym :
begin
if not assigned(def) then
internalerror(200310073);
if (ppo_hasparameters in p.propoptions) or
not(is_boolean(def)) then
Message(parser_e_stored_property_must_be_boolean);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end;
end;
end;
_FALSE:
begin
consume(_FALSE);
exclude(p.propoptions,ppo_stored);
end;
_TRUE:
consume(_TRUE);
end;
end;
if try_to_consume(_DEFAULT) then
begin
if not(is_ordinal(p.proptype.def) or
is_64bitint(p.proptype.def) or
is_class(p.proptype.def) or
is_single(p.proptype.def) or
(p.proptype.def.deftype in [classrefdef,pointerdef]) or
((p.proptype.def.deftype=setdef) and
(tsetdef(p.proptype.def).settype=smallset))) or
((p.proptype.def.deftype=arraydef) and
(ppo_indexed in p.propoptions)) or
(ppo_hasparameters in p.propoptions) then
begin
Message(parser_e_property_cant_have_a_default_value);
{ Error recovery }
pt:=comp_expr(true);
pt.free;
end
else
begin
{ Get the result of the default, the firstpass is
needed to support values like -1 }
pt:=comp_expr(true);
if (p.proptype.def.deftype=setdef) and
(pt.nodetype=arrayconstructorn) then
begin
arrayconstructor_to_set(pt);
do_resulttypepass(pt);
end;
inserttypeconv(pt,p.proptype);
if not(is_constnode(pt)) then
Message(parser_e_property_default_value_must_const);
{ Set default value }
case pt.nodetype of
setconstn :
p.default:=plongint(tsetconstnode(pt).value_set)^;
ordconstn :
p.default:=tordconstnode(pt).value;
niln :
p.default:=0;
realconstn:
p.default:=longint(single(trealconstnode(pt).value_real));
end;
pt.free;
end;
end
else if try_to_consume(_NODEFAULT) then
begin
p.default:=0;
end;
p:=read_property_dec(aktclass);
consume(_SEMICOLON);
{ default property ? }
if try_to_consume(_DEFAULT) then
begin
include(p.propoptions,ppo_defaultproperty);
if readprocdef.maxparacount=0 then
if not(ppo_hasparameters in p.propoptions) then
message(parser_e_property_need_paras);
consume(_SEMICOLON);
end;
{ remove temporary procvardefs }
symtablestack:=symtablestack.next;
readprocdef.free;
writeprocdef.free;
end;
@ -1162,7 +696,10 @@ implementation
end.
{
$Log$
Revision 1.74 2003-12-04 23:27:49 peter
Revision 1.75 2003-12-10 16:37:01 peter
* global property support for fpc modes
Revision 1.74 2003/12/04 23:27:49 peter
* missing handle_calling_convention()
Revision 1.73 2003/11/10 18:06:25 florian

502
compiler/pdecvar.pas
View File

@ -27,6 +27,11 @@ unit pdecvar;
interface
uses
symsym,symdef;
function read_property_dec(aclass:tobjectdef):tpropertysym;
procedure read_var_decs(is_record,is_object,is_threadvar:boolean);
@ -39,10 +44,10 @@ implementation
globtype,globals,tokens,verbose,
systems,
{ symtable }
symconst,symbase,symtype,symdef,symsym,symtable,defutil,
symconst,symbase,symtype,symtable,defutil,defcmp,
fmodule,
{ pass 1 }
node,
node,pass_1,
nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,nmem,
{ codegen }
ncgutil,
@ -57,6 +62,494 @@ implementation
{$endif}
;
function read_property_dec(aclass:tobjectdef):tpropertysym;
{ convert a node tree to symlist and return the last
symbol }
function parse_symlist(pl:tsymlist;var def:tdef):boolean;
var
idx : longint;
sym : tsym;
srsymtable : tsymtable;
st : tsymtable;
begin
result:=true;
def:=nil;
if token=_ID then
begin
if assigned(aclass) then
sym:=search_class_member(aclass,pattern)
else
searchsym(pattern,sym,srsymtable);
if assigned(sym) then
begin
case sym.typ of
varsym :
begin
pl.addsym(sl_load,sym);
def:=tvarsym(sym).vartype.def;
end;
procsym :
begin
pl.addsym(sl_call,sym);
end;
end;
end
else
begin
Message1(parser_e_illegal_field_or_method,pattern);
result:=false;
end;
consume(_ID);
repeat
case token of
_ID,
_SEMICOLON :
begin
break;
end;
_POINT :
begin
consume(_POINT);
if assigned(def) then
begin
st:=def.getsymtable(gs_record);
if assigned(st) then
begin
sym:=searchsymonlyin(st,pattern);
if assigned(sym) then
begin
pl.addsym(sl_subscript,sym);
case sym.typ of
varsym :
def:=tvarsym(sym).vartype.def;
else
begin
Message1(sym_e_illegal_field,pattern);
result:=false;
end;
end;
end
else
begin
Message1(sym_e_illegal_field,pattern);
result:=false;
end;
end
else
begin
Message(cg_e_invalid_qualifier);
result:=false;
end;
end
else
begin
Message(cg_e_invalid_qualifier);
result:=false;
end;
consume(_ID);
end;
_LECKKLAMMER :
begin
consume(_LECKKLAMMER);
repeat
if def.deftype=arraydef then
begin
idx:=get_intconst;
pl.addconst(sl_vec,idx);
def:=tarraydef(def).elementtype.def;
end
else
begin
Message(cg_e_invalid_qualifier);
result:=false;
end;
until not try_to_consume(_COMMA);
consume(_RECKKLAMMER);
end;
else
begin
Message(parser_e_ill_property_access_sym);
result:=false;
break;
end;
end;
until false;
end
else
begin
Message(parser_e_ill_property_access_sym);
result:=false;
end;
end;
var
sym : tsym;
p : tpropertysym;
overriden : tsym;
hs : string;
varspez : tvarspez;
s : string;
tt : ttype;
arraytype : ttype;
def : tdef;
pt : tnode;
propname : stringid;
sc : tsinglelist;
oldregisterdef : boolean;
readvs,
hvs : tvarsym;
readprocdef,
writeprocdef : tprocvardef;
begin
{ Generate temp procvardefs to search for matching read/write
procedures. the readprocdef will store all definitions }
oldregisterdef:=registerdef;
registerdef:=false;
readprocdef:=tprocvardef.create(normal_function_level);
writeprocdef:=tprocvardef.create(normal_function_level);
registerdef:=oldregisterdef;
{ make it method pointers }
if assigned(aclass) then
begin
include(readprocdef.procoptions,po_methodpointer);
include(writeprocdef.procoptions,po_methodpointer);
end;
if token<>_ID then
begin
consume(_ID);
consume(_SEMICOLON);
exit;
end;
{ Generate propertysym and insert in symtablestack }
p:=tpropertysym.create(orgpattern);
symtablestack.insert(p);
propname:=pattern;
consume(_ID);
{ Set the symtablestack to the parast of readprop so
temp defs will be destroyed after declaration }
readprocdef.parast.next:=symtablestack;
symtablestack:=readprocdef.parast;
{ property parameters ? }
if token=_LECKKLAMMER then
begin
if (sp_published in current_object_option) then
Message(parser_e_cant_publish_that_property);
{ create a list of the parameters }
sc:=tsinglelist.create;
consume(_LECKKLAMMER);
inc(testcurobject);
repeat
if token=_VAR then
begin
consume(_VAR);
varspez:=vs_var;
end
else if token=_CONST then
begin
consume(_CONST);
varspez:=vs_const;
end
else if (idtoken=_OUT) and (m_out in aktmodeswitches) then
begin
consume(_OUT);
varspez:=vs_out;
end
else
varspez:=vs_value;
sc.reset;
repeat
readvs:=tvarsym.create(orgpattern,varspez,generrortype);
readprocdef.parast.insert(readvs);
sc.insert(readvs);
consume(_ID);
until not try_to_consume(_COMMA);
if token=_COLON then
begin
consume(_COLON);
if token=_ARRAY then
begin
consume(_ARRAY);
consume(_OF);
{ define range and type of range }
tt.setdef(tarraydef.create(0,-1,s32bittype));
{ define field type }
single_type(arraytype,s,false);
tarraydef(tt.def).setelementtype(arraytype);
end
else
single_type(tt,s,false);
end
else
tt:=cformaltype;
readvs:=tvarsym(sc.first);
while assigned(readvs) do
begin
readprocdef.concatpara(nil,tt,readvs,nil,false);
{ also update the writeprocdef }
hvs:=tvarsym.create(readvs.realname,vs_value,generrortype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,tt,hvs,nil,false);
readvs:=tvarsym(readvs.listnext);
end;
until not try_to_consume(_SEMICOLON);
sc.free;
dec(testcurobject);
consume(_RECKKLAMMER);
{ the parser need to know if a property has parameters, the
index parameter doesn't count (PFV) }
if readprocdef.minparacount>0 then
include(p.propoptions,ppo_hasparameters);
end;
{ overriden property ? }
{ force property interface
there is a property parameter
a global property }
if (token=_COLON) or (readprocdef.minparacount>0) or (aclass=nil) then
begin
consume(_COLON);
single_type(p.proptype,hs,false);
if (idtoken=_INDEX) then
begin
consume(_INDEX);
pt:=comp_expr(true);
if is_constnode(pt) and
is_ordinal(pt.resulttype.def) and
(not is_64bitint(pt.resulttype.def)) then
p.index:=tordconstnode(pt).value
else
begin
Message(parser_e_invalid_property_index_value);
p.index:=0;
end;
p.indextype.setdef(pt.resulttype.def);
include(p.propoptions,ppo_indexed);
{ concat a longint to the para templates }
hvs:=tvarsym.create('$index',vs_value,p.indextype);
readprocdef.parast.insert(hvs);
readprocdef.concatpara(nil,p.indextype,hvs,nil,false);
hvs:=tvarsym.create('$index',vs_value,p.indextype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,p.indextype,hvs,nil,false);
pt.free;
end;
end
else
begin
{ do an property override }
overriden:=search_class_member(aclass.childof,propname);
if assigned(overriden) and (overriden.typ=propertysym) then
begin
p.dooverride(tpropertysym(overriden));
end
else
begin
p.proptype:=generrortype;
message(parser_e_no_property_found_to_override);
end;
end;
if (sp_published in current_object_option) and
not(p.proptype.def.is_publishable) then
Message(parser_e_cant_publish_that_property);
if try_to_consume(_READ) then
begin
p.readaccess.clear;
if parse_symlist(p.readaccess,def) then
begin
sym:=p.readaccess.firstsym^.sym;
case sym.typ of
procsym :
begin
{ read is function returning the type of the property }
readprocdef.rettype:=p.proptype;
{ Insert hidden parameters }
handle_calling_convention(readprocdef);
calc_parast(readprocdef);
{ search procdefs matching readprocdef }
p.readaccess.procdef:=Tprocsym(sym).search_procdef_bypara(readprocdef.para,p.proptype.def,[cpo_allowdefaults]);
if not assigned(p.readaccess.procdef) then
Message(parser_e_ill_property_access_sym);
end;
varsym :
begin
if not assigned(def) then
internalerror(200310071);
if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
begin
{ property parameters are allowed if this is
an indexed property, because the index is then
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) then
Message(parser_e_ill_property_access_sym);
end
else
IncompatibleTypes(def,p.proptype.def);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end;
end;
if try_to_consume(_WRITE) then
begin
p.writeaccess.clear;
if parse_symlist(p.writeaccess,def) then
begin
sym:=p.writeaccess.firstsym^.sym;
case sym.typ of
procsym :
begin
{ write is a procedure with an extra value parameter
of the of the property }
writeprocdef.rettype:=voidtype;
hvs:=tvarsym.create('$value',vs_value,p.proptype);
writeprocdef.parast.insert(hvs);
writeprocdef.concatpara(nil,p.proptype,hvs,nil,false);
{ Insert hidden parameters }
handle_calling_convention(writeprocdef);
calc_parast(writeprocdef);
{ search procdefs matching writeprocdef }
p.writeaccess.procdef:=Tprocsym(sym).search_procdef_bypara(writeprocdef.para,writeprocdef.rettype.def,[cpo_allowdefaults]);
if not assigned(p.writeaccess.procdef) then
Message(parser_e_ill_property_access_sym);
end;
varsym :
begin
if not assigned(def) then
internalerror(200310072);
if compare_defs(def,p.proptype.def,nothingn)>=te_equal then
begin
{ property parameters are allowed if this is
an indexed property, because the index is then
the parameter.
Note: In the help of Kylix it is written
that it isn't allowed, but the compiler accepts it (PFV) }
if (ppo_hasparameters in p.propoptions) then
Message(parser_e_ill_property_access_sym);
end
else
IncompatibleTypes(def,p.proptype.def);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end;
end;
if assigned(aclass) then
begin
include(p.propoptions,ppo_stored);
if try_to_consume(_STORED) then
begin
p.storedaccess.clear;
case token of
_ID:
begin
{ in the case that idtoken=_DEFAULT }
{ we have to do nothing except }
{ setting ppo_stored, it's the same }
{ as stored true }
if idtoken<>_DEFAULT then
begin
if parse_symlist(p.storedaccess,def) then
begin
sym:=p.storedaccess.firstsym^.sym;
case sym.typ of
procsym :
begin
p.storedaccess.procdef:=Tprocsym(sym).search_procdef_nopara_boolret;
if not assigned(p.storedaccess.procdef) then
message(parser_e_ill_property_storage_sym);
end;
varsym :
begin
if not assigned(def) then
internalerror(200310073);
if (ppo_hasparameters in p.propoptions) or
not(is_boolean(def)) then
Message(parser_e_stored_property_must_be_boolean);
end;
else
Message(parser_e_ill_property_access_sym);
end;
end;
end;
end;
_FALSE:
begin
consume(_FALSE);
exclude(p.propoptions,ppo_stored);
end;
_TRUE:
consume(_TRUE);
end;
end;
end;
if try_to_consume(_DEFAULT) then
begin
if not(is_ordinal(p.proptype.def) or
is_64bitint(p.proptype.def) or
is_class(p.proptype.def) or
is_single(p.proptype.def) or
(p.proptype.def.deftype in [classrefdef,pointerdef]) or
((p.proptype.def.deftype=setdef) and
(tsetdef(p.proptype.def).settype=smallset))) or
((p.proptype.def.deftype=arraydef) and
(ppo_indexed in p.propoptions)) or
(ppo_hasparameters in p.propoptions) then
begin
Message(parser_e_property_cant_have_a_default_value);
{ Error recovery }
pt:=comp_expr(true);
pt.free;
end
else
begin
{ Get the result of the default, the firstpass is
needed to support values like -1 }
pt:=comp_expr(true);
if (p.proptype.def.deftype=setdef) and
(pt.nodetype=arrayconstructorn) then
begin
arrayconstructor_to_set(pt);
do_resulttypepass(pt);
end;
inserttypeconv(pt,p.proptype);
if not(is_constnode(pt)) then
Message(parser_e_property_default_value_must_const);
{ Set default value }
case pt.nodetype of
setconstn :
p.default:=plongint(tsetconstnode(pt).value_set)^;
ordconstn :
p.default:=tordconstnode(pt).value;
niln :
p.default:=0;
realconstn:
p.default:=longint(single(trealconstnode(pt).value_real));
end;
pt.free;
end;
end
else if try_to_consume(_NODEFAULT) then
begin
p.default:=0;
end;
{ remove temporary procvardefs }
symtablestack:=symtablestack.next;
readprocdef.free;
writeprocdef.free;
result:=p;
end;
const
variantrecordlevel : longint = 0;
@ -659,7 +1152,10 @@ implementation
end.
{
$Log$
Revision 1.58 2003-11-23 17:05:15 peter
Revision 1.59 2003-12-10 16:37:01 peter
* global property support for fpc modes
Revision 1.58 2003/11/23 17:05:15 peter
* register calling is left-right
* parameter ordering
* left-right calling inserts result parameter last

52
compiler/psub.pas
View File

@ -1229,17 +1229,11 @@ implementation
internalerror(200304251);
case token of
_LABEL:
begin
label_dec;
end;
label_dec;
_CONST:
begin
const_dec;
end;
const_dec;
_TYPE:
begin
type_dec;
end;
type_dec;
_VAR:
var_dec;
_THREADVAR:
@ -1251,8 +1245,6 @@ implementation
_OPERATOR,
_CLASS:
read_proc;
_RESOURCESTRING:
resourcestring_dec;
_EXPORTS:
begin
if not(assigned(current_procinfo.procdef.localst)) or
@ -1272,7 +1264,21 @@ implementation
end;
end
else
break;
begin
case idtoken of
_RESOURCESTRING :
resourcestring_dec;
_PROPERTY:
begin
if (m_fpc in aktmodeswitches) then
property_dec
else
break;
end;
else
break;
end;
end;
end;
until false;
@ -1301,10 +1307,19 @@ implementation
read_proc;
else
begin
if idtoken=_RESOURCESTRING then
resourcestring_dec
else
break;
case idtoken of
_RESOURCESTRING :
resourcestring_dec;
_PROPERTY:
begin
if (m_fpc in aktmodeswitches) then
property_dec
else
break;
end;
else
break;
end;
end;
end;
until false;
@ -1318,7 +1333,10 @@ implementation
end.
{
$Log$
Revision 1.175 2003-12-03 23:13:20 peter
Revision 1.176 2003-12-10 16:37:01 peter
* global property support for fpc modes
Revision 1.175 2003/12/03 23:13:20 peter
* delayed paraloc allocation, a_param_*() gets extra parameter
if it needs to allocate temp or real paralocation
* optimized/simplified int-real loading