1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153 |
- {
- $Id$
- Copyright (c) 2000-2002 by Florian Klaempfl
- Type checking and register allocation for memory related nodes
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit nmem;
- {$i fpcdefs.inc}
- interface
- uses
- node,
- symtype,symppu,symdef,symsym,symtable,
- cpubase;
- type
- tloadvmtaddrnode = class(tunarynode)
- constructor create(l : tnode);virtual;
- function pass_1 : tnode;override;
- function det_resulttype:tnode;override;
- end;
- tloadvmtaddrnodeclass = class of tloadvmtaddrnode;
- tloadparentfpnode = class(tunarynode)
- parentpd : tprocdef;
- constructor create(pd:tprocdef);virtual;
- function pass_1 : tnode;override;
- function det_resulttype:tnode;override;
- function getcopy : tnode;override;
- end;
- tloadparentfpnodeclass = class of tloadparentfpnode;
- taddrnode = class(tunarynode)
- getprocvardef : tprocvardef;
- getprocvardefderef : tderef;
- constructor create(l : tnode);virtual;
- constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- procedure mark_write;override;
- procedure buildderefimpl;override;
- procedure derefimpl;override;
- function getcopy : tnode;override;
- function pass_1 : tnode;override;
- function det_resulttype:tnode;override;
- end;
- taddrnodeclass = class of taddrnode;
- tderefnode = class(tunarynode)
- constructor create(l : tnode);virtual;
- function pass_1 : tnode;override;
- function det_resulttype:tnode;override;
- procedure mark_write;override;
- end;
- tderefnodeclass = class of tderefnode;
- tsubscriptnode = class(tunarynode)
- vs : tvarsym;
- vsderef : tderef;
- constructor create(varsym : tsym;l : tnode);virtual;
- constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- procedure buildderefimpl;override;
- procedure derefimpl;override;
- function getcopy : tnode;override;
- function pass_1 : tnode;override;
- function docompare(p: tnode): boolean; override;
- function det_resulttype:tnode;override;
- procedure mark_write;override;
- end;
- tsubscriptnodeclass = class of tsubscriptnode;
- tvecnode = class(tbinarynode)
- constructor create(l,r : tnode);virtual;
- function pass_1 : tnode;override;
- function det_resulttype:tnode;override;
- procedure mark_write;override;
- end;
- tvecnodeclass = class of tvecnode;
- twithnode = class(tunarynode)
- withsymtable : twithsymtable;
- tablecount : longint;
- withrefnode : tnode;
- constructor create(l:tnode;symtable:twithsymtable;count:longint;r:tnode);
- destructor destroy;override;
- constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;
- procedure ppuwrite(ppufile:tcompilerppufile);override;
- function getcopy : tnode;override;
- function pass_1 : tnode;override;
- function docompare(p: tnode): boolean; override;
- function det_resulttype:tnode;override;
- end;
- twithnodeclass = class of twithnode;
- var
- cloadvmtaddrnode : tloadvmtaddrnodeclass;
- cloadparentfpnode : tloadparentfpnodeclass;
- caddrnode : taddrnodeclass;
- cderefnode : tderefnodeclass;
- csubscriptnode : tsubscriptnodeclass;
- cvecnode : tvecnodeclass;
- cwithnode : twithnodeclass;
- implementation
- uses
- globtype,systems,
- cutils,verbose,globals,
- symconst,symbase,defutil,defcmp,
- nbas,
- htypechk,pass_1,ncal,nld,ncon,ncnv,cgbase,procinfo
- ;
- {*****************************************************************************
- TLOADVMTADDRNODE
- *****************************************************************************}
- constructor tloadvmtaddrnode.create(l : tnode);
- begin
- inherited create(loadvmtaddrn,l);
- end;
- function tloadvmtaddrnode.det_resulttype:tnode;
- begin
- result:=nil;
- resulttypepass(left);
- if codegenerror then
- exit;
- case left.resulttype.def.deftype of
- classrefdef :
- resulttype:=left.resulttype;
- objectdef :
- resulttype.setdef(tclassrefdef.create(left.resulttype));
- else
- Message(parser_e_pointer_to_class_expected);
- end;
- end;
- function tloadvmtaddrnode.pass_1 : tnode;
- begin
- result:=nil;
- expectloc:=LOC_REGISTER;
- if left.nodetype<>typen then
- begin
- firstpass(left);
- registers32:=left.registers32;
- end;
- if registers32<1 then
- registers32:=1;
- end;
- {*****************************************************************************
- TLOADPARENTFPNODE
- *****************************************************************************}
- constructor tloadparentfpnode.create(pd:tprocdef);
- begin
- inherited create(loadparentfpn,nil);
- if not assigned(pd) then
- internalerror(200309288);
- if (pd.parast.symtablelevel>current_procinfo.procdef.parast.symtablelevel) then
- internalerror(200309284);
- parentpd:=pd;
- end;
- function tloadparentfpnode.getcopy : tnode;
- var
- p : tloadparentfpnode;
- begin
- p:=tloadparentfpnode(inherited getcopy);
- p.parentpd:=parentpd;
- getcopy:=p;
- end;
- function tloadparentfpnode.det_resulttype:tnode;
- begin
- result:=nil;
- resulttype:=voidpointertype;
- end;
- function tloadparentfpnode.pass_1 : tnode;
- begin
- result:=nil;
- expectloc:=LOC_REGISTER;
- registers32:=1;
- end;
- {*****************************************************************************
- TADDRNODE
- *****************************************************************************}
- constructor taddrnode.create(l : tnode);
- begin
- inherited create(addrn,l);
- getprocvardef:=nil;
- end;
- constructor taddrnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
- begin
- inherited ppuload(t,ppufile);
- ppufile.getderef(getprocvardefderef);
- end;
- procedure taddrnode.ppuwrite(ppufile:tcompilerppufile);
- begin
- inherited ppuwrite(ppufile);
- ppufile.putderef(getprocvardefderef);
- end;
- procedure Taddrnode.mark_write;
- begin
- {@procvar:=nil is legal in Delphi mode.}
- left.mark_write;
- end;
- procedure taddrnode.buildderefimpl;
- begin
- inherited buildderefimpl;
- getprocvardefderef.build(getprocvardef);
- end;
- procedure taddrnode.derefimpl;
- begin
- inherited derefimpl;
- getprocvardef:=tprocvardef(getprocvardefderef.resolve);
- end;
- function taddrnode.getcopy : tnode;
- var
- p : taddrnode;
- begin
- p:=taddrnode(inherited getcopy);
- p.getprocvardef:=getprocvardef;
- getcopy:=p;
- end;
- function taddrnode.det_resulttype:tnode;
- var
- hp : tnode;
- hp2 : TParaItem;
- hp3 : tabstractprocdef;
- begin
- result:=nil;
- resulttypepass(left);
- if codegenerror then
- exit;
- { don't allow constants }
- if is_constnode(left) then
- begin
- aktfilepos:=left.fileinfo;
- CGMessage(type_e_no_addr_of_constant);
- exit;
- end;
- { tp @procvar support (type of @procvar is a void pointer)
- Note: we need to leave the addrn in the tree,
- else we can't see the difference between @procvar and procvar.
- we set the procvarload flag so a secondpass does nothing for
- this node (PFV) }
- if (m_tp_procvar in aktmodeswitches) then
- begin
- case left.nodetype of
- calln :
- begin
- { a load of a procvar can't have parameters }
- if assigned(tcallnode(left).left) then
- CGMessage(cg_e_illegal_expression);
- { is it a procvar? }
- hp:=tcallnode(left).right;
- if assigned(hp) then
- begin
- { remove calln node }
- tcallnode(left).right:=nil;
- left.free;
- left:=hp;
- include(flags,nf_procvarload);
- end;
- end;
- loadn,
- subscriptn,
- typeconvn,
- vecn,
- derefn :
- begin
- if left.resulttype.def.deftype=procvardef then
- include(flags,nf_procvarload);
- end;
- end;
- if nf_procvarload in flags then
- begin
- resulttype:=voidpointertype;
- exit;
- end;
- end;
- { proc 2 procvar ? }
- if left.nodetype=calln then
- { if it were a valid construct, the addr node would already have }
- { been removed in the parser. This happens for (in FPC mode) }
- { procvar1 := @procvar2(parameters); }
- CGMessage(cg_e_illegal_expression)
- else
- if (left.nodetype=loadn) and (tloadnode(left).symtableentry.typ=procsym) then
- begin
- { the address is already available when loading a procedure of object }
- if assigned(tloadnode(left).left) then
- include(flags,nf_procvarload);
- { result is a procedure variable }
- { No, to be TP compatible, you must return a voidpointer to
- the procedure that is stored in the procvar.}
- if not(m_tp_procvar in aktmodeswitches) then
- begin
- if assigned(getprocvardef) and
- (tprocsym(tloadnode(left).symtableentry).procdef_count>1) then
- begin
- hp3:=tprocsym(tloadnode(left).symtableentry).search_procdef_byprocvardef(getprocvardef);
- if not assigned(hp3) then
- begin
- IncompatibleTypes(tprocsym(tloadnode(left).symtableentry).first_procdef,getprocvardef);
- exit;
- end;
- end
- else
- hp3:=tabstractprocdef(tprocsym(tloadnode(left).symtableentry).first_procdef);
- { create procvardef }
- resulttype.setdef(tprocvardef.create(hp3.parast.symtablelevel));
- tprocvardef(resulttype.def).proctypeoption:=hp3.proctypeoption;
- tprocvardef(resulttype.def).proccalloption:=hp3.proccalloption;
- tprocvardef(resulttype.def).procoptions:=hp3.procoptions;
- tprocvardef(resulttype.def).rettype:=hp3.rettype;
- { method ? then set the methodpointer flag }
- if (hp3.owner.symtabletype=objectsymtable) then
- include(tprocvardef(resulttype.def).procoptions,po_methodpointer);
- { only need the address of the method? this is needed
- for @tobject.create }
- if not assigned(tloadnode(left).left) then
- include(tprocvardef(resulttype.def).procoptions,po_addressonly);
- { Add parameters in left to right order }
- hp2:=TParaItem(hp3.Para.first);
- while assigned(hp2) do
- begin
- tprocvardef(resulttype.def).concatpara(nil,hp2.paratype,hp2.parasym,
- hp2.defaultvalue,hp2.is_hidden);
- hp2:=TParaItem(hp2.next);
- end;
- end
- else
- resulttype:=voidpointertype;
- end
- else
- begin
- { what are we getting the address from an absolute sym? }
- hp:=left;
- while assigned(hp) and (hp.nodetype in [vecn,derefn,subscriptn]) do
- hp:=tunarynode(hp).left;
- if assigned(hp) and (hp.nodetype=loadn) and
- ((tloadnode(hp).symtableentry.typ=absolutesym) and
- tabsolutesym(tloadnode(hp).symtableentry).absseg) then
- begin
- if not(cs_typed_addresses in aktlocalswitches) then
- resulttype:=voidfarpointertype
- else
- resulttype.setdef(tpointerdef.createfar(left.resulttype));
- end
- else
- begin
- if not(cs_typed_addresses in aktlocalswitches) then
- resulttype:=voidpointertype
- else
- resulttype.setdef(tpointerdef.create(left.resulttype));
- end;
- end;
- { this is like the function addr }
- inc(parsing_para_level);
- set_varstate(left,vs_used,false);
- dec(parsing_para_level);
- end;
- function taddrnode.pass_1 : tnode;
- begin
- result:=nil;
- firstpass(left);
- if codegenerror then
- exit;
- make_not_regable(left);
- if nf_procvarload in flags then
- begin
- registers32:=left.registers32;
- registersfpu:=left.registersfpu;
- {$ifdef SUPPORT_MMX}
- registersmmx:=left.registersmmx;
- {$endif SUPPORT_MMX}
- if registers32<1 then
- registers32:=1;
- expectloc:=left.expectloc;
- exit;
- end;
- { we should allow loc_mem for @string }
- if not(left.expectloc in [LOC_CREFERENCE,LOC_REFERENCE]) then
- begin
- aktfilepos:=left.fileinfo;
- CGMessage(cg_e_illegal_expression);
- end;
- registers32:=left.registers32;
- registersfpu:=left.registersfpu;
- {$ifdef SUPPORT_MMX}
- registersmmx:=left.registersmmx;
- {$endif SUPPORT_MMX}
- if registers32<1 then
- registers32:=1;
- { is this right for object of methods ?? }
- expectloc:=LOC_REGISTER;
- end;
- {*****************************************************************************
- TDEREFNODE
- *****************************************************************************}
- constructor tderefnode.create(l : tnode);
- begin
- inherited create(derefn,l);
- end;
- function tderefnode.det_resulttype:tnode;
- begin
- result:=nil;
- resulttypepass(left);
- set_varstate(left,vs_used,true);
- if codegenerror then
- exit;
- if left.resulttype.def.deftype=pointerdef then
- resulttype:=tpointerdef(left.resulttype.def).pointertype
- else
- CGMessage(cg_e_invalid_qualifier);
- end;
- procedure Tderefnode.mark_write;
- begin
- include(flags,nf_write);
- end;
- function tderefnode.pass_1 : tnode;
- begin
- result:=nil;
- firstpass(left);
- if codegenerror then
- exit;
- registers32:=max(left.registers32,1);
- registersfpu:=left.registersfpu;
- {$ifdef SUPPORT_MMX}
- registersmmx:=left.registersmmx;
- {$endif SUPPORT_MMX}
- expectloc:=LOC_REFERENCE;
- end;
- {*****************************************************************************
- TSUBSCRIPTNODE
- *****************************************************************************}
- constructor tsubscriptnode.create(varsym : tsym;l : tnode);
- begin
- inherited create(subscriptn,l);
- { vs should be changed to tsym! }
- vs:=tvarsym(varsym);
- end;
- constructor tsubscriptnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
- begin
- inherited ppuload(t,ppufile);
- ppufile.getderef(vsderef);
- end;
- procedure tsubscriptnode.ppuwrite(ppufile:tcompilerppufile);
- begin
- inherited ppuwrite(ppufile);
- ppufile.putderef(vsderef);
- end;
- procedure tsubscriptnode.buildderefimpl;
- begin
- inherited buildderefimpl;
- vsderef.build(vs);
- end;
- procedure tsubscriptnode.derefimpl;
- begin
- inherited derefimpl;
- vs:=tvarsym(vsderef.resolve);
- end;
- function tsubscriptnode.getcopy : tnode;
- var
- p : tsubscriptnode;
- begin
- p:=tsubscriptnode(inherited getcopy);
- p.vs:=vs;
- getcopy:=p;
- end;
- function tsubscriptnode.det_resulttype:tnode;
- begin
- result:=nil;
- resulttypepass(left);
- resulttype:=vs.vartype;
- end;
- procedure Tsubscriptnode.mark_write;
- begin
- include(flags,nf_write);
- end;
- function tsubscriptnode.pass_1 : tnode;
- begin
- result:=nil;
- firstpass(left);
- if codegenerror then
- exit;
- registers32:=left.registers32;
- registersfpu:=left.registersfpu;
- {$ifdef SUPPORT_MMX}
- registersmmx:=left.registersmmx;
- {$endif SUPPORT_MMX}
- { classes must be dereferenced implicit }
- if is_class_or_interface(left.resulttype.def) then
- begin
- if registers32=0 then
- registers32:=1;
- expectloc:=LOC_REFERENCE;
- end
- else
- begin
- if (left.expectloc<>LOC_CREFERENCE) and
- (left.expectloc<>LOC_REFERENCE) then
- CGMessage(cg_e_illegal_expression);
- expectloc:=left.expectloc;
- end;
- end;
- function tsubscriptnode.docompare(p: tnode): boolean;
- begin
- docompare :=
- inherited docompare(p) and
- (vs = tsubscriptnode(p).vs);
- end;
- {*****************************************************************************
- TVECNODE
- *****************************************************************************}
- constructor tvecnode.create(l,r : tnode);
- begin
- inherited create(vecn,l,r);
- end;
- function tvecnode.det_resulttype:tnode;
- var
- htype : ttype;
- begin
- result:=nil;
- resulttypepass(left);
- resulttypepass(right);
- if codegenerror then
- exit;
- { maybe type conversion for the index value, but
- do not convert enums,booleans,char }
- if (right.resulttype.def.deftype<>enumdef) and
- not(is_char(right.resulttype.def)) and
- not(is_boolean(right.resulttype.def)) then
- begin
- inserttypeconv(right,s32bittype);
- end;
- case left.resulttype.def.deftype of
- arraydef :
- begin
- { check type of the index value }
- if (compare_defs(right.resulttype.def,tarraydef(left.resulttype.def).rangetype.def,right.nodetype)=te_incompatible) then
- CGMessage(type_e_mismatch);
- resulttype:=tarraydef(left.resulttype.def).elementtype;
- end;
- pointerdef :
- begin
- { are we accessing a pointer[], then convert the pointer to
- an array first, in FPC this is allowed for all pointers in
- delphi/tp7 it's only allowed for pchars }
- if (m_fpc in aktmodeswitches) or
- is_pchar(left.resulttype.def) or
- is_pwidechar(left.resulttype.def) then
- begin
- { convert pointer to array }
- htype.setdef(tarraydef.create(0,$7fffffff,s32bittype));
- tarraydef(htype.def).setelementtype(tpointerdef(left.resulttype.def).pointertype);
- inserttypeconv(left,htype);
- resulttype:=tarraydef(htype.def).elementtype;
- end
- else
- CGMessage(type_e_array_required);
- end;
- stringdef :
- begin
- { indexed access to 0 element is only allowed for shortstrings }
- if (right.nodetype=ordconstn) and
- (tordconstnode(right).value=0) and
- not(is_shortstring(left.resulttype.def)) then
- CGMessage(cg_e_can_access_element_zero);
- case tstringdef(left.resulttype.def).string_typ of
- st_widestring :
- resulttype:=cwidechartype;
- st_ansistring :
- resulttype:=cchartype;
- st_longstring :
- resulttype:=cchartype;
- st_shortstring :
- resulttype:=cchartype;
- end;
- end
- else
- CGMessage(type_e_array_required);
- end;
- end;
- procedure Tvecnode.mark_write;
- begin
- include(flags,nf_write);
- end;
- function tvecnode.pass_1 : tnode;
- {$ifdef consteval}
- var
- tcsym : ttypedconstsym;
- {$endif}
- begin
- result:=nil;
- firstpass(left);
- firstpass(right);
- if codegenerror then
- exit;
- if (nf_callunique in flags) and
- (is_ansistring(left.resulttype.def) or
- is_widestring(left.resulttype.def)) then
- begin
- left := ctypeconvnode.create_explicit(ccallnode.createintern('fpc_'+tstringdef(left.resulttype.def).stringtypname+'_unique',
- ccallparanode.create(
- ctypeconvnode.create_explicit(left,voidpointertype),nil)),
- left.resulttype);
- firstpass(left);
- { double resulttype passes somwhere else may cause this to be }
- { reset though :/ }
- exclude(flags,nf_callunique);
- end;
- { the register calculation is easy if a const index is used }
- if right.nodetype=ordconstn then
- begin
- {$ifdef consteval}
- { constant evaluation }
- if (left.nodetype=loadn) and
- (left.symtableentry.typ=typedconstsym) then
- begin
- tcsym:=ttypedconstsym(left.symtableentry);
- if tcsym.defintion^.typ=stringdef then
- begin
- end;
- end;
- {$endif}
- registers32:=left.registers32;
- { for ansi/wide strings, we need at least one register }
- if is_ansistring(left.resulttype.def) or
- is_widestring(left.resulttype.def) or
- { ... as well as for dynamic arrays }
- is_dynamic_array(left.resulttype.def) then
- registers32:=max(registers32,1);
- end
- else
- begin
- { this rules are suboptimal, but they should give }
- { good results }
- registers32:=max(left.registers32,right.registers32);
- { for ansi/wide strings, we need at least one register }
- if is_ansistring(left.resulttype.def) or
- is_widestring(left.resulttype.def) or
- { ... as well as for dynamic arrays }
- is_dynamic_array(left.resulttype.def) then
- registers32:=max(registers32,1);
- { need we an extra register when doing the restore ? }
- if (left.registers32<=right.registers32) and
- { only if the node needs less than 3 registers }
- { two for the right node and one for the }
- { left address }
- (registers32<3) then
- inc(registers32);
- { need we an extra register for the index ? }
- if (right.expectloc<>LOC_REGISTER)
- { only if the right node doesn't need a register }
- and (right.registers32<1) then
- inc(registers32);
- { not correct, but what works better ?
- if left.registers32>0 then
- registers32:=max(registers32,2)
- else
- min. one register
- registers32:=max(registers32,1);
- }
- end;
- registersfpu:=max(left.registersfpu,right.registersfpu);
- {$ifdef SUPPORT_MMX}
- registersmmx:=max(left.registersmmx,right.registersmmx);
- {$endif SUPPORT_MMX}
- if left.expectloc=LOC_CREFERENCE then
- expectloc:=LOC_CREFERENCE
- else
- expectloc:=LOC_REFERENCE;
- end;
- {*****************************************************************************
- TWITHNODE
- *****************************************************************************}
- constructor twithnode.create(l:tnode;symtable:twithsymtable;count:longint;r:tnode);
- begin
- inherited create(withn,l);
- withrefnode:=r;
- withsymtable:=symtable;
- tablecount:=count;
- set_file_line(l);
- end;
- destructor twithnode.destroy;
- var
- hsymt,
- symt : tsymtable;
- i : longint;
- begin
- symt:=withsymtable;
- for i:=1 to tablecount do
- begin
- if assigned(symt) then
- begin
- hsymt:=symt.next;
- symt.free;
- symt:=hsymt;
- end;
- end;
- inherited destroy;
- end;
- constructor twithnode.ppuload(t:tnodetype;ppufile:tcompilerppufile);
- begin
- inherited ppuload(t,ppufile);
- internalerror(200208192);
- end;
- procedure twithnode.ppuwrite(ppufile:tcompilerppufile);
- begin
- inherited ppuwrite(ppufile);
- internalerror(200208193);
- end;
- function twithnode.getcopy : tnode;
- var
- p : twithnode;
- begin
- p:=twithnode(inherited getcopy);
- p.withsymtable:=withsymtable;
- p.tablecount:=tablecount;
- if assigned(p.withrefnode) then
- p.withrefnode:=withrefnode.getcopy
- else
- p.withrefnode:=nil;
- result:=p;
- end;
- function twithnode.det_resulttype:tnode;
- begin
- result:=nil;
- resulttype:=voidtype;
- resulttypepass(withrefnode);
- //unset_varstate(withrefnode);
- set_varstate(withrefnode,vs_used,true);
- if codegenerror then
- exit;
- if (withrefnode.nodetype=vecn) and
- (nf_memseg in withrefnode.flags) then
- CGMessage(parser_e_no_with_for_variable_in_other_segments);
- if assigned(left) then
- resulttypepass(left);
- end;
- function twithnode.pass_1 : tnode;
- begin
- result:=nil;
- expectloc:=LOC_VOID;
- if assigned(left) then
- begin
- firstpass(left);
- registers32:=left.registers32;
- registersfpu:=left.registersfpu;
- {$ifdef SUPPORT_MMX}
- registersmmx:=left.registersmmx;
- {$endif SUPPORT_MMX}
- end;
- if assigned(withrefnode) then
- begin
- firstpass(withrefnode);
- if withrefnode.registers32 > registers32 then
- registers32:=withrefnode.registers32;
- if withrefnode.registersfpu > registersfpu then
- registers32:=withrefnode.registersfpu;
- {$ifdef SUPPORT_MMX}
- if withrefnode.registersmmx > registersmmx then
- registersmmx:=withrefnode.registersmmx;
- {$endif SUPPORT_MMX}
- end;
- end;
- function twithnode.docompare(p: tnode): boolean;
- begin
- docompare :=
- inherited docompare(p) and
- (withsymtable = twithnode(p).withsymtable) and
- (tablecount = twithnode(p).tablecount) and
- (withrefnode.isequal(twithnode(p).withrefnode));
- end;
- begin
- cloadvmtaddrnode := tloadvmtaddrnode;
- caddrnode := taddrnode;
- cderefnode := tderefnode;
- csubscriptnode := tsubscriptnode;
- cvecnode := tvecnode;
- cwithnode := twithnode;
- end.
- {
- $Log$
- Revision 1.70 2003-10-31 18:44:18 peter
- * don't search for compatible procvars when the proc is not
- overloaded
- Revision 1.69 2003/10/31 15:52:58 peter
- * support creating classes using <class of tobject>.create
- Revision 1.68 2003/10/23 14:44:07 peter
- * splitted buildderef and buildderefimpl to fix interface crc
- calculation
- Revision 1.67 2003/10/22 20:40:00 peter
- * write derefdata in a separate ppu entry
- Revision 1.66 2003/10/21 18:16:13 peter
- * IncompatibleTypes() added that will include unit names when
- the typenames are the same
- Revision 1.65 2003/10/08 19:19:45 peter
- * set_varstate cleanup
- Revision 1.64 2003/10/01 20:34:49 peter
- * procinfo unit contains tprocinfo
- * cginfo renamed to cgbase
- * moved cgmessage to verbose
- * fixed ppc and sparc compiles
- Revision 1.63 2003/09/28 17:55:04 peter
- * parent framepointer changed to hidden parameter
- * tloadparentfpnode added
- Revision 1.62 2003/09/06 22:27:08 florian
- * fixed web bug 2669
- * cosmetic fix in printnode
- * tobjectdef.gettypename implemented
- Revision 1.61 2003/09/03 11:18:37 florian
- * fixed arm concatcopy
- + arm support in the common compiler sources added
- * moved some generic cg code around
- + tfputype added
- * ...
- Revision 1.60 2003/08/10 17:25:23 peter
- * fixed some reported bugs
- Revision 1.59 2003/06/17 19:24:08 jonas
- * fixed conversion of fpc_*str_unique to compilerproc
- Revision 1.58 2003/06/17 16:34:44 jonas
- * lots of newra fixes (need getfuncretparaloc implementation for i386)!
- * renamed all_intregisters to volatile_intregisters and made it
- processor dependent
- Revision 1.57 2003/06/07 20:26:32 peter
- * re-resolving added instead of reloading from ppu
- * tderef object added to store deref info for resolving
- Revision 1.56 2003/06/07 18:57:04 jonas
- + added freeintparaloc
- * ppc get/freeintparaloc now check whether the parameter regs are
- properly allocated/deallocated (and get an extra list para)
- * ppc a_call_* now internalerrors if pi_do_call is not yet set
- * fixed lot of missing pi_do_call's
- Revision 1.55 2003/05/24 17:15:24 jonas
- * added missing firstpass for withrefnode
- Revision 1.54 2003/05/11 14:45:12 peter
- * tloadnode does not support objectsymtable,withsymtable anymore
- * withnode cleanup
- * direct with rewritten to use temprefnode
- Revision 1.53 2003/05/09 17:47:02 peter
- * self moved to hidden parameter
- * removed hdisposen,hnewn,selfn
- Revision 1.52 2003/05/05 14:53:16 peter
- * vs_hidden replaced by is_hidden boolean
- Revision 1.51 2003/04/27 11:21:33 peter
- * aktprocdef renamed to current_procdef
- * procinfo renamed to current_procinfo
- * procinfo will now be stored in current_module so it can be
- cleaned up properly
- * gen_main_procsym changed to create_main_proc and release_main_proc
- to also generate a tprocinfo structure
- * fixed unit implicit initfinal
- Revision 1.50 2003/04/27 07:29:50 peter
- * current_procdef cleanup, current_procdef is now always nil when parsing
- a new procdef declaration
- * aktprocsym removed
- * lexlevel removed, use symtable.symtablelevel instead
- * implicit init/final code uses the normal genentry/genexit
- * funcret state checking updated for new funcret handling
- Revision 1.49 2003/04/23 10:10:54 peter
- * procvar is not compared in addrn
- Revision 1.48 2003/04/22 23:50:23 peter
- * firstpass uses expectloc
- * checks if there are differences between the expectloc and
- location.loc from secondpass in EXTDEBUG
- Revision 1.47 2003/04/10 17:57:52 peter
- * vs_hidden released
- Revision 1.46 2003/01/30 21:46:57 peter
- * self fixes for static methods (merged)
- Revision 1.45 2003/01/09 21:52:37 peter
- * merged some verbosity options.
- * V_LineInfo is a verbosity flag to include line info
- Revision 1.44 2003/01/06 21:16:52 peter
- * po_addressonly added to retrieve the address of a methodpointer
- only, this is used for @tclass.method which has no self pointer
- Revision 1.43 2003/01/04 15:54:03 daniel
- * Fixed mark_write for @ operator
- (can happen when compiling @procvar:=nil (Delphi mode construction))
- Revision 1.42 2003/01/03 12:15:56 daniel
- * Removed ifdefs around notifications
- ifdefs around for loop optimizations remain
- Revision 1.41 2002/11/25 17:43:20 peter
- * splitted defbase in defutil,symutil,defcmp
- * merged isconvertable and is_equal into compare_defs(_ext)
- * made operator search faster by walking the list only once
- Revision 1.40 2002/09/27 21:13:28 carl
- * low-highval always checked if limit ober 2GB is reached (to avoid overflow)
- Revision 1.39 2002/09/01 18:44:17 peter
- * cleanup of tvecnode.det_resulttype
- * move 0 element of string access check to resulttype
- Revision 1.38 2002/09/01 13:28:38 daniel
- - write_access fields removed in favor of a flag
- Revision 1.37 2002/09/01 08:01:16 daniel
- * Removed sets from Tcallnode.det_resulttype
- + Added read/write notifications of variables. These will be usefull
- for providing information for several optimizations. For example
- the value of the loop variable of a for loop does matter is the
- variable is read after the for loop, but if it's no longer used
- or written, it doesn't matter and this can be used to optimize
- the loop code generation.
- Revision 1.36 2002/08/19 19:36:43 peter
- * More fixes for cross unit inlining, all tnodes are now implemented
- * Moved pocall_internconst to po_internconst because it is not a
- calling type at all and it conflicted when inlining of these small
- functions was requested
- Revision 1.35 2002/07/23 09:51:23 daniel
- * Tried to make Tprocsym.defs protected. I didn't succeed but the cleanups
- are worth comitting.
- Revision 1.34 2002/07/20 11:57:54 florian
- * types.pas renamed to defbase.pas because D6 contains a types
- unit so this would conflicts if D6 programms are compiled
- + Willamette/SSE2 instructions to assembler added
- Revision 1.33 2002/05/18 13:34:10 peter
- * readded missing revisions
- Revision 1.32 2002/05/16 19:46:39 carl
- + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
- + try to fix temp allocation (still in ifdef)
- + generic constructor calls
- + start of tassembler / tmodulebase class cleanup
- Revision 1.30 2002/05/12 16:53:07 peter
- * moved entry and exitcode to ncgutil and cgobj
- * foreach gets extra argument for passing local data to the
- iterator function
- * -CR checks also class typecasts at runtime by changing them
- into as
- * fixed compiler to cycle with the -CR option
- * fixed stabs with elf writer, finally the global variables can
- be watched
- * removed a lot of routines from cga unit and replaced them by
- calls to cgobj
- * u32bit-s32bit updates for and,or,xor nodes. When one element is
- u32bit then the other is typecasted also to u32bit without giving
- a rangecheck warning/error.
- * fixed pascal calling method with reversing also the high tree in
- the parast, detected by tcalcst3 test
- Revision 1.29 2002/04/21 19:02:04 peter
- * removed newn and disposen nodes, the code is now directly
- inlined from pexpr
- * -an option that will write the secondpass nodes to the .s file, this
- requires EXTDEBUG define to actually write the info
- * fixed various internal errors and crashes due recent code changes
- Revision 1.28 2002/04/20 21:32:23 carl
- + generic FPC_CHECKPOINTER
- + first parameter offset in stack now portable
- * rename some constants
- + move some cpu stuff to other units
- - remove unused constents
- * fix stacksize for some targets
- * fix generic size problems which depend now on EXTEND_SIZE constant
- Revision 1.27 2002/04/02 17:11:29 peter
- * tlocation,treference update
- * LOC_CONSTANT added for better constant handling
- * secondadd splitted in multiple routines
- * location_force_reg added for loading a location to a register
- of a specified size
- * secondassignment parses now first the right and then the left node
- (this is compatible with Kylix). This saves a lot of push/pop especially
- with string operations
- * adapted some routines to use the new cg methods
- Revision 1.26 2002/04/01 20:57:13 jonas
- * fixed web bug 1907
- * fixed some other procvar related bugs (all related to accepting procvar
- constructs with either too many or too little parameters)
- (both merged, includes second typo fix of pexpr.pas)
- }
|