|
|
@@ -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
|
peter